I need to enumerate combinations for 3 groups of values that I have. The groups are (a,b,c,d), (e,f,g,h), (i,j,k,l) for example. The total combinations are 4x4x4=64.
Has anyone an idea, how can I define the ascending numbering of these combinations?
I have written something in that form:
Do[Do[Do[x["formula is needed here"]=s[[i,j,k]],{k,1,4}],{j,1,4}],{i,1,4}]
I cannot find the formula for the numbering of the combinations. I have read something about "Generating the mth Lexicographical Element of a Mathematical Combination" but I am more lost than helped. x is supposed to take values 1,2,3,....,64.
Thank you for your suggestions!
if you need a "formula" for the 'nth' tuple it looks like this:
{ Floor[(# - 1)/16 ] + 1,
Floor[Mod[# - 1, 16]/4] + 1 ,
Floor[Mod[# - 1, 4] ] + 1 } & /# Range[64] ==
Tuples[Range[4], 3]
True
so then if you want say the 12'th combination of your sets you could do something like this:
({
Floor[(# - 1)/16] + 1,
Floor[Mod[# - 1, 16]/4 + 1] ,
Mod[# - 1, 4] + 1 } );
{{a, b, c, d}[[%[[1]]]], {e, f, g, h}[[%[[2]]]], {i, j, k,
l}[[%[[3]]]]}
{a, g, l}
note that whatever you are doing it is almost always best to use the built in object oriented functions.
Tuples[{{a, b, c, d}, {e, f, g, h}, {i, j, k, l}}][[12]]
{a, g, l}
Edit: for completeness a generalization of the first expression:
listlen = 6;
nsamp = 4;
Table[Floor[Mod[# - 1, listlen^i]/listlen^(i - 1) + 1], {i, nsamp,
1, -1}] & /# Range[listlen^nsamp] ==
Tuples[Range[listlen], nsamp]
True
Tuples[{{a, b, c, d}, {e, f, g, h}, {i, j, k, l}}]
Related
Suppose I want to construct a matrix A such that A[[i,i]]=f[x_,y_]+d[i], A[[i,i+1]]=u[i], A[[i+1,i]]=l[i], i=1,N . Say, f[x_,y_]=x^2+y^2.
How can I code this in Mathematica?
Additionally, if I want to integrate the first diagonal element of A, i.e. A[[1,1]] over x and y, both running from 0 to 1, how can I do that?
In[1]:= n = 4;
f[x_, y_] := x^2 + y^2;
A = Normal[SparseArray[{
{i_,i_}/;i>1 -> f[x,y]+ d[i],
{i_,j_}/;j-i==1 -> u[i],
{i_,j_}/;i-j==1 -> l[i-1],
{1, 1} -> Integrate[f[x,y]+d[1], {x,0,1}, {y,0,1}]},
{n, n}]]
Out[3]= {{2/3+d[1], l[1], 0, 0},
{u[1], x^2+y^2+ d[2], l[2], 0},
{0, u[2], x^2+y^2+d[3], l[3]},
{0, 0, u[3], x^2+y^2+d[4]}}
Band is tailored specifically for this:
myTridiagonalMatrix#n_Integer?Positive :=
SparseArray[
{ Band#{1, 1} -> f[x, y] + Array[d, n]
, Band#{1, 2} -> Array[u, n - 1]
, Band#{2, 1} -> Array[l, n - 1]}
, {n, n}]
Check it out (no need to define f, d, u, l):
myTridiagonalMatrix#5 // MatrixForm
Note that MatrixForm should not be part of a definition. For example, it's a bad idea to set A = (something) // MatrixForm. You will get a MatrixForm object instead of a table (= array of arrays) or a sparse array, and its only purpose is to be pretty-printed in FrontEnd. Trying to use MatrixForm in calculations will yield errors and will lead to unnecessary confusion.
Integrating the element at {1, 1}:
myTridiagonalMatrixWithFirstDiagonalElementIntegrated#n_Integer?Positive :=
MapAt[
Integrate[#, {x, 0, 1}, {y, 0, 1}]&
, myTridiagonalMatrix#n
, {1, 1}]
You may check it out without defining f or d, as well:
myTridiagonalMatrixWithFirstDiagonalElementIntegrated#5
The latter operation, however, looks suspicious. For example, it does not leave your matrix (or its corresponding linear system) invariant w.r.t. reasonable transformations. (This operation does not even preserve linearity of matrices.) You probably don't want to do it.
Comment on comment above: there's no need to define A[x_, y_] := … to Integrate[A[[1,1]], {x,0,1}, {y,0,1}]. Note that A[[1,1]] is totally different from A[1, 1]: the former is Part[A, 1, 1] which is a certain element of table A. A[1, 1] is a different expression: if A is some table then A[1, 1] is (that table)[1, 1], which is a valid expression but is normally considered meaningless.
Relatively new to Mathematica, so this might be an easy question. With two lists I need to sort both by one of them, while ignoring any non-numeric values
Example:
x={a, b, c, d, e, f, g};
y={-2, Indeterminate, -3, -Infinity, -1, Apples, 5};
(Also have z=Partition[Riffle[x,y], 2] if that's a little bit better to work with)
Result looking for:
xn={g, e, a, c}
yn={5, -1, -2, -3}
(Or zn equivalent from using z)
Here is one way:
Transpose#Reverse#SortBy[Cases[Transpose[{y, x}], {_?NumericQ, _}], First]
which returns
{{5, -1, -2, -3}, {g, e, a, c}}
I've been fiddling with some Mathematica code to join 2 lists but doing some operations on the one list before adding it to the other. So for example I have
list={{1, "A"}, {1, "B"}, {1, "C"}, {2, "D"}, {2, "E"}, {2, "F"}};
p = {};
q = {};
ones = Select[list, #[[1]] == 1 &];
p = Join[{#[[2]], "t"}, p] & /# Reverse[ones];
Table[
q = Join[{{ones[[m, 2]], "t"}}, q];
, {m, Length[ones]}];
twos = Select[list, #[[1]] == 2 &];
p = Join[{{#[[2]], "t"}}, p] & /# Reverse[twos];
Table[
q = Join[{{twos[[m, 2]], "t"}}, q];
, {m, Length[twos]}];
This yields the following values of p and q respectively:
p={{{F, t}, {C, t}, {B, t}, {A, t}}, {{E, t}, {C, t}, {B, t}, {A, t}}, {{D, t}, {C, t}, {B, t}, {A, t}}}
and
q={{F, t}, {E, t}, {D, t}, {C, t}, {B, t}, {A, t}}
From what I can gather, the second time Join is used with the /#or Map function, each list item in p which at the moment is {{C, t}, {B, t}, {A, t}} is applied to the Join function and is added to a list of results. Is there a way to use Map and rather apply the join to the new value of p each time, so as to obtain a result exactly the same as the value of q but achieved with one line of code.
I tried the same line of code using PrependTo instead of Join and it works fine, I assume this is because PrependTo updates the value of p each time the function is called. For example PrependTo[p, {#[[2]], "t"}] & /# twos;
The reason I was trying to do it this was was to determine whether it will be more time efficient to use Join rather then PrependTo. But ran into this problem before I could get an answer.
Another thing I do not quite understand, is why I need to apply Reverse[] to the lists when using Map to achieve the same result as running through the list using a loop. Could someone possibly explain why this is the case?! I would have assumed Map would run through a list forwards. But this behaviour seems to me as though is traversing the list backwards.
Thanks in advance for the help.
Map does traverse the list as you would expect, in a left right direction. I suspect later elements of your code are introducing reversals.
For instance:
Sqrt /# Select[Range#10, OddQ]
gives {1, Sqrt[3], Sqrt[5], Sqrt[7], 3}
If you want to apply some function to the ones from your list and another function to the twos the structure in a functional language might look something like this:
ans=Join[f1 /# Select[myList, #[[1]] == 1 &], f2 /# Select[myList, #[[1]] == 2 &]]
Further from your clarification:
Method 1 to produce q:
Reverse /# Reverse#list /. {2 -> "t", 1 -> "t"}
Method 2:
Reverse#Join[{Last##, "t"} & /# Select[list, #[[1]] == 1 &], {Last##, "t"} & /# Select[list, First## == 2 &]]
I have written code which draws the Sierpinski fractal. It is really slow since it uses recursion. Do any of you know how I could write the same code without recursion in order for it to be quicker? Here is my code:
midpoint[p1_, p2_] := Mean[{p1, p2}]
trianglesurface[A_, B_, C_] := Graphics[Polygon[{A, B, C}]]
sierpinski[A_, B_, C_, 0] := trianglesurface[A, B, C]
sierpinski[A_, B_, C_, n_Integer] :=
Show[
sierpinski[A, midpoint[A, B], midpoint[C, A], n - 1],
sierpinski[B, midpoint[A, B], midpoint[B, C], n - 1],
sierpinski[C, midpoint[C, A], midpoint[C, B], n - 1]
]
edit:
I have written it with the Chaos Game approach in case someone is interested. Thank you for your great answers!
Here is the code:
random[A_, B_, C_] := Module[{a, result},
a = RandomInteger[2];
Which[a == 0, result = A,
a == 1, result = B,
a == 2, result = C]]
Chaos[A_List, B_List, C_List, S_List, n_Integer] :=
Module[{list},
list = NestList[Mean[{random[A, B, C], #}] &,
Mean[{random[A, B, C], S}], n];
ListPlot[list, Axes -> False, PlotStyle -> PointSize[0.001]]]
This uses Scale and Translate in combination with Nest to create the list of triangles.
Manipulate[
Graphics[{Nest[
Translate[Scale[#, 1/2, {0, 0}], pts/2] &, {Polygon[pts]}, depth]},
PlotRange -> {{0, 1}, {0, 1}}, PlotRangePadding -> .2],
{{pts, {{0, 0}, {1, 0}, {1/2, 1}}}, Locator},
{{depth, 4}, Range[7]}]
If you would like a high-quality approximation of the Sierpinski triangle, you can use an approach called the chaos game. The idea is as follows - pick three points that you wish to define as the vertices of the Sierpinski triangle and choose one of those points randomly. Then, repeat the following procedure as long as you'd like:
Choose a random vertex of the trangle.
Move from the current point to the halfway point between its current location and that vertex of the triangle.
Plot a pixel at that point.
As you can see at this animation, this procedure will eventually trace out a high-resolution version of the triangle. If you'd like, you can multithread it to have multiple processes plotting pixels at once, which will end up drawing the triangle more quickly.
Alternatively, if you just want to translate your recursive code into iterative code, one option would be to use a worklist approach. Maintain a stack (or queue) that contains a collection of records, each of which holds the vertices of the triangle and the number n. Initially put into this worklist the vertices of the main triangle and the fractal depth. Then:
While the worklist is not empty:
Remove the first element from the worklist.
If its n value is not zero:
Draw the triangle connecting the midpoints of the triangle.
For each subtriangle, add that triangle with n-value n - 1 to the worklist.
This essentially simulates the recursion iteratively.
Hope this helps!
You may try
l = {{{{0, 1}, {1, 0}, {0, 0}}, 8}};
g = {};
While [l != {},
k = l[[1, 1]];
n = l[[1, 2]];
l = Rest[l];
If[n != 0,
AppendTo[g, k];
(AppendTo[l, {{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1}] & ## #) & /#
NestList[RotateLeft, k, 2]
]]
Show#Graphics[{EdgeForm[Thin], Pink,Polygon#g}]
And then replace the AppendTo by something more efficient. See for example https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile
Edit
Faster:
f[1] = {{{0, 1}, {1, 0}, {0, 0}}, 8};
i = 1;
g = {};
While[i != 0,
k = f[i][[1]];
n = f[i][[2]];
i--;
If[n != 0,
g = Join[g, k];
{f[i + 1], f[i + 2], f[i + 3]} =
({{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1} & ## #) & /#
NestList[RotateLeft, k, 2];
i = i + 3
]]
Show#Graphics[{EdgeForm[Thin], Pink, Polygon#g}]
Since the triangle-based functions have already been well covered, here is a raster based approach.
This iteratively constructs pascal's triangle, then takes modulo 2 and plots the result.
NestList[{0, ##} + {##, 0} & ## # &, {1}, 511] ~Mod~ 2 // ArrayPlot
Clear["`*"];
sierpinski[{a_, b_, c_}] :=
With[{ab = (a + b)/2, bc = (b + c)/2, ca = (a + c)/2},
{{a, ab, ca}, {ab, b, bc}, {ca, bc, c}}];
pts = {{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}} // N;
n = 5;
d = Nest[Join ## sierpinski /# # &, {pts}, n]; // AbsoluteTiming
Graphics[{EdgeForm#Black, Polygon#d}]
(*sierpinski=Map[Mean, Tuples[#,2]~Partition~3 ,{2}]&;*)
Here is a 3D version,https://mathematica.stackexchange.com/questions/22256/how-can-i-compile-this-function
ListPlot#NestList[(# + RandomChoice[{{0, 0}, {2, 0}, {1, 2}}])/2 &,
N#{0, 0}, 10^4]
With[{data =
NestList[(# + RandomChoice#{{0, 0}, {1, 0}, {.5, .8}})/2 &,
N#{0, 0}, 10^4]},
Graphics[Point[data,
VertexColors -> ({1, #[[1]], #[[2]]} & /# Rescale#data)]]
]
With[{v = {{0, 0, 0.6}, {-0.3, -0.5, -0.2}, {-0.3, 0.5, -0.2}, {0.6,
0, -0.2}}},
ListPointPlot3D[
NestList[(# + RandomChoice[v])/2 &, N#{0, 0, 0}, 10^4],
BoxRatios -> 1, ColorFunction -> "Pastel"]
]
I am wondering if anyone can help me to plot the Cantor dust on the plane in Mathematica. This is linked to the Cantor set.
Thanks a lot.
EDIT
I actually wanted to have something like this:
Here's a naive and probably not very optimized way of reproducing the graphics for the ternary Cantor set construction:
cantorRule = Line[{{a_, n_}, {b_, n_}}] :>
With[{d = b - a, np = n - .1},
{Line[{{a, np}, {a + d/3, np}}], Line[{{b - d/3, np}, {b, np}}]}]
Graphics[{CapForm["Butt"], Thickness[.05],
Flatten#NestList[#/.cantorRule&, Line[{{0., 0}, {1., 0}}], 6]}]
To make Cantor dust using the same replacement rules, we take the result at a particular level, e.g. 4:
dust4=Flatten#Nest[#/.cantorRule&,Line[{{0.,0},{1.,0}}],4]/.Line[{{a_,_},{b_,_}}]:>{a,b}
and take tuples of it
dust4 = Transpose /# Tuples[dust4, 2];
Then we just plot the rectangles
Graphics[Rectangle ### dust4]
Edit: Cantor dust + squares
Changed specs -> New, but similar, solution (still not optimized).
Set n to be a positive integer and choice any subset of 1,...,n then
n = 3; choice = {1, 3};
CanDChoice = c:CanD[__]/;Length[c]===n :> CanD[c[[choice]]];
splitRange = {a_, b_} :> With[{d = (b - a + 0.)/n},
CanD##NestList[# + d &, {a, a + d}, n - 1]];
cantLevToRect[lev_]:=Rectangle###(Transpose/#Tuples[{lev}/.CanD->Sequence,2])
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 4] // Rest;
Graphics[{FaceForm[LightGray], EdgeForm[Black],
Table[cantLevToRect[lev], {lev, Most#dust}],
FaceForm[Black], cantLevToRect[Last#dust /. CanDChoice]}]
Here's the graphics for
n = 7; choice = {1, 2, 4, 6, 7};
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 2] // Rest;
and everything else the same:
Once can use the following approach. Define cantor function:
cantorF[r:(0|1)] = r;
cantorF[r_Rational /; 0 < r < 1] :=
Module[{digs, scale}, {digs, scale} = RealDigits[r, 3];
If[! FreeQ[digs, 1],
digs = Append[TakeWhile[Most[digs]~Join~Last[digs], # != 1 &], 1];];
FromDigits[{digs, scale}, 2]]
Then form the dust by computing differences of F[n/3^k]-F[(n+1/2)/3^k]:
With[{k = 4},
Outer[Times, #, #] &[
Table[(cantorF[(n + 1/2)/3^k] - cantorF[(n)/3^k]), {n, 0,
3^k - 1}]]] // ArrayPlot
I like recursive functions, so
cantor[size_, n_][pt_] :=
With[{s = size/3, ct = cantor[size/3, n - 1]},
{ct[pt], ct[pt + {2 s, 0}], ct[pt + {0, 2 s}], ct[pt + {2 s, 2 s}]}
]
cantor[size_, 0][pt_] := Rectangle[pt, pt + {size, size}]
drawCantor[n_] := Graphics[cantor[1, n][{0, 0}]]
drawCantor[5]
Explanation: size is the edge length of the square the set fits into. pt is the {x,y} coordinates of it lower left corner.