Discussion:
A new more general recursion approach to the q-combinations
(too old to reply)
Roger Bagula
2009-02-07 18:22:30 UTC
Permalink
Here is where I started several days ago:

General Pascal-Sierpinski recursion:
A[n_, 1, m_] := 1;
A[n_, n_, m_] := 1;
A[n_, k_, m_] := (m*n - m*k + 1)*A[n - 1, k - 1, m] + (m*k - (m -
1))*A[n - 1, k, m]
m=1, Eulerian numbers: m=2, MacMahon numbers
http://mathworld.wolfram.com/Second-OrderEulerianTriangle.html
New general recursion: l=2, Eulerian second order
e[n_, 0, l_] := 1
e[n_, k_, l_] := 0 /; k ? n
e[n_, k_, 1] := 1 /; k >= n
e[n_, k_, l_] := (k + l - 1)e[n - 1, k, l] + (l*n - k + 1 - l)e[n - 1, k
- 1, l]


L. Carlitz and John Riordan wrote papers about this new level of
combinatorial triangle.
More recent work is by Len Smiley and the team of :

John *Shareshian*, Michelle L. Wachs, q-Eulerian Polynomials : Excedance
Number and Major Index, arXiv: math/ 0608274v1,11 Aug 2006,page 3.

Yesterday I got the MacMahon sequence using a new generalized from that
I got by more or less a geometrical-matrix analsis
of the Pascal-Sierinski generalization of before and the Eulerian
generalization
I had just found.
The idea is that the quantum variable behave like a 3 dimensional or 4
dinmensional system
of a quantum sort.
The Eulerian q-combinations types are at a different angle of attack on
the {n,k,1} vector.
These triangles seem to have fractals associated at different modulos. I
use mostly modulo three as my monitor.
These systems seem to be somewhat beyond the ordinatory scope of the
q-combinations generalization.

%I A156233
%S A156233
2,1,1,1,6,1,1,37,37,1,1,226,606,226,1,1,1565,7972,7972,1565,1,1,13514,
%T A156233
102407,187824,102407,13514,1,1,150753,1445555,3859373,3859373,1445555,
%U A156233 150753,1,1,2105142,23789060,79955452,115641606,79955452,23789060
%N A156233 A symmetrical recursion triangular sequence: m=4;e(n,k,m)=
(2* k + m - 1)e)n - 1, k, m) + (m*n - 2*k + 1 - m)e(n - 1, k - 1, m);
t(n,k)=e(n, k, m) + e(n, n - k, m).
%C A156233 Row sums are:
%C A156233 {2, 2, 8, 76, 1060, 19076, 419668, 10911364, 327340916,
11129591140,
%C A156233 422924463316,...}.
%C A156233 Since m=2 is A060187, this recursion seems to be a MacMahon
numbers level recursion.
%F A156233 m=4;e(n,k,m)= (2*k + m - 1)e)n - 1, k, m) + (m*n - 2*k + 1 -
m)e(n - 1, k - 1, m);
%F A156233 t(n,k)=e(n, k, m) + e(n, n - k, m).
%e A156233 {2},
%e A156233 {1, 1},
%e A156233 {1, 6, 1},
%e A156233 {1, 37, 37, 1},
%e A156233 {1, 226, 606, 226, 1},
%e A156233 {1, 1565, 7972, 7972, 1565, 1},
%e A156233 {1, 13514, 102407, 187824, 102407, 13514, 1},
%e A156233 {1, 150753, 1445555, 3859373, 3859373, 1445555, 150753, 1},
%e A156233 {1, 2105142, 23789060, 79955452, 115641606, 79955452,
23789060, 2105142, 1},
%e A156233 {1, 34850041, 457127618, 1813119912, 3259697998, 3259697998,
1813119912, 457127618, 34850041, 1},
%e A156233 {1, 656682190, 9977604269, 46096675274, 96031672538,
117399194772, 96031672538, 46096675274, 9977604269, 656682190, 1}
%t A156233 Clear[e, n, k, m]; m = 4; e[n_, 0, m_] := 1;
%t A156233 e[n_, k_, m_] := 0 /; k â0/00¥ n; e[n_, k_, 1] := 1 /; k >= n;
%t A156233 e[n_, k_, m_] := (2*k + m - 1)e[n - 1, k, m] + (m*n - 2*k + 1
- m)e[n - 1, k - 1, m];
%t A156233 Table[Table[e[n, k, m], {k, 0, n - 1}], {n, 1, 10}];
%t A156233 Flatten[%];
%t A156233 Table[Table[e[n, k, m] + e[n, n - k, m], {k, 0, n}], {n, 0, 10}];
%t A156233 Flatten[%]
%Y A156233 A060187
%K A156233 nonn,tabl
%O A156233 0,1
%A A156233 Roger L. Bagula and Gary W. Adamson
(rlbagulatftn(AT)yahoo.com), Feb 06 2009

%I A156278
%S A156278
1,1,1,1,9,1,1,52,44,1,1,270,716,187,1,1,1363,8428,7069,762,1,1,6831,
%T A156278
85143,162039,60151,3065,1,1,34174,790440,2889288,2462504,473162,12280,
%U A156278
1,1,170892,6972826,44429208,72035800,32668794,3557734,49143,1,1,854485
%N A156278 A higher order recursion triangle sequence:
m=3;l=3;e(n,k,m)=(l*k + m - 1)e(n - 1, k, m) + (m*n - l*k + 1 - m)e(n -
1, k - 1, m).
%C A156278 Row sums are:
%C A156278 {2, 2, 4, 22, 196, 2350, 35248, 634462, 13323700, 319768798,
8633757544,...}.
%C A156278 The MacMahon level generalization that I was looking for:
%C A156278 I can get the Sierpinski Pascal mostly by this method too.
%C A156278 I did it by looking at the three variables {n,k,m}
%C A156278 as being a 3d plane and the General -Sierpinski-Pascal like
%C A156278 {{m,0,0},
%C A156278 {0,-m,0},
%C A156278 {0,0,1}}. {n,k,1}
%C A156278 and the General Eulerian as being like:
%C A156278 {{m,0,0},
%C A156278 {0,-1,1},
%C A156278 {0,0-m}}. {n,k,1}
%C A156278 So the MacMahon is the next quantum step up in k:
%C A156278 {{m,0,0},
%C A156278 {0,-2,1},
%C A156278 {0,0-m}}. {n,k,1}
%C A156278 The further generalization adds a new quantum variable l:
%C A156278 {{m,0,0},
%C A156278 {0,-l,1},
%C A156278 {0,0-m}}. {n,k,1}
%C A156278 This resursive result seems to give a much more general
%C A156278 type of combinatorial triangle sequence.
%F A156278 m=3;l=3;
%F A156278 e(n,k,m)=(l*k + m - 1)e(n - 1, k, m) + (m*n - l*k + 1 - m)e(n
- 1, k - 1, m).
%e A156278 {1},
%e A156278 {1, 1},
%e A156278 {1, 9, 1},
%e A156278 {1, 52, 44, 1},
%e A156278 {1, 270, 716, 187, 1},
%e A156278 {1, 1363, 8428, 7069, 762, 1},
%e A156278 {1, 6831, 85143, 162039, 60151, 3065, 1},
%e A156278 {1, 34174, 790440, 2889288, 2462504, 473162, 12280, 1},
%e A156278 {1, 170892, 6972826, 44429208, 72035800, 32668794, 3557734,
49143, 1},
%e A156278 {1, 854485, 59542232, 621204982, 1719368528, 1491834898,
397842620, 26034427, 196598, 1}
%t A156278 m = 3; l = 3;
%t A156278 e[n_, 0, m_] := 1; e[n_, k_, m_] := 0 /; k â0/00¥ n;
%t A156278 e[n_, k_, 1] := 1 /; k >= n
%t A156278 e[n_, k_, m_] := (l*k + m - 1)e[ n - 1, k, m] + (m*n - l*k +
1 - m)e[n - 1, k - 1, m];
%t A156278 Table[Table[e[n, k, m], {k, 0, n - 1}], {n, 1, 10}];
%t A156278 Flatten[%]
%Y A156278 A008517
%K A156278 nonn,tabl
%O A156278 0,5
%A A156278 Roger L. Bagula and Gary W. Adamson
(rlbagulatftn(AT)yahoo.com), Feb 07 2009
--
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 :http://www.geocities.com/rlbagulatftn/Index.html
alternative email: ***@sbcglobal.net
Roger Bagula
2009-02-07 18:25:23 UTC
Permalink
Having done a lot with the sequences that result from
from irreducible polynomials
when confronted with the polynomials
p(x,n)=(1-x^n)/(1-x)
( and their products)
I immediately give a Pavlovian response of:
p(x,n)=x^n-(1-x^n)/(1-x)
and
p(x,n)=Cyclotomic[n,x]
It doesn't appear that the idea has been thought of a generalized
exponential of the sorts:
p[x_, n_] := Product[x^k-(1-x^k)/(1-x), {k, 1, n}];
e[x_, q_] = Sum[x^n/p[q, n], {n, 0, Infinity}]
or
p[x_, n_] := Product[Cyclotomic[k,x], {k, 1, n}];
e[x_, q_] = Sum[x^n/p[q, n], {n, 0, Infinity}]
Or the dynamics that will arise from them if they actually work
computationally.
I at least make a start here with these triangle sequences:
b-Eulerian: Bonacci -Eulerian.
c-Eulerian: Cyclotomic- Eulerian

%I A156281
%S A156281 1,1,1,1,0,2,1,1,1,1,2,1,3,1,1,2,1,1,4,2,0,3,3,4,1,1,3,4,3,
%T A156281 1,5,8,5,1,4,5,3,3,6,5,1,1,4,8,11,10,5,5,15,19,17,7,5,13,9,7,
%U A156281 1,7,8,1,10,6,1,1,5,13,24,34,39,34,17,9,38,59,63,50,26,6
%V A156281
1,-1,1,1,0,-2,1,-1,-1,1,2,1,-3,1,1,2,1,-1,-4,-2,0,3,3,-4,1,-1,-3,-4,-3,
%W A156281
1,5,8,5,-1,-4,-5,-3,3,6,-5,1,1,4,8,11,10,5,-5,-15,-19,-17,-7,5,13,9,7,
%X A156281
-1,-7,-8,1,10,-6,1,-1,-5,-13,-24,-34,-39,-34,-17,9,38,59,63,50,26,-6
%N A156281 A triangle sequence of Bonacci sub-cyclotomic product
polynomials: p(x,n)=Product[x^k - (1 - x^k)/(1 - x), {k, 1, n}].
%C A156281 The row sums are:{1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...}.
%C A156281 This idea for these products come from the q-Eulerian
exponential generalization:
%C A156281 Here are the definitions of the q-exponentials in
%C A156281 John Shareshian and Michelle Wachs paper:
%C A156281 Clear[Q, e, p, n, x];
%C A156281 p[x_, n_] := Product[(1 - x^k)/(1 - x), {k, 1, n}];
%C A156281 e[x_, q_] = Sum[x^n/p[q, n], {n, 0, Infinity}];
%C A156281 f[x_, t_, q_] = (1 - t)/(e[x*(t - 1), q] - t);
%C A156281 Where the expansion is: (called the Stanley q-analog of the
Eulerian type);
%C A156281 (1 - t)/(e[x*(t - 1), q] - t)= Sum[A[n,q,t]*x^n/p[q, n], {n,
0, Infinity}] ;
%C A156281 The idea here is to substitute the new sub-cyclotomic-Bonacci
product where it will work for the q-product.
%D A156281 L. Carlitz,q-Bernoulli numbers and polynomials,Duke Math. J.
Volume 15, Number 4 (1948),
987-1000.http://projecteuclid.org/DPubS?service=UI&version=1.0&verb=Display&handle=euclid.dmj/1077475200
%D A156281 L. Carlitz and J. Riordan,Two element lattice permutation
numbers and their q-generalization, Duke Math. J. Volume 31, Number 3
(1964), 371-388,
http://projecteuclid.org/DPubS?service=UI&version=1.0&verb=Display&handle=euclid.dmj/1077375351
%D A156281 John Shareshian, Michelle L. Wachs, q-Eulerian Polynomials :
Excedance Number ans Major Index, arXiv: math/ 0608274v1,11 Aug 2006,page 3.
%F A156281 p(x,n)=Product[x^k - (1 - x^k)/(1 - x), {k, 1, n}].
%e A156281 {1},
%e A156281 {-1, 1},
%e A156281 {1, 0, -2, 1},
%e A156281 {-1, -1, 1, 2, 1, -3, 1},
%e A156281 {1, 2, 1, -1, -4, -2, 0, 3, 3, -4, 1},
%e A156281 {-1, -3, -4, -3, 1, 5, 8, 5, -1, -4, -5, -3, 3, 6, -5, 1},
%e A156281 {1, 4, 8, 11, 10, 5, -5, -15, -19, -17, -7, 5, 13, 9, 7, -1,
-7, -8, 1, 10, -6, 1},
%e A156281 {-1, -5, -13, -24, -34, -39, -34, -17, 9, 38, 59, 63, 50, 26,
-6, -28, -36, -25, -9, 2, 13, 17, 8, -5, -14, -4, 15, -7, 1},
%e A156281 {1, 6, 19, 43, 77, 116, 150, 167, 156, 109, 29, -69, -163,
-233, -256, -228, -157, -65, 24, 89, 113, 98, 52, 7, -23, -33, -41, -21,
2, 23, 22, 4, -19, -13, 21, -8, 1},
%e A156281 {-1, -7, -26, -69, -146, -262, -412, -579, -735, -842, -860,
-759, -529, -185, 226, 638, 979, 1189, 1227, 1087, 807, 452, 97, -189,
-366, -419, -351, -217, -65, 49, 110, 112, 93, 53, -11, -52, -54, -29,
15, 36, 22, -20, -27, 28, -9, 1},
%e A156281 {1, 8, 34, 103, 249, 511, 923, 1502, 2237, 3079, 3937, 4683,
5167, 5240, 4791, 3775, 2234, 299, -1819, -3855, -5540, -6650, -7046,
-6698, -5695, -4226, -2555, -939, 391, 1289, 1706, 1691, 1340, 812, 280,
-140, -369, -423, -351, -224, -75, 59, 160, 145, 79, -15, -71, -75, -16,
41, 49, -13, -47, 36, -10, 1}
%t A156281 Clear[p, n, x]; p[x_, n_] = Product[x^k - (1 - x^k)/(1 - x),
{k, 1, n}]; Table[FullSimplify[ExpandAll[p[x, n]]], {n, 0, 10}];
Table[CoefficientList[FullSimplify[ExpandAll[p[x, n]]], x], {n, 0, 10}];
Flatten[%]
%K A156281 nonn,tabl
%O A156281 0,6
%A A156281 Roger L. Bagula (rlbagulatftn(AT)yahoo.com), Feb 07 2009

%I A156282
%S A156282
1,1,1,1,2,2,1,1,2,3,3,2,1,1,3,6,9,11,11,9,6,3,1,1,2,4,6,8,9,9,8,6,4,2,
%T A156282
1,1,3,7,13,21,30,39,46,50,50,46,39,30,21,13,7,3,1,1,3,7,13,22,33,46,59,
%U A156282
71,80,85,85,80,71,59,46,33,22,13,7,3,1,1,3,7,14,25,40,60,84,111,139
%N A156282 A triangle sequence of cyclotomic product polynomials:
p(x,n)=Product[Cyclotomic[k + 1, x], {k, 1, n}].
%C A156282 The row sums are:{1, 2, 6, 12, 60, 60, 420, 840, 2520, 2520,
27720,...}.
%C A156282 This idea for these products come from the q-Eulerian
exponential generalization:
%C A156282 Here are the definitions of the q-exponentials in
%C A156282 John Shareshian and Michelle Wachs paper:
%C A156282 Clear[Q, e, p, n, x];
%C A156282 p[x_, n_] := Product[(1 - x^k)/(1 - x), {k, 1, n}];
%C A156282 e[x_, q_] = Sum[x^n/p[q, n], {n, 0, Infinity}];
%C A156282 f[x_, t_, q_] = (1 - t)/(e[x*(t - 1), q] - t);
%C A156282 Where the expansion is: (called the Stanley q-analog of the
Eulerian type);
%C A156282 (1 - t)/(e[x*(t - 1), q] - t)= Sum[A[n,q,t]*x^n/p[q, n], {n,
0, Infinity}] ;
%C A156282 The idea here is to substitute the new Cyclotomic product
where it will work for the q-product.
%D A156282 L. Carlitz,q-Bernoulli numbers and polynomials,Duke Math. J.
Volume 15, Number 4 (1948),
987-1000.http://projecteuclid.org/DPubS?service=UI&version=1.0&verb=Display&handle=euclid.dmj/1077475200
%D A156282 L. Carlitz and J. Riordan,Two element lattice permutation
numbers and their q-generalization, Duke Math. J. Volume 31, Number 3
(1964), 371-388,
http://projecteuclid.org/DPubS?service=UI&version=1.0&verb=Display&handle=euclid.dmj/1077375351
%D A156282 John Shareshian, Michelle L. Wachs, q-Eulerian Polynomials :
Excedance Number ans Major Index, arXiv: math/ 0608274v1,11 Aug 2006,page 3.
%F A156282 p(x,n)=Product[Cyclotomic[k + 1, x], {k, 1, n}].
%e A156282 {1},
%e A156282 {1, 1},
%e A156282 {1, 2, 2, 1},
%e A156282 {1, 2, 3, 3, 2, 1},
%e A156282 {1, 3, 6, 9, 11, 11, 9, 6, 3, 1},
%e A156282 {1, 2, 4, 6, 8, 9, 9, 8, 6, 4, 2, 1},
%e A156282 {1, 3, 7, 13, 21, 30, 39, 46, 50, 50, 46, 39, 30, 21, 13, 7,
3, 1},
%e A156282 {1, 3, 7, 13, 22, 33, 46, 59, 71, 80, 85, 85, 80, 71, 59, 46,
33, 22, 13, 7, 3, 1},
%e A156282 {1, 3, 7, 14, 25, 40, 60, 84, 111, 139, 166, 189, 206, 215,
215, 206, 189, 166, 139, 111, 84, 60, 40, 25, 14, 7, 3, 1},
%e A156282 {1, 2, 5, 9, 16, 25, 38, 53, 72, 92, 114, 135, 155, 171, 183,
189, 189, 183, 171, 155, 135, 114, 92, 72, 53, 38, 25, 16, 9, 5, 2, 1},
%e A156282 {1, 3, 8, 17, 33, 58, 96, 149, 221, 313, 427, 561, 714, 880,
1054, 1227, 1391, 1536, 1654, 1737, 1780, 1780, 1737, 1654, 1536, 1391,
1227, 1054, 880, 714, 561, 427, 313, 221, 149, 96, 58, 33, 17, 8, 3, 1}
%t A156282 Clear[p, n, x]; p[x_, n_] = Product[Cyclotomic[k + 1, x], {k,
1, n}]; Table[FullSimplify[ExpandAll[p[x, n]]], {n, 0, 10}];
Table[CoefficientList[FullSimplify[ExpandAll[p[x, n]]], x], {n, 0, 10}];
Flatten[%]
%K A156282 nonn,tabl
%O A156282 0,5
%A A156282 Roger L. Bagula (rlbagulatftn(AT)yahoo.com), Feb 07 2009
--
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html
alternative email: ***@sbcglobal.net
Roger Bagula
2009-02-08 18:38:34 UTC
Permalink
Any one have an idea how to get IFS
that behave like q-Eulerian triangle sequences?
Roger Bagula
2009-02-09 13:38:14 UTC
Permalink
Post by Roger Bagula
Any one have an idea how to get IFS
that behave like q-Eulerian triangle sequences?
As per my previous post here are my efforts
at generalized q-Eulerian
like IFS using an {(1-q^x)/r,{1-q^y)/r} instead of {x/r,y/r}
complex structure and adjusting r
so that the point centered results are close to touching.
It appears that like the Sierpinski -Pascal types they
will eventually become a limiting space filling curve.
I don't know that this is exactly right:
it is just an attempt.
They are in the type/ class of nonlinear IFS
which I had worked with before.

Loading Image...
Loading Image...
Loading Image...
Loading Image...
Loading Image...

Mathematica:

Clear[f, dlst, pt, cr, ptlst, M, r, p, rotate]
n0 = 3/2;
dlst = Table[ Random[Integer, {1, 2*n0}], {n, 100000}];
r = 1/Sqrt[3]
M = Table[{{N[r], 0}, {0, N[r]}}, {n, 1, 3}]
in = Delete[Union[Flatten[Table[Union[Table[If[n + m ≤ 1, {n,
m}, {}], {n, 0, 1}]], {m, 0, 1}], 1]], 1]
Length[in]
f[j_, {x_, y_}] := M[[j]]. {1 - 2^x, 1 - 2^y} + in[[j]]
pt = {0.5, 0.5};
cr[n_] := Flatten[Table[If[i == j ==
k == 1, {},
RGBColor[i,
j, k]], {i, 0, 1}, {j, 0, 1}, {k, 0, 1}]][[1 + Mod[n, 7]]];
ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];
Show[Graphics[
Join[{PointSize[.001]}, ptlst[n]]], AspectRatio ->
Automatic, PlotRange -> All]


Clear[f, dlst, pt, cr, ptlst, M, r, p, rotate]
n0 = 3;
dlst = Table[ Random[Integer, {1, 2*n0}], {n, 100000}];
r = 1/5
M = Table[{{N[r], 0}, {0, N[r]}}, {n, 1, 10}]
in = Delete[Union[Flatten[Table[Union[Table[If[n/2 + m/2 ≤ 1, {n/
2, m/2}, {}], {n, 0, 2}]], {m, 0, 2}], 1]], 1]
Length[in]
f[j_, {x_, y_}] := M[[j]]. {1 - 3^x, 1 - 3^y} + in[[j]]
pt = {0.5, 0.5};
cr[n_] := Flatten[Table[If[i ==
j == k == 1, {}, RGBColor[i, j, k]], {i, 0, 1}, {j, 0, 1}, {
k, 0, 1}]][[1 + Mod[n, 7]]];
ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];
Show[Graphics[Join[{PointSize[.001]}, ptlst[n]]],
AspectRatio -> Automatic, PlotRange -> All]


Clear[f, dlst, pt, cr, ptlst, M, r, p, rotate]
n0 = 5;
dlst = Table[ Random[Integer, {1, 2*n0}], {n, 100000}];
r = 1/10;
M = Table[{{N[r], 0}, {0, N[r]}}, {n, 1, 10}];
in = Delete[Union[Flatten[Table[Union[Table[If[n/3 + m/3 ≤
1, {n/3, m/3}, {}], {n, 0, 3}]], {m, 0, 3}], 1]], 1];
Length[in]
f[j_, {x_, y_}] := M[[j]]. {1 - 4^x, 1 - 4^y} + in[[j]]

pt = {0.5, 0.5};

cr[n_] := Flatten[Table[If[i ==
j == k == 1, {}, RGBColor[i, j, k]], {i, 0, 1}, {j, 0, 1}, {
k, 0, 1}]][[1 + Mod[n, 7]]];
ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];

Show[Graphics[Join[{PointSize[.001]}, ptlst[n]]],
AspectRatio -> Automatic, PlotRange -> All]


Clear[f, dlst, pt, cr, ptlst, M, r, p, rotate]
n0 = 15/2;
dlst = Table[ Random[Integer, {1, 2*n0}], {n, 100000}];
r = 1/17
M = Table[{{N[r], 0}, {0, N[r]}}, {n, 1, 15}]
in = Delete[Union[Flatten[Table[Union[Table[If[n/4 + m/4 ≤ 1, {n/4,
m/4}, {}], {n, 0, 4}]], {m, 0, 4}], 1]], 1]
Length[in]
f[j_, {x_, y_}] := M[[j]]. {1 - 5^x, 1 - 5^y} + in[[j]]
pt = {0.5, 0.5};
cr[n_] := Flatten[Table[
If[i == j ==
k == 1, {},
RGBColor[i,
j, k]], {i, 0, 1}, {j, 0, 1}, {k, 0, 1}]][[1 + Mod[n, 7]]];
ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];

Show[Graphics[Join[{
PointSize[.001]}, ptlst[n]]], AspectRatio -> Automatic, PlotRange -> All
]

Clear[f, dlst, pt, cr, ptlst, M, r, p, rotate]
n0 = 21/2;
dlst = Table[ Random[Integer, {1, 2*n0}], {n, 100000}];
r = 1/27
M = Table[{{N[r], 0}, {0, N[r]}}, {n, 1, 21}]
in = Delete[Union[Flatten[Table[Union[Table[If[n/5 + m/5 ≤ 1, {n/5,
m/5}, {}], {n, 0, 5}]], {m, 0, 5}], 1]], 1]
Length[in]
f[j_, {x_, y_}] := M[[j]]. {1 - 6^x, 1 - 6^y} + in[[j]]
pt = {0.5, 0.5};
cr[n_] := Flatten[Table[
If[i == j ==
k == 1, {},
RGBColor[i,
j, k]], {i, 0, 1}, {j, 0, 1}, {k, 0, 1}]][[1 + Mod[n, 7]]];
ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];

Show[Graphics[Join[{
PointSize[.001]}, ptlst[n]]], AspectRatio -> Automatic, PlotRange -> All
]

Loading...