self-avoiding closed loops (3)

Fri Sep 18 02:31:30 CEST 1998

hi,

the self-avoiding closed loops over a hexagonal net produce the hexagonal
polyomino's ordered by perimeter length. (see attached file "peri20.gif")

excluding any symmetry, their number is :

perimeter       polyomino's     s.a. closed loops:
2               0               0
4               0               0
6               1               1
8               0               0
10              1               5
12              1               4
14              3               28
16              3               48
18              16              195
20              23              460

the s.a. closed loops are counted using a convention that all
loops start from {0,0} with the first step in the one-o'clock direction
(say Exp[I Pi/3]), colored red in the peri20.gif picture),
and the last step from the nine o'clock position back to center.

So, the equivalent loops with a return from the five o'clock direction back
to center are not counted. (this mirroring would double the figures).

The connection between the s.a. closed loops and the polyomino's stems from
the effect of the "rotation operator" on the s.a. closed loops.

example:
-------
for perimeter=10, we have 5 closed loops:
 {528,759,891,957,990}
it has a mirroring to {1007,776,644,578,545}
and left-rotation of the bit-string [until again a "1" stands up front]
produces:
 {528,990,759,891,957}
This is a permutation of the unrotated loops. The rotation operator is then
equivalent to the permutation {{1},{2,5,4,3}}.
Each of the cycles contributes its leading member to the polyomino set. In
this case the first & second of the loops eq. 528 and 759 get selected. 
It's confusing, but there is still a symmetry lurking here, a two-fold axis
this time. 

Conclusion:
----------
One polyomino per cycle of the rotation-permutation operator.
the polyomino's are: (each occurs twice except the hexagon)
6 sides:
{63}
8 sides:
{ }
10 sides:
{528,759}
 12 sides:
{2184,3003}
 14 sides:
{8481,8514,8772,10167,11223,11739}
 16 sides:
{34065,34338,35106,40407,40635,44763}
 18 sides:
{135747,135813,135945,136326,136329,136458,137313,137361,
137484,137490,140049,140433,140562,141474,141588,146871,
149796,155319,159447,159543,161499,161511,161595,162279,
162525,162621,162654,175959,178011,178923,179037,187245}
 20 sides:
{543267,543813,545091,545157,545349,545841,545862,545865,
546954,549510,549513,549969,550026,551052,551058,553236,
560265,561801,562257,562314,565905,566412,566418,585399,
587223,587451,620247,620343,621015,621243,636759,637659,
637671,637755,642903,644955,644967,645867,645981,646461,
646494,649707,649965,650094,703323,711531}

----------------------------------------------------------------
for completeness:
the Mathematica 3.0 program:
(Chinese-Hungarian to most readers)

1/  Inits:
----------

Ordering[li_List]:=Last at Transpose[Sort[Transpose[{li,Range[Length[li]]}]]]

my[x_,a_,b_]:=If[x\[LessEqual]a,b,x]

mytocycles[perm_List] := DeleteCases[Table[Module[{predi = Position[perm, i][[
1,1]], fpl}, 
     fpl = If[i > 1 && predi < i, Null, Drop[FixedPointList[my[perm[[#1]], i, 
predi] & , i], -1]]; 
      If[fpl === Null || perm[[fpl[[-Min[Length[fpl], 2]]]]] =!= fpl[[-1]] || 
fpl[[1]] =!= Min[fpl], Null, fpl]], 
    {i, 1, Length[perm]}], Null]

selfavoidingQ[k_Integer]:=
Module[{ le,n=1,nogo={0},argu=0.,elem=0.},
bin=IntegerDigits[k,2];le=Length[bin];nocross=True;
While[ nocross && n<=le,
elem=Chop[elem+10. N at Exp[argu+=I Pi/3 (2 bin[[n]]-1)]];
rel=Round[elem];
nocross=FreeQ[nogo,rel];
nogo={nogo,rel};
n++]; rel===0&&le+1===n && Round[E^argu]===1]

nice[a_]:=If[a==={},a,Partition[Join[a, Table[Graphics[Point[{0, 0}]], 
     { Mod[Ceiling[Sqrt[#]]-Mod[#,(Ceiling[Sqrt[#]] )],Ceiling[Sqrt[#]]] & @ 
Length[a]}]], Ceiling[Sqrt[Length[a]]] ] ]

pad=FoldList[Chop[#1+ N at Exp[argu+=I Pi/3 (2 #2-1)]]&,argu=0.;0,
IntegerDigits[#,2]]&;

plotpad[k_Integer]:= Graphics[{Line[{Re[#],Im[#]}&/@pad[k]],Hue[0],Line[{{0,
0},{1/2,Sqrt[3]/2}}]},DisplayFunction->Identity,Axes->False,AspectRatio->
Automatic]

2/ Program:
------------
Timing[w11=Cases[Range[2^11,2^(11+1)-1],_?selfavoidingQ]]

Show[GraphicsArray[nice[plotpad /@ (w11)]],DisplayFunction->$DisplayFunction]

mir11=Fold[2#1+#2&,0,Prepend[1-Rest at IntegerDigits[#,2],1]]&/@w11

rolw11=Fold[2#1+#2&,0,FixedPoint[RotateLeft,IntegerDigits[#,2],SameTest->(
First[#2]===1&)]]& /@w11

Sort at rolw11==Sort at w11

r11=Ordering at Ordering@rolw11

w11[[  r11  ]] == rolw11

c11=mytocycles at r11

Length/@Sort[%]

{First[#],Length[#]}&/@Split[%]

Plus@@(%/.{a_Integer,b_}->a b) == Length[w11]

*******************************************************************************

-------------- next part --------------
A non-text attachment was scrubbed...
Name: PERI20.GIF
Type: image/gif
Size: 4546 bytes
Desc: not available
URL: <http://list.seqfan.eu/pipermail/seqfan/attachments/19980918/11c457cb/attachment.gif>
-------------- next part --------------
Dr. Wouter L. J. MEEUSSEN
w.meeussen.vdmcc at vandemoortele.be
eu000949 at pophost.eunet.be