Tag Info

New answers tagged

5

ClearAll[cyclesF, edgesF] cyclesF = Map[FromCharacterCode, 64 + PermutationCycles[ToCharacterCode@# - 64][[1]], {-1}] &; edgesF = Developer`PartitionMap[DirectedEdge @@ # &, #, 2, 1, {1, 1}] & /@ cyclesF[#] &; str = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; colors = {Red, Green, Blue, Orange, Cyan, Yellow}; vl = cyclesF@str; el = ...


4

Not going to win a beauty contest, but you might get some ideas: string = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; rules[cycle_] := Thread[DirectedEdge[cycle, RotateLeft[cycle]]]; edges = MapIndexed[Style[#1, Thick, ColorData[2][#2[[1]]]] &, rules /@ PermutationCycles[LetterNumber /@ Characters[string], Identity], {2}]; verts = ...


5

s = "AJDKSIRUXBLHWTMCQGZNPYFVOE"; pc = PermutationCycles[ToCharacterCode@s - 64] // First; Graph[Flatten[Thread[# -> RotateRight@#] & /@ pc], VertexLabels -> Table[i -> FromCharacterCode[i + 64], {i, Flatten@pc}], ImagePadding -> 12] Perhaps better: pc = (PermutationCycles[ToCharacterCode@s - 64] // First) /. ...


0

Purely functional func[lastr_, {i_, j_}] := MapAt[# + u[[i, j]] &, MapAt[# - u[[i, j]] &, lastr, i], j] Fold[func, r, B] {-∞, ∞, 7, 1, Indeterminate} or Fold[Function[{lastr, ind}, MapAt[# + u[[Sequence @@ ind]] &, MapAt[# - u[[Sequence @@ ind]] &, lastr, First@ind], Last@ind]], r, B]


5

I don't think this is a good example for learning functional style. Of course it can be done as other answers show, but they are cryptic for two reasons: (1) Mathematica doesn't accommodate "for {i, j} in B" (though Simon Woods' answer is pretty close) (2) your code is actually depending on side effects (it is changing r each time the loop iterates) The ...


1

As a place to start I suggest TransformationFunctions: FullSimplify[expr1, TransformationFunctions -> {Automatic, schId, sortarg}] 0 This works even if both sortarg and schId are defined with /. rather than //.. For more manual application consider MapAt. Also familiarize yourself with levelspec.


1

A case not covered yet is if the argument list is held. Starting with a dummy argument list, held: args = Hold[{2+2, 8/4}]; and a dummy head (function) that also that holds its arguments, for illustration: SetAttributes[foo, HoldAll] Here are some options: foo @@@ args // First foo @@@ args // ReleaseHold args /. _[{x___}] :> foo[x] All yield: ...


0

Courant[X_, Y_] := Module[{dim, x, y, \[Lambda], \[Omega]}, dim = Length[X]/2; x = X[[1 ;; dim]]; \[Lambda] = X[[dim + 1 ;; Length[X]]]; dim = Length[Y]/2; y = Y[[1 ;; dim]]; \[Omega] = Y[[dim + 1 ;; Length[Y]]]; Return[Flatten[{LieD[x, y], LieD[x, \[Omega]] - LieD[y,[Lambda]]- (1/2) d[interiorProduct[x, ...


3

A possible implementation of stableList that evaluates fun sequentially: stableList[func_, threshold_, nMax_: Infinity] := NestWhileList[{func[#], #} &[Last@# + 1] &, {func[1], 1}, Abs[First@#1 - First@#2] > threshold &, 2, nMax - 1][[All, 1]] Usage example: fun[x_] := 1/x stableList[fun, 0.01] {1, 1/2, 1/3, 1/4, 1/5, 1/6, ...


3

I think your code is not too bad. In my opinion, the main thing to learn is not to use Append(To) in a loop. Here is an improved version func = 1/# &; intermitThresDif = Function[ {threshold}, Reap[ Module[ {variation, prev, next, j = 1}, prev = func@1; Sow@prev; variation = threshold + 1; While[ ...


7

FixedPointList[f, expr, n, SameTest -> g[e1,e2]] evaluates f[expr] recursively for at most n times. It also stops if g[e1,e2] returns true. e1 and e2 being the most recent values. It is very similar to NestWhileList. There is also a version that returns only the last value, called FixedPoint. Map is not meant to be used sequentially, and so you can't ...


1

This example from the documentation may be instructive for approximation of $\sqrt{2}$: NestWhileList[(# + 2/# )/2 &, 1, Abs[#1 - #2] > 0.001 &, 2] ->{1, 3/2, 17/12, 577/408, 665857/470832}


3

A top-down approach: triangle = Import["https://projecteuler.net/project/resources/p067_triangle.txt", "Table"]; listmod[l_List] := {First@l} ~Join~ Partition[l, 2, 1] ~Join~ {Last@l} mainF[lastList_List, nextList_List] := Max /@ Inner[Plus, listmod[lastList], nextList, List] Max@Fold[mainF, triangle[[1]], triangle[[2 ;;]]] 7273


5

It's quite easy once you realize that the bottom-up max sums give you the desired result: i = Reverse@Import["https://projecteuler.net/project/resources/p067_triangle.txt", "Table"]; f[linPrev_, lin_] := Max /@ (lin + Partition[linPrev, 2, 1]) Fold[f, i] (* {7273} *)


4

You could also use Function[{i, j}, r[[i]] -= u[[i, j]]; r[[j]] += u[[i, j]] ] @@@ B; r or With[{e = Extract[u, B]}, r[[B[[All, 1]]]] -= e; r[[B[[All, 2]]]] += e]; r


3

This is just a way to rewrite the data into a - for our purposes - better format: u = {{1, 2} -> 5, {1, 3} -> 9, {1, 4} -> 6, {1, 5} -> Infinity, {3, 2} -> 2, {3, 4} -> 4, {4, 2} -> 9, {5, 2} -> Infinity, {5, 3} -> Infinity, {5, 4} -> Infinity, {5, 5} -> Infinity}; rules = B //. {a___, {i_Integer, j_Integer}, b___} :> ...


4

What Bill posted as a comment, or for example: {r[[#1]] -= #3, r[[#2]] += #3} & @@@ (Transpose@Join[Transpose@B, {Extract[u, B]}]); r (* {-∞, ∞, 7, 1, Indeterminate} *) The Indeterminate thingy comes from ∞ - ∞


5

beta = .1; m = 50; SeedRandom[42]; {s, i} = RandomReal[{0, 1}, {2, m, m}]; newSI[{s_, i_}] := Clip[{s - #, i + #}] &[beta ListConvolve[CrossMatrix[1], ArrayPad[s i, 1]]] ListAnimate[gr = GraphicsRow /@ Map[MatrixPlot, NestList[newSI, {s, i}, 50], {2}]]


2

GatherBy does exactly what you want. l = {{a, obj1}, {c, obj2}, {a, obj3}, {b, obj4}}; GatherBy[l, First] {{{a, obj1}, {a, obj3}}, {{c, obj2}}, {{b, obj4}}}



Top 50 recent answers are included