1: %auto-ignore
2: print(`This is the package RS`):
3: print(`written by Arvind Ayyer. Version of 30 November, 2008.`):
4: print(`It is written for the analysis of FPLs,`):
5: print(`particularly the Razumov-Stroganov conjecture.`):
6: print(`FPLs are stored in an internal format in two-dimensional arrays.`):
7: print(`To see the list of procedures, type Help();`):
8: print(`For help on a specific procedure, type Help(procedure_name);`):
9:
10:
11: Help := proc()
12:
13: if args=NULL then
14:
15: print(`Contains the following procedures:`):
16: print(`ASM: nasm,asm,asmw1,asmtofpl,fpltoasm,fpltograph.`):
17: print(`FPL: fpls,A,printfpl,fplconn,npitofpl,pitofpl,ei,invei.`):
18: print(`RS Conjecture: revrs,testrs,rsmatrix,redrsmatrix`):
19: print(`Alternating Paths: findpath,apsq,appath,newaltfpl`):
20: print(``):
21: print(`WARNING: The lattice notation is unconventional. The origin is on the top left. The -y axis coordinate is first followed by the +x axis coordinate`):
22:
23: fi:
24:
25: if nops([args])=1 and op(1,[args])=`nasm` then
26: print(`nasm(n) returns the number of ASMs of size n`):
27: print(`For example, try nasm(3);`):
28: fi:
29:
30:
31: if nops([args])=1 and op(1,[args])=`asm` then
32: print(`asm(n) returns all ASMs of size n`):
33: print(`For example, try asm(3);`):
34: fi:
35:
36:
37: if nops([args])=1 and op(1,[args])=`asmw1` then
38: print(`asmw1(n,k) returns all ASMs of size n whose 1`):
39: print(`in the first row is in the k'th column.`):
40: print(`For example, try asm(3,2);`):
41: fi:
42:
43: if nops([args])=1 and op(1,[args])=`fpltograph` then
44: print(`fpltograph(fpl) for an fpl in the internal formal returns `):
45: print(`the same fpl as a graph in the subset of the 2d lattice`):
46: print(`For example, try fpltograph([[5, 3, 2], [3, 2, 5], [2, 5, 3]]);`):
47: fi:
48:
49: if nops([args])=1 and op(1,[args])=`asmtofpl` then
50: print(`asmtofpl(asm) returns the fpl corresponding`):
51: print(`to the given asm.`):
52: print(`For example, try asmtofpl([[0, 1, 0], [0, 0, 1], [1, 0, 0]]);`):
53: fi:
54:
55:
56: if nops([args])=1 and op(1,[args])=`fpltoasm` then
57: print(`asmtofpl(fpl) returns the ASM corresponding`):
58: print(`to the given fpl (in the internal format).`):
59: print(`For example, try fpltoasm([[5, 1, 4], [3, 6, 1], [2, 5, 3]]);`):
60: fi:
61:
62:
63: if nops([args])=1 and op(1,[args])=`fpls` then
64: print(`fpls(n) returns a list of link patterns of size 2n`):
65: print(`along with the number of fpls in that link pattern.`):
66: print(`For example, try fpls(2);`):
67: fi:
68:
69: if nops([args])=1 and op(1,[args])=`printfpl` then
70: print(`printfpl(fpl) prints the fpl in a screen readable format.`):
71: print(`The 6 possible connections are drawn as ||,==,-|,|-,_|,|_.`):
72: print(`For example, try printfpl([[5, 1, 4], [3, 6, 1], [2, 5, 3]]);`):
73: fi:
74:
75: if nops([args])=1 and op(1,[args])=`fplconn` then
76: print(`fplconn(fpl) returns the link pattern of that fpl.`):
77: print(`For example, try fplconn([[5, 1, 4], [3, 6, 1], [2, 5, 3]]);`):
78: fi:
79:
80: if nops([args])=1 and op(1,[args])=`npitofpl` then
81: print(`npitofpl(pi) given a link pattern returns all fpls`):
82: print(`which have the same link pattern (in the internal format).`):
83: print(`For example, try npitofpl({{1, 6}, {2, 3}, {4, 5}});`):
84: fi:
85:
86:
87: if nops([args])=1 and op(1,[args])=`pitofpl` then
88: print(`npitofpl(pi) given a link pattern returns all fpls`):
89: print(`which have the same link pattern in the form of`):
90: print(`edges in two dimensional square lattice.`):
91: print(`For example, try pitofpl({{1, 6}, {2, 3}, {4, 5}});`):
92: fi:
93:
94:
95: if nops([args])=1 and op(1,[args])=`ei` then
96: print(`ei(pi,i) given a link pattern of size n and an integer from `):
97: print(`1 to 2n return the new link pattern got by connecting i to i+1`):
98: print(`cyclically and their partners to each other.`):
99: print(`For example, try ei({{1, 6}, {2, 3}, {4, 5}},1);`):
100: fi:
101:
102: if nops([args])=1 and op(1,[args])=`invei` then
103: print(`invei(pi) given a link pattern returns all other link patterns pi'`):
104: print(`that return pi under the action of ei(pi',i) along with the i's.`):
105: print(`For example, try invei({{1, 6}, {2, 3}, {4, 5}});`):
106: fi:
107:
108: if nops([args])=1 and op(1,[args])=`A` then
109: print(`A(pi) given a link patterns returns the number of FPLs that`):
110: print(`have that particular link pattern.`):
111: print(`For example, try A({{1, 2}, {3, 4}});`):
112: fi:
113:
114: if nops([args])=1 and op(1,[args])=`testrs` then
115: print(`testrs(n) tests the RS conjecture for fpls of size n.`):
116: print(`If true, you should get a list of zeros of size Catalan(n)`):
117: print(`For example, try testrs(2);`):
118: fi:
119:
120: if nops([args])=1 and op(1,[args])=`revrs` then
121: print(`revrs(n) assumes the RS conjecture to find the number of FPLs`):
122: print(`for each link pattern. Faster that fpls(n).`):
123: print(`For example, try revrs(2);`):
124: fi:
125:
126: if nops([args])=1 and op(1,[args])=`rsmatrix` then
127: print(`rsmatrix(n) returns the matrix in the RS conjecture in the `):
128: print(`link pattern basis ordered in no particular way.`):
129: print(`For example, try rsmatrix(3);`):
130: fi:
131:
132: if nops([args])=1 and op(1,[args])=`redrsmatrix` then
133: print(`redrsmatrix(n) returns the reduced matrix in the RS conjecture in the `):
134: print(`basis in which link patterns are considered equivalent upto rotation.`):
135: print(`For example, try redrsmatrix(3);`):
136: fi:
137:
138:
139: if nops([args])=1 and op(1,[args])=`findpath` then
140: print(`findpath(fpl,i) given an fpl and an endpoint i finds the path `):
141: print(`on the lattice that leads from i to its endpoint.`):
142: print(`For example, try findpath([[5, 1], [1, 3]],1);`):
143: fi:
144:
145: if nops([args])=1 and op(1,[args])=`apsq` then
146: print(`apsq(fpl,sq) given an fpl and a square whose top left corner is (i,j)`):
147: print(`returns all alternating paths in the fpl which touch atleast two `):
148: print(`of the four possible edges in that square.`):
149: print(`For example, try apsq([[5, 3, 2], [1, 4, 5], [6, 1, 3]],[1,1]);`):
150: fi:
151:
152: if nops([args])=1 and op(1,[args])=`appath` then
153: print(`appath(fpl,path) given an fpl and a list of vertices forming part of an`):
154: print(`alternating path, returns all complete alternating paths which contain it.`):
155: print(`For example, try appath([[5, 3, 2], [1, 4, 5], [6, 1, 3]],[[1,1],[2,1]]);`):
156: fi:
157:
158: if nops([args])=1 and op(1,[args])=`newaltfpl` then
159: print(`newaltfpl(fpl,ap) given an fpl and a complete alternating path returns`):
160: print(`the new fpl obtained by the involution.`):
161: print(`For example, try newaltfpl([[5, 1, 4], [1, 1, 1], [6, 1, 3]],[[1, 1], [2, 1], [2, 2], [1, 2], [1, 1]]);`):
162: fi:
163:
164: if nops([args])=1 and op(1,[args])=`` then
165: print(` `):
166: print(``):
167: print(`For example, try ;`):
168: fi:
169:
170: end:
171:
172:
173: ##################################ASM procedures############################
174: nasm := proc(n) local k:
175:
176: return mul((3*k+1)!/(n+k)!,k=0..n-1):
177:
178: end:
179:
180: #asm(n) returns the ASMs of size n
181: asm := proc(n) local gogs, asms:
182:
183: gogs := GOGset(n,n):
184:
185: asms := {seq(op(GOGTOASM(op(i,gogs))),i=1..nops(gogs))}:
186:
187: return asms:
188:
189: end:
190:
191: #asmw1(n,k) returns the ASMs with the 1 in the first row in the kth column
192: asmw1:= proc(n,k) local i,j,gogs,asms,asmk:
193:
194: if k<0 or k>n then
195: ERROR(`The column where the 1 should be located is not correct`):
196: fi:
197:
198: gogs := GOGset(n,n):
199:
200: asms := {seq(op(GOGTOASM(op(i,gogs))),i=1..nops(gogs))}:
201:
202: asmk := {}:
203:
204: for i from 1 to nops(asms) do
205: if asms[i][1,k] = 1 then
206: asmk := asmk union {asms[i]}:
207: fi:
208: od:
209:
210: return asmk:
211:
212: end:
213:
214:
215:
216: printfpl:=proc(cnt) local i,j:
217:
218: for i from 1 to nops(cnt) do
219: printf("\t"):
220: for j from 1 to nops(cnt) do
221: if cnt[i,j]=1 then
222: printf("||\t"):
223: elif cnt[i,j]=2 then
224: printf("==\t"):
225: elif cnt[i,j]=3 then
226: printf("|_\t"):
227: elif cnt[i,j]=4 then
228: printf("|-\t"):
229: elif cnt[i,j]=5 then
230: printf("-|\t"):
231: elif cnt[i,j]=6 then
232: printf("_|\t"):
233: else
234: printf("00\t"):
235: fi:
236: od:
237: printf("\n"):
238: od:
239:
240: end:
241:
242:
243: fztop := proc(cnt,i,j) local k:
244:
245: if i=1 then
246: if j=1 then
247: return 5:
248: elif j mod 2 = 1 then
249: if cnt[i,j-1] = 2 or cnt[i,j-1]=3 or cnt[i,j-1]=4 then
250: return 5:
251: else
252: return 4:
253: fi:
254: elif j mod 2 = 0 then
255: if cnt[i,j-1] = 2 or cnt[i,j-1]=3 or cnt[i,j-1]=4 then
256: return 6:
257: else
258: return 3:
259: fi:
260: fi:
261: else
262: if cnt[i,j-1] = 2 or cnt[i,j-1] = 3 or cnt[i,j-1] = 4 then
263: if cnt[i-1,j] = 1 or cnt[i-1,j] = 4 or cnt[i-1,j] = 5 then
264: return 6:
265: else
266: return 5:
267: fi:
268: else
269: if cnt[i-1,j] = 1 or cnt[i-1,j] = 4 or cnt[i-1,j] = 5 then
270: return 3:
271: else
272: return 4:
273: fi:
274: fi:
275: fi:
276:
277:
278: end:
279:
280: fzright := proc(cnt,i,j) local k:
281:
282: if j=nops(cnt) then
283: if i=1 and nops(cnt) mod 2 = 0 then
284: return 6:
285: elif i=1 and nops(cnt) mod 2 = 1 then
286: return 4:
287: elif (i mod 2 = 1 and nops(cnt) mod 2 = 1) or (i mod 2 = 0 and nops(cnt) mod 2 = 0)then
288: if cnt[i-1,j] = 2 or cnt[i-1,j]=3 or cnt[i-1,j]=6 then
289: return 4:
290: else
291: return 3:
292: fi:
293: elif (i mod 2 = 1 and nops(cnt) mod 2 = 0) or (i mod 2 = 0 and nops(cnt) mod 2 = 1)then
294: if cnt[i-1,j] = 2 or cnt[i-1,j]=3 or cnt[i-1,j]=6 then
295: return 5:
296: else
297: return 6:
298: fi:
299: fi:
300: else
301: if cnt[i,j+1] = 2 or cnt[i,j+1] = 5 or cnt[i,j+1] = 6 then
302: if cnt[i-1,j] = 1 or cnt[i-1,j] = 4 or cnt[i-1,j] = 5 then
303: return 3:
304: else
305: return 4:
306: fi:
307: else
308: if cnt[i-1,j] = 1 or cnt[i-1,j] = 4 or cnt[i-1,j] = 5 then
309: return 6:
310: else
311: return 5:
312: fi:
313: fi:
314:
315: fi:
316:
317:
318: end:
319:
320: fzbot := proc(cnt,i,j) local k:
321:
322: if i=nops(cnt) then
323: if j=nops(cnt) then
324: return 3:
325: elif (nops(cnt)-j) mod 2 = 1 then
326: if cnt[i,j+1] = 1 or cnt[i,j+1]=3 or cnt[i,j+1]=4 then
327: return 5:
328: else
329: return 4:
330: fi:
331: elif (nops(cnt)-j) mod 2 = 0 then
332: if cnt[i,j+1] = 1 or cnt[i,j+1]=3 or cnt[i,j+1]=4 then
333: return 6:
334: else
335: return 3:
336: fi:
337: fi:
338: else
339: if cnt[i,j+1] = 2 or cnt[i,j+1] = 5 or cnt[i,j+1] = 6 then
340: if cnt[i+1,j] = 1 or cnt[i+1,j] = 3 or cnt[i+1,j] = 6 then
341: return 4:
342: else
343: return 3:
344: fi:
345: else
346: if cnt[i+1,j] = 1 or cnt[i+1,j] = 3 or cnt[i+1,j] = 6 then
347: return 5:
348: else
349: return 6:
350: fi:
351: fi:
352:
353: fi:
354:
355:
356: end:
357:
358:
359: fzleft := proc(cnt,i,j) local k:
360:
361: if j=1 then
362: if i=nops(cnt) and nops(cnt) mod 2 = 1 then
363: return 6:
364: elif i=nops(cnt) and nops(cnt) mod 2 = 0 then
365: return 4:
366: elif i mod 2 = 1 then
367: if cnt[i+1,j] = 2 or cnt[i+1,j]=4 or cnt[i+1,j]=5 then
368: return 6:
369: else
370: return 5:
371: fi:
372: elif i mod 2 = 0 then
373: if cnt[i+1,j] = 2 or cnt[i+1,j]=4 or cnt[i+1,j]=5 then
374: return 3:
375: else
376: return 4:
377: fi:
378: fi:
379: else
380: if cnt[i,j-1] = 2 or cnt[i,j-1] = 3 or cnt[i,j-1] = 4 then
381: if cnt[i+1,j] = 1 or cnt[i+1,j] = 3 or cnt[i+1,j] = 6 then
382: return 5:
383: else
384: return 6:
385: fi:
386: else
387: if cnt[i+1,j] = 1 or cnt[i+1,j] = 3 or cnt[i+1,j] = 6 then
388: return 4:
389: else
390: return 3:
391: fi:
392: fi:
393:
394: fi:
395:
396:
397: end:
398:
399:
400:
401:
402: #asmtofpl(asm) returns and draws an FPL for a given ASM
403: asmtofpl := proc(asm) local i,j,k,dim,cnt:
404:
405: dim := nops(convert(asm,listlist));
406:
407: #cnt will mark each corner according to the type of vertex it has
408: #cnt(||)=1, cnt(__)=2, cnt(|_)=3, cnt(|-)=4, cnt(-|)=5, cnt(_|)=6
409: cnt:=[[0$dim]$dim]:
410:
411: for i from 1 to ceil(dim/2) do
412:
413: for j from i to dim+1-i do
414:
415: #Top Row
416: if cnt[i,j]=0 and (i+j) mod 2 = 1 then
417: if asm[i,j]=0 then
418: cnt[i,j]:=fztop(cnt,i,j):
419: elif asm[i,j]=1 then
420: cnt[i,j]:=1:
421: else
422: cnt[i,j]:=2:
423: fi:
424: elif cnt[i,j]=0 and (i+j) mod 2 = 0 then
425: if asm[i,j]=0 then
426: cnt[i,j]:=fztop(cnt,i,j):
427: elif asm[i,j]=1 then
428: cnt[i,j]:=2:
429: else
430: cnt[i,j]:=1:
431: fi:
432: fi:
433:
434: #Right column
435: if cnt[j,dim+1-i]=0 and (dim+1-i+j) mod 2 = 1 then
436: if asm[j,dim+1-i]=0 then
437: cnt[j,dim+1-i]:=fzright(cnt,j,dim+1-i):
438: elif asm[j,dim+1-i]=1 then
439: cnt[j,dim+1-i]:=1:
440: else
441: cnt[j,dim+1-i]:=2:
442: fi:
443: elif cnt[j,dim+1-i]=0 and (dim+1-i+j) mod 2 = 0 then
444: if asm[j,dim+1-i]=0 then
445: cnt[j,dim+1-i]:=fzright(cnt,j,dim+1-i):
446: elif asm[j,dim+1-i]=1 then
447: cnt[j,dim+1-i]:=2:
448: else
449: cnt[j,dim+1-i]:=1:
450: fi:
451: fi:
452:
453: #Bottom Row
454: if cnt[dim+1-i,dim+1-j]=0 and (2*dim+2-i-j) mod 2 = 1 then
455: if asm[dim+1-i,dim+1-j]=0 then
456: cnt[dim+1-i,dim+1-j]:=fzbot(cnt,dim+1-i,dim+1-j):
457: elif asm[dim+1-i,dim+1-j]=1 then
458: cnt[dim+1-i,dim+1-j]:=1:
459: else
460: cnt[dim+1-i,dim+1-j]:=2:
461: fi:
462: elif cnt[dim+1-i,dim+1-j]=0 and (2*dim+2-i-j) mod 2 = 0 then
463: if asm[dim+1-i,dim+1-j]=0 then
464: cnt[dim+1-i,dim+1-j]:=fzbot(cnt,dim+1-i,dim+1-j):
465: elif asm[dim+1-i,dim+1-j]=1 then
466: cnt[dim+1-i,dim+1-j]:=2:
467: else
468: cnt[dim+1-i,dim+1-j]:=1:
469: fi:
470: fi:
471:
472: #Left Column
473: if cnt[dim+1-j,i]=0 and (i+dim+1-j) mod 2 = 1 then
474: if asm[dim+1-j,i]=0 then
475: cnt[dim+1-j,i]:=fzleft(cnt,dim+1-j,i):
476: elif asm[dim+1-j,i]=1 then
477: cnt[dim+1-j,i]:=1:
478: else
479: cnt[dim+1-j,i]:=2:
480: fi:
481: elif cnt[dim+1-j,i]=0 and (i+dim+1-j) mod 2 = 0 then
482: if asm[dim+1-j,i]=0 then
483: cnt[dim+1-j,i]:=fzleft(cnt,dim+1-j,i):
484: elif asm[dim+1-j,i]=1 then
485: cnt[dim+1-j,i]:=2:
486: else
487: cnt[dim+1-j,i]:=1:
488: fi:
489: fi:
490:
491:
492: od:
493: od:
494:
495: #printcnt(cnt):
496: return cnt:
497:
498: end:
499:
500:
501: #fpltoasm(fpl) returns the asm corresponding to the given fpl
502: fpltoasm := proc(fpl) local asm,i,j,dim:
503:
504: dim := nops(fpl):
505:
506: asm := [[0$dim]$dim]:
507:
508: for i from 1 to dim do
509: for j from 1 to dim do
510: if fpl[i,j] > 2 then
511: asm[i,j]=0:
512: elif fpl[i,j] = 2 then
513: if (i+j) mod 2 = 0 then
514: asm[i,j]:= 1:
515: else
516: asm[i,j]:= -1:
517: fi:
518: elif fpl[i,j] = 1 then
519: if (i+j) mod 2 = 0 then
520: asm[i,j]:= -1:
521: else
522: asm[i,j]:= 1:
523: fi:
524: else
525: ERROR(`Something wrong in input`):
526: fi:
527: od:
528: od:
529:
530: return asm:
531:
532:
533: end:
534:
535: #asmtogog(asm) given an ASM returns the corresponding monotone triangle
536: asmtogog := proc(asm) local i,j,k,cnt,gog:
537:
538: gog := [seq([seq(0,j=1..i)],i=1..nops(asm))]:
539:
540: for i from 1 to nops(asm) do
541: cnt:=1:
542: for j from 1 to nops(asm) do
543: if add(asm[k,j],k=1..i) = 1 then
544: gog[i][cnt]:= j:
545: cnt:=cnt+1:
546: fi:
547: od:
548: od:
549:
550: return gog:
551:
552: end:
553:
554:
555:
556: ##################################FPL procedures############################
557: #fplconn(fpl) returns the connectivities of the given FPL as a set of sets of two end vertices
558: fplconn := proc(fpl) local gr,i,j,dim,cc,ends:
559:
560: dim := nops(fpl):
561:
562: gr := fpltograph(fpl):
563:
564: ends := {}:
565:
566: for i from 1 to dim do
567: ends := {seq([2*i-1,0],i=1..ceil(dim/2))} union {seq([0,2*i],i=1..floor(dim/2))}
568: union {seq([dim+2-2*i,dim+1],i=1..ceil(dim/2))} union {seq([dim+1,dim+1-2*i],i=1..floor(dim/2))}:
569: od:
570:
571: cc:= {seq(CC(gr,ends[i]) intersect ends,i=1..nops(ends))}:
572:
573: cc :=subs({seq([0,2*i]=i,i=1..floor(dim/2))},cc):
574: cc :=subs({seq([2*i+dim-2*ceil(dim/2),dim+1]=floor(dim/2)+i,i=1..ceil(dim/2))},cc):
575: cc :=subs({seq([dim+1,dim+1-2*i]=dim+i,i=1..floor(dim/2))},cc):
576: cc :=subs({seq([2*ceil(dim/2)+1-2*i,0]=dim+floor(dim/2)+i,i=1..ceil(dim/2))},cc):
577:
578: return cc:
579:
580: end:
581:
582:
583:
584: #fpls(n) returns the number of times a particular link pattern appears for all fpls of size n by n
585: fpls := proc(n) local i,j,asmn,fpln,lps,uniqlp,numlp:
586:
587: asmn := asm(n):
588:
589: fpln := {seq(asmtofpl(asmn[i]),i=1..nops(asmn))}:
590:
591: lps := [seq(fplconn(fpln[i]),i=1..nops(fpln))]:
592:
593: uniqlp := {seq(lps[i],i=1..nops(lps))}:
594:
595: numlp := Array(1..(2*n)!/n!/(n+1)!):
596:
597: for i from 1 to nops(lps) do
598: for j from 1 to nops(uniqlp) do
599: if lps[i]=uniqlp[j] then
600: numlp[j] := numlp[j]+1:
601: fi:
602: od:
603: od:
604:
605: return {seq([uniqlp[i],numlp[i]],i=1..nops(uniqlp))}:
606:
607:
608: end:
609:
610:
611: #npitofpl(pi) calculates all the fpls that contribute to the given pi
612: npitofpl := proc(pi) local fpln,asmn,lps,i,j,pifpl:
613:
614: pifpl := []:
615:
616: asmn := asm(nops(pi)):
617:
618: fpln := [seq(asmtofpl(asmn[i]),i=1..nops(asmn))]:
619:
620: lps := [seq(fplconn(fpln[i]),i=1..nops(fpln))]:
621:
622: for i from 1 to nops(fpln) do
623: if pi = lps[i] then
624: # printf("%d\n",i):
625: # printfpl(fpln[i]):
626: pifpl := [op(pifpl),fpln[i]]:
627: fi:
628: od:
629:
630: return pifpl:
631:
632: end:
633:
634:
635:
636:
637: #A(pi) returns the number of FPLs with the given endpoint connectivities pi
638: A := proc(pi) local i,num,fpla:
639:
640: fpla := revrs(nops(pi)):
641:
642: for i from 1 to nops(fpla) do
643: if fpla[i][1] = pi then
644: num := fpla[i][2]:
645: fi:
646: od:
647:
648: return num:
649:
650: end:
651:
652:
653: #ei(pi,i) returns the new connectivity obtained by the action of e_i(pi)
654: ei := proc(pi,i) local j,k,npi,ipos,ipluspos,l1,l2,iplus1:
655:
656: if i<2*nops(pi) then
657: iplus1 := i+1:
658: else
659: iplus1 := 1:
660: fi:
661:
662: for j from 1 to nops(pi) do
663: if pi[j][1] = i then
664: ipos := j:
665: l1 := pi[j][2]:
666: fi:
667:
668: if pi[j][2] = i then
669: ipos := j:
670: l1 := pi[j][1]:
671: fi:
672:
673: if pi[j][1] = iplus1 then
674: ipluspos := j:
675: l2 := pi[j][2]:
676: fi:
677:
678: if pi[j][2] = iplus1 then
679: ipluspos := j:
680: l2 := pi[j][1]:
681: fi:
682: od:
683:
684: if ipos < ipluspos then
685: npi := {seq(pi[j],j=1..ipos-1),{i,iplus1},seq(pi[j],j=ipos+1..ipluspos-1),{l1,l2},seq(pi[j],j=ipluspos+1..nops(pi))}:
686: elif ipluspos < ipos then
687: npi := {seq(pi[j],j=1..ipluspos-1),{i,iplus1},seq(pi[j],j=ipluspos+1..ipos-1),{l1,l2},seq(pi[j],j=ipos+1..nops(pi))}:
688: else
689: npi := pi:
690: fi:
691:
692: return npi:
693:
694: end:
695:
696:
697: #invei(pi) given a connectivity pi, returns the set of i's and sigma's such that ei(sigma,i)=pi
698: invei := proc(pi) local i,j,nc,gu:
699:
700: nc := numchords(1,2*nops(pi)):
701:
702: gu:= {}:
703:
704: for i from 1 to nops(nc) do
705: for j from 1 to 2*nops(pi) do
706: if ei(nc[i],j) = pi then
707: gu := gu union {[j,nc[i]]}:
708: fi:
709: od:
710: od:
711:
712: return gu:
713:
714: end:
715:
716: ###########################RS Conjecture procedures#############################
717: #testrs(n) tests the RS conjecture for all configurations in LP(n)
718: testrs := proc(n) local i,j,k,fpla,S,api,numpi:
719:
720: fpla := fpls(n):
721:
722: S := []:
723: for i from 1 to nops(fpla) do
724:
725: api := fpla[i][1]:
726: numpi := 2*n*fpla[i][2]:
727: for j from 1 to nops(fpla) do
728: for k from 1 to 2*n do
729:
730: if ei(fpla[j][1],k) = api then
731: numpi := numpi - fpla[j][2]:
732: fi:
733: od:
734: od:
735:
736: S := [op(S),numpi]:
737:
738: od:
739:
740: return S:
741:
742:
743: end:
744:
745:
746: Eq1:=proc(pi,n,A) local i,sig,lu,gu:
747: gu:=2*n*A[pi]:
748: lu:=numchords(1,2*n):
749: for sig in lu do
750: for i from 1 to 2*n do
751: if ei(sig,i)=pi then
752: gu:=gu-A[sig]:
753: fi:
754: od:
755: od:
756: gu:
757: end:
758:
759:
760: #revrs(n) reverses the RS conjecture to solve for A(pi) for all pi's.
761: revrs := proc(n) local gu,pi,eq,var,pi0,A,i,mu,m:
762:
763: pi0:={seq({2*i,2*i-1},i=1..n)}:
764: gu:=numchords(1,2*n):
765: eq:= {seq(Eq1(pi,n,A), pi in gu)}:
766: #return eq:
767:
768: eq:=subs({A[pi0]=1},eq):
769:
770: var:= {seq(A[pi], pi in gu minus {pi0})} :
771: var:=solve(eq,var):
772:
773: mu:={[pi0,1],seq([pi,subs(var,A[pi])],pi in gu minus {pi0} )}:
774:
775: m:=min(seq(mu[i][2],i=1..nops(mu))):
776:
777:
778: {seq([mu[i][1],mu[i][2]/m],i=1..nops(mu))}:
779:
780:
781: end:
782:
783: #rsmatrix(n) finds the matrix involved in the RS conjecture
784: rsmatrix := proc(n) local i,j,M,C,A,eqs:
785:
786: C := numchords(1,2*n):
787:
788: eqs := {seq(Eq1(C[i],n,A),i=1..nops(C))}:
789: M := [[0$nops(C)]$nops(C)]:
790:
791: for i from 1 to nops(eqs) do
792: for j from 1 to nops(C) do
793: M[i][j] := coeff(eqs[i],A[C[j]]):
794: od:
795: od:
796:
797: return convert(M,matrix):
798:
799: end:
800:
801:
802: #redrsmatrix(n) finds the matrix involved in the RS conjecture when only inequivalent patters are considered
803: redrsmatrix := proc(n) local i,j,k,l,M,C1,C2,A,eqs,chart:
804:
805: C1 := numchords(1,2*n):
806: C2 := ineqchords(n):
807:
808: chart := {}:
809:
810: for i from 1 to nops(C1) do
811: for j from 1 to nops(C2) do
812: for l from 1 to 2*n-1 do
813: if subs({seq(k=k+l,k=1..2*n-l),seq(k=k+l-2*n,k=2*n-l+1..2*n)},C1[i]) =C2[j] then
814: chart := chart union {[C1[i],C2[j]]}:
815: fi:
816: od:
817: od:
818: od:
819:
820: #return chart:
821:
822:
823: eqs := {seq(Eq1(C2[i],n,A),i=1..nops(C2))}:
824: eqs := subs({seq(chart[i][1]=chart[i][2],i=1..nops(chart))},eqs):
825:
826: #return eqs:
827: M := Array(1..nops(C2),1..nops(C2)):
828: #M := [[0$nops(C2)]$nops(C2)]:
829:
830: for i from 1 to nops(eqs) do
831: for j from 1 to nops(C2) do
832: M[i,j] := coeff(eqs[i],A[C2[j]]):
833: od:
834: od:
835:
836: return convert(M,matrix):
837:
838: end:
839:
840:
841:
842:
843:
844: ######################################Procedures about the G_S operator in Wieland's paper#########
845:
846:
847:
848: #gsonfpl(fpl,i,j) applies the operator G_S defined in wieland's paper on the square with lower left vertex=(i,j)
849: gsonfpl := proc(fpl,i,j) local n,nfpl,f1,f2,f3,f4:
850:
851: n := nops(fpl):
852:
853: if (i<0 or i>n) or (j<0 or j>n) then
854: ERROR(`i and j must be between 0 and`,n):
855: fi:
856:
857: if i=0 or i=n or j=0 or j=n then
858: return fpl:
859: fi:
860:
861: nfpl := fpl:
862:
863: f1 := nfpl[i][j]:
864: f3 := nfpl[i+1][j]:
865: f2 := nfpl[i][j+1]:
866: f4 := nfpl[i+1][j+1]:
867:
868: #Horizontal lines -> Vertical lines
869: if (f1=3 or f1=2) and (f2=2 or f2=6) and (f3=2 or f3=4) and (f4=2 or f4=5) then
870: if f1=2 then
871: nfpl[i][j] := 5:
872: else
873: nfpl[i][j] := 1:
874: fi:
875:
876: if f2=2 then
877: nfpl[i][j+1] := 4:
878: else
879: nfpl[i][j+1] := 1:
880: fi:
881:
882: if f3=2 then
883: nfpl[i+1][j] := 6:
884: else
885: nfpl[i+1][j] := 1:
886: fi:
887:
888: if f4=2 then
889: nfpl[i+1][j+1] := 3:
890: else
891: nfpl[i+1][j+1] := 1:
892: fi:
893: fi:
894:
895: # Vertical lines -> Horizontal lines
896: if (f1=1 or f1=5) and (f2=1 or f2=4) and (f3=1 or f3=6) and (f4=1 or f4=3) then
897: if f1=1 then
898: nfpl[i][j] := 3:
899: else
900: nfpl[i][j] := 2:
901: fi:
902:
903: if f2=1 then
904: nfpl[i][j+1] := 6:
905: else
906: nfpl[i][j+1] := 2:
907: fi:
908:
909: if f3=1 then
910: nfpl[i+1][j] := 4:
911: else
912: nfpl[i+1][j] := 2:
913: fi:
914:
915: if f4=1 then
916: nfpl[i+1][j+1] := 5:
917: else
918: nfpl[i+1][j+1] := 2:
919: fi:
920: fi:
921:
922: #printfpl(nfpl):
923: return nfpl:
924:
925:
926: end:
927:
928: #gsodd(fpl) acts the gs operator on the fpl for all odd squares
929: gsodd := proc(fpl) local i,j,nfpl,n:
930:
931: n := nops(fpl):
932: nfpl := fpl:
933:
934: for i from 0 to n do
935: for j from 0 to n do
936: if (i+j) mod 2 = 1 then
937: nfpl := gsonfpl(nfpl,i,j):
938: fi:
939: od:
940: od:
941:
942: return nfpl:
943:
944: end:
945:
946: #gseven(fpl) acts the gs operator on the fpl for all even squares
947: gseven := proc(fpl) local i,j,nfpl,n:
948:
949: n := nops(fpl):
950: nfpl := fpl:
951:
952: for i from 0 to n do
953: for j from 0 to n do
954: if (i+j) mod 2 = 0 then
955: nfpl := gsonfpl(nfpl,i,j):
956: fi:
957: od:
958: od:
959:
960: return nfpl:
961:
962: end:
963:
964: #gsgraph(n) generates the graph whose vertices are all n by n with directed edges marked (i,j) from f to g if the G_S operator on square (i,j) on f takes it to g
965: gsgraph := proc(n) local i,j,k,asmn,V,E:
966:
967: asmn := asm(n):
968:
969: V := {seq(asmtofpl(asmn[i]),i=1..nops(asmn))}:
970:
971: E := {}:
972:
973: for i from 1 to nops(V) do
974: for j from 1 to n-1 do
975: for k from 1 to n-1 do
976: if gsonfpl(V[i],j,k) <> V[i] then
977: E := E union {[{V[i],gsonfpl(V[i],j,k)},[j,k]]}:
978: fi:
979: od:
980: od:
981: od:
982:
983:
984: return V,E:
985:
986: end:
987:
988:
989: #gsmoves(fpl,k) returns all the fpls which can be reached by k moves in the corresponding gsgraph()
990: gsmoves := proc(fpl,k) local n,S,T,i,j,E:
991: option remember:
992:
993: if k=0 then
994: return {[fpl,[]]}:
995: fi:
996:
997: n := nops(fpl):
998: E := gsgraph(n)[2]:
999:
1000: S := gsmoves(fpl,k-1):
1001: T := {}:
1002: for i from 1 to nops(S) do
1003: for j from 1 to nops(E) do
1004: if member(S[i][1],E[j][1]) then
1005: T := T union {[op(E[j][1] minus {S[i][1]}),[op(S[i][2]),E[j][2]]]}:
1006: fi:
1007: od:
1008: od:
1009:
1010: S := T:
1011: T := {}:
1012: for i from 1 to nops(S) do
1013: if nops(S[i][2]) = nops(convert(S[i][2],set)) then
1014: T := T union {S[i]}:
1015: fi:
1016: od:
1017:
1018: return T:
1019:
1020: end:
1021:
1022: #printgsmoves(fpl,k) prints the fpls that arise from fpl by k G_S moves
1023: printgsmoves := proc(fpl,k) local s,S:
1024:
1025: S := gsmoves(fpl,k):
1026:
1027: print(printfpl(fpl),` gives rise to`):
1028: for s in S do
1029: print(printfpl(s[1]),` by moves`, s[2]):
1030: od:
1031:
1032: end:
1033:
1034: #gsfpltofpl(f1,f2,n) returns the minimal set of steps needed to get from f1 to f2
1035: gsfpltofpl := proc(f1,f2,n) local i,j,g1,g2:
1036:
1037: #n := nops(f1):
1038:
1039: for i from 0 to n do
1040: g1 := [op(gsmoves(f1,i))]:
1041: g2 := [seq(g1[i][1],i=1..nops(g1))]:
1042: for j from 1 to nops(g2) do
1043: if g2[j]=f2 then
1044: return g1[j][2]:
1045: fi:
1046: od:
1047: od:
1048:
1049: return FAIL:
1050:
1051: end:
1052:
1053:
1054:
1055: #findbij(conn) given a connectivity, lists its fpls, lists the fpls that it is supposed to go to and finds all the square moves that takes the former to the latter
1056: findbij := proc(conn) local i,j,fpl1,fpl2,c2,S:
1057:
1058: fpl1 := npitofpl(conn):
1059:
1060: c2 := invei(conn):
1061: c2 := {seq(c2[i][2],i=1..nops(c2))}:
1062:
1063: fpl2 := {seq(op(npitofpl(c2[i])),i=1..nops(c2))}:
1064:
1065:
1066: #return fpl2:
1067:
1068: S := {}:
1069:
1070: for i from 1 to nops(fpl1) do
1071: for j from 1 to nops(fpl2) do
1072: # print([fpl1[i],fpl2[j],gsfpltofpl(fpl1[i],fpl2[j])]):
1073: S := S union {[fpl1[i],fpl2[j],gsfpltofpl(fpl1[i],fpl2[j],3)]}:
1074: od:
1075: od:
1076:
1077: print(fpl1):
1078: #print(fpl2):
1079:
1080: return S:
1081:
1082: end:
1083:
1084: ######################################Procedures about Alt paths in FPLs#########
1085:
1086: #fpltograph(fpl) returns the special multi-component graph represented by the fpl
1087: fpltograph := proc(fpl) local ve,ed,i,j,dim:
1088:
1089: dim := nops(fpl):
1090:
1091: ve := {seq(seq([i,j],i=0..dim+1),j=0..dim+1)}:
1092:
1093: ed := {}:
1094:
1095: for i from 1 to dim do
1096: for j from 1 to dim do
1097: if fpl[i,j]=1 then
1098: ed := ed union {{[i-1,j],[i,j]},{[i,j],[i+1,j]}}:
1099: elif fpl[i,j]=2 then
1100: ed := ed union {{[i,j-1],[i,j]},{[i,j],[i,j+1]}}:
1101: elif fpl[i,j]=3 then
1102: ed := ed union {{[i-1,j],[i,j]},{[i,j],[i,j+1]}}:
1103: elif fpl[i,j]=4 then
1104: ed := ed union {{[i+1,j],[i,j]},{[i,j],[i,j+1]}}:
1105: elif fpl[i,j]=5 then
1106: ed := ed union {{[i,j-1],[i,j]},{[i,j],[i+1,j]}}:
1107: elif fpl[i,j]=6 then
1108: ed := ed union {{[i,j-1],[i,j]},{[i,j],[i-1,j]}}:
1109: fi:
1110: od:
1111: od:
1112:
1113:
1114: return [ve,ed]:
1115:
1116: end:
1117:
1118: #graphtofpl(gr) returns the fpl represented by the multi-component graph
1119: graphtofpl := proc(gr) local fpl,i,j,k,n,ed,pt,cpt:
1120:
1121: n := sqrt(nops(gr[1]))-2:
1122: ed := gr[2]:
1123:
1124: fpl := [[0$n]$n]:
1125:
1126: for i from 1 to n do
1127: for j from 1 to n do
1128: pt := [i,j]:
1129: cpt := ctpt(ed,pt):
1130: if evalb([i+1,j] in cpt) and evalb([i-1,j] in cpt) then
1131: fpl[i][j] := 1:
1132: elif evalb([i+1,j] in cpt) and evalb([i,j+1] in cpt) then
1133: fpl[i][j] := 4:
1134: elif evalb([i+1,j] in cpt) and evalb([i,j-1] in cpt) then
1135: fpl[i][j] := 5:
1136: elif evalb([i-1,j] in cpt) and evalb([i,j+1] in cpt) then
1137: fpl[i][j] := 3:
1138: elif evalb([i-1,j] in cpt) and evalb([i,j-1] in cpt) then
1139: fpl[i][j] := 6:
1140: else
1141: fpl[i][j] := 2:
1142: fi:
1143: od:
1144: od:
1145:
1146: return fpl:
1147:
1148: end:
1149:
1150: #findpath(fpl,i) given an fpl and a starting point finds the path in the fplgraph starting at point i
1151: findpath := proc(fpl,i) local n,j,k,ed,cnt,ipt,S,ip1:
1152:
1153: n := nops(fpl):
1154: ed := fpltograph(fpl)[2]:
1155:
1156: if i <= floor(n/2) then
1157: ipt := [0,2*i]:
1158: ip1 := [1,2*i]:
1159: elif i <= n then
1160: ipt := [2*i-n,n+1]:
1161: ip1 := [2*i-n,n]:
1162: elif i <= n + floor(n/2) then
1163: ipt := [n+1,3*n+1-2*i]:
1164: ip1 := [n,3*n+1-2*i]:
1165: else
1166: ipt := [4*n+1-2*i,0]:
1167: ip1 := [4*n+1-2*i,1]:
1168: fi:
1169:
1170: S := [ipt,ip1]:
1171: cnt := 1:
1172:
1173: for j from 1 while cnt = 1 do
1174: cnt := 0:
1175: for k from 1 to nops(ed) do
1176: if evalb(S[nops(S)] in ed[k]) and not evalb(S[nops(S)-1] in ed[k]) then
1177: S := [op(S),op(ed[k] minus {S[nops(S)]})]:
1178: cnt := 1:
1179: fi:
1180: od:
1181: od:
1182:
1183: return S:
1184:
1185: end:
1186:
1187: #distpaths(p1,p2) given two paths in an fpl finds the shortest distance points between them
1188: distpaths := proc(p1,p2) local i,j,d,S:
1189:
1190: d := 2:
1191: S := []:
1192: for i from 1 to nops(p1) do
1193: for j from 1 to nops(p2) do
1194: if abs(p1[i][1]-p2[j][1])+abs(p1[i][2]-p2[j][2]) < d then
1195: S := [[p1[i],p2[j]]]:
1196: d := abs(p1[i][1]-p2[j][1])+abs(p1[i][2]-p2[j][2]):
1197: elif abs(p1[i][1]-p2[j][1])+abs(p1[i][2]-p2[j][2]) = d then
1198: S := [op(S),[p1[i],p2[j]]]:
1199: fi:
1200: od:
1201: od:
1202:
1203: return S:
1204:
1205: end:
1206:
1207: #distpaths4(p1,p2) given two paths in an fpl finds the shortest distance points between them
1208: distpaths4 := proc(p1,p2) local i,j,d,S,f:
1209:
1210: d := 4:
1211: S := []:
1212: for i from 2 to nops(p1)-2 do
1213: for j from 2 to nops(p2)-2 do
1214: f := abs(p1[i][1]-p2[j][1])+abs(p1[i][2]-p2[j][2])
1215: + abs(p1[i+1][1]-p2[j+1][1])+abs(p1[i+1][2]-p2[j+1][2]):
1216: if f <= d then
1217: S := [op(S),[[p1[i],p1[i+1]],[p2[j],p2[j+1]]]]:
1218: fi:
1219: od:
1220: od:
1221:
1222: return S:
1223:
1224: end:
1225:
1226: #distpaths2(p1,p2) given two paths in an fpl finds the shortest distance points between them
1227: distpaths2 := proc(p1,p2) local i,j,d,S,f:
1228:
1229: d := 4:
1230: S := []:
1231: for i from 2 to nops(p1)-2 do
1232: for j from 2 to nops(p2)-2 do
1233: f := abs(p1[i][1]-p2[j][1])+abs(p1[i][2]-p2[j][2])
1234: + abs(p1[i+1][1]-p2[j+1][1])+abs(p1[i+1][2]-p2[j+1][2]):
1235: if f < d then
1236: S := [[[p1[i],p1[i+1]],[p2[j],p2[j+1]]]]:
1237: d := f:
1238: elif f = d then
1239: S := [op(S),[[p1[i],p1[i+1]],[p2[j],p2[j+1]]]]:
1240: fi:
1241: od:
1242: od:
1243:
1244: return S:
1245:
1246: end:
1247:
1248:
1249: #ctpt(ed,pt) given the edges in the fplgraph and a lattice point, finds the other two points connected to it in the fpl
1250: ctpt := proc(ed,pt) local a,b,S:
1251:
1252: S := {}:
1253:
1254: for a from 1 to nops(ed) do
1255: if evalb(pt in ed[a]) then
1256: S := S union {op(ed[a] minus {pt})}:
1257: fi:
1258: od:
1259:
1260: return S:
1261:
1262: end:
1263:
1264: #looparea(L) given a loop in the integer lattice finds the area enclosed by the loop
1265: looparea := proc(L) local i,j,minx,maxx,miny,maxy:
1266: option remember:
1267:
1268: if nops(L)=0 then
1269: return 0:
1270: fi:
1271:
1272: minx := min(seq(L[i][1],i=1..nops(L))):
1273: maxx := max(seq(L[i][1],i=1..nops(L))):
1274: miny := min(seq(L[i][2],i=1..nops(L))):
1275: maxy := max(seq(L[i][2],i=1..nops(L))):
1276:
1277: #return minx,miny,maxx,maxy:
1278: for i from 1 to nops(L)-1 do
1279: for j from i+1 to nops(L)-1 do
1280: if L[i]=L[j] then
1281: return looparea([op(1..i,L),op(j+1..nops(L),L)]) + looparea([op(i..j,L)]):
1282: fi:
1283: od:
1284: od:
1285:
1286:
1287: if {seq(op([[maxx,i],[minx,i]]),i=miny..maxy),seq(op([[i,maxy],[i,miny]]),i=minx..maxx)}={op(L)} then
1288: return (maxx-minx)*(maxy-miny):
1289: fi:
1290:
1291:
1292: for i from 1 to nops(L)-2 do
1293: if L[i]=L[i+2] then
1294: return looparea([op(1..i,L),op(i+3..nops(L),L)]):
1295: fi:
1296: od:
1297:
1298: for i from 1 to nops(L)-2 do
1299: if L[i][1]=maxx-1 and L[i+1][1]=maxx then
1300: if L[i+2][2]>L[i+1][2] then
1301: return 1 + looparea([op(1..i,L),[L[i][1],L[i][2]+1],op(i+2..nops(L),L)]):
1302: elif L[i+2][2]<L[i+1][2] then
1303: return 1 + looparea([op(1..i,L),[L[i][1],L[i][2]-1],op(i+2..nops(L),L)]):
1304: fi:
1305: fi:
1306: od:
1307:
1308: end:
1309:
1310: #nloops(fpl) calculates the number of loops in the given fpl
1311: nloops := proc(fpl) local i,j,n,gr,V,path:
1312:
1313: n := nops(fpl):
1314: gr := fpltograph(fpl)[2]:
1315:
1316: for i from 1 to 2*n do
1317: path := findpath(fpl,i):
1318: path := {seq({path[i],path[i+1]},i=1..nops(path)-1)}:
1319: gr := gr minus path:
1320: od:
1321:
1322: if nops(gr)=0 then
1323: return 0:
1324: fi:
1325:
1326: #return gr:
1327: V := {seq(seq(gr[i][j],j=1..2),i=1..nops(gr))}:
1328:
1329: return `if`(CCD([V,gr])=0,0,nops(CCD([V,gr]))):
1330:
1331: end:
1332:
1333:
1334: #apsq(fpl,sq) finds all alt paths involving sq in the fpl
1335: apsq := proc(fpl,sq) local i,j,k,b1,w1,S,spt,npt,S1,Sprime,B,W,n:
1336: option remember:
1337:
1338: n := nops(fpl):
1339:
1340: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1341: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1342:
1343: B := fpltograph(fpl)[2]:
1344:
1345: W := S minus B:
1346:
1347: #return B,W:
1348:
1349: b1 := {}:
1350: w1 := {}:
1351:
1352: S := {}:
1353:
1354: if evalb({sq,[sq[1]+1,sq[2]]} in B) then
1355: b1 := b1 union {{sq,[sq[1]+1,sq[2]]}}:
1356: else
1357: w1 := w1 union {{sq,[sq[1]+1,sq[2]]}}:
1358: fi:
1359:
1360: if evalb({sq,[sq[1],sq[2]+1]} in B) then
1361: b1 := b1 union {{sq,[sq[1],sq[2]+1]}}:
1362: else
1363: w1 := w1 union {{sq,[sq[1],sq[2]+1]}}:
1364: fi:
1365:
1366: if evalb({[sq[1]+1,sq[2]],[sq[1]+1,sq[2]+1]} in B) then
1367: b1 := b1 union {{[sq[1]+1,sq[2]],[sq[1]+1,sq[2]+1]}}:
1368: else
1369: w1 := w1 union {{[sq[1]+1,sq[2]],[sq[1]+1,sq[2]+1]}}:
1370: fi:
1371:
1372: if evalb({[sq[1],sq[2]+1],[sq[1]+1,sq[2]+1]} in B) then
1373: b1 := b1 union {{[sq[1],sq[2]+1],[sq[1]+1,sq[2]+1]}}:
1374: else
1375: w1 := w1 union {{[sq[1],sq[2]+1],[sq[1]+1,sq[2]+1]}}:
1376: fi:
1377:
1378: for i from 1 to nops(b1) do
1379: for j from 1 to nops(w1) do
1380: if nops(b1[i] intersect w1[j]) > 0 then
1381: spt := op(b1[i] minus w1[j]):
1382: npt := op(b1[i] intersect w1[j]):
1383: S := S union aps1(B,W,[spt,npt,op(w1[j] minus {npt})],spt):
1384: #S := S union {[spt,npt,op(w1[j] minus {npt})]}:
1385: fi:
1386: od:
1387: od:
1388:
1389: S1 := S:
1390: S := {}:
1391:
1392: for i from 1 to nops(S1) do
1393: Sprime := {seq({op(S[j])},j=1..nops(S))}:
1394: if not evalb({op(S1[i])} in Sprime) then
1395: S := S union {S1[i]}:
1396: fi:
1397: od:
1398:
1399: return S:
1400:
1401: end:
1402:
1403: #appath(fpl,P) given an fpl and a part of an alternating path on it returns all allowed alternate fpls from it
1404: appath := proc(fpl,P) local n,i,j,S,B,W:
1405:
1406: n := nops(fpl):
1407:
1408: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1409: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1410:
1411: B := fpltograph(fpl)[2]:
1412: W := S minus B:
1413:
1414: S := aps1(B,W,P,P[1]):
1415:
1416: return S:
1417: #return seq(newaltfpl(fpl,S[i]),i=1..nops(S)):
1418:
1419: end:
1420:
1421: #appath1(fpl,P) given an fpl and a part of an alternating path on it returns all allowed alternate fpls from it
1422: appath1 := proc(fpl,P) local n,i,j,S,B,W:
1423:
1424: n := nops(fpl):
1425:
1426: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1427: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1428:
1429: B := fpltograph(fpl)[2]:
1430: W := S minus B:
1431:
1432: S := aps1(B,W,P,P[1]):
1433:
1434: return seq([newaltfpl(fpl,S[i]),S[i]],i=1..nops(S)):
1435:
1436: end:
1437:
1438:
1439: #aps1(B,W,stpart,ept) returns all alt paths with starting edge seq stpart and last
1440: aps1 := proc(B,W,stpart,ept) local i,j,spt,Wpt,Bpt,p1,S:
1441: option remember:
1442:
1443: if stpart[nops(stpart)]=ept then
1444: return {stpart}:
1445: fi:
1446:
1447: spt := stpart[nops(stpart)]:
1448: #p1 := {[spt[1]+1,spt[2]],[spt[1]-1,spt[2]],[spt[1],spt[2]+1],[spt[1],spt[2]-1]} minus {stpart[nops(stpart)-1]}:
1449: p1 := {[spt[1]+1,spt[2]],[spt[1]-1,spt[2]],[spt[1],spt[2]+1],[spt[1],spt[2]-1]} minus {op(2..nops(stpart)-1,stpart)}:
1450: S := {}:
1451:
1452: #return p1:
1453:
1454: if evalb({stpart[nops(stpart)-1],stpart[nops(stpart)]} in B) then
1455: Wpt := {}:
1456: for i from 1 to nops(p1) do
1457: if evalb({spt,p1[i]} in W) then
1458: Wpt := Wpt union {p1[i]}:
1459: fi:
1460: od:
1461: if nops(Wpt) = 0 then
1462: return {}:
1463: else
1464: for j from 1 to nops(Wpt) do
1465: S := S union aps1(B,W,[op(stpart),Wpt[j]],ept):
1466: od:
1467: fi:
1468: elif evalb({stpart[nops(stpart)-1],stpart[nops(stpart)]} in W) then
1469: Bpt := {}:
1470: for i from 1 to nops(p1) do
1471: if evalb({spt,p1[i]} in B) then
1472: #print(p1[i]):
1473: Bpt := Bpt union {p1[i]}:
1474: fi:
1475: od:
1476: if nops(Bpt) = 0 then
1477: return {}:
1478: else
1479: for j from 1 to nops(Bpt) do
1480: S := S union aps1(B,W,[op(stpart),Bpt[j]],ept):
1481: od:
1482: fi:
1483: fi:
1484:
1485: end:
1486:
1487:
1488: #newaltfpl(fpl,AP) given an fpl and an alt path AP finds the new FPLs given by an involution on the alt path
1489: newaltfpl := proc(fpl,AP) local B,n,gr,B2,i,j:
1490:
1491: n := nops(fpl):
1492:
1493: gr := fpltograph(fpl):
1494: B := gr[2]:
1495:
1496: B2 := B:
1497:
1498: for i from 1 to nops(AP)-2 do
1499: if evalb({AP[i],AP[i+1]} in B) then
1500: B2 := B2 minus {{AP[i],AP[i+1]}} union {{AP[i+1],AP[i+2]}}:
1501: fi:
1502: od:
1503:
1504: #return B2:
1505: return graphtofpl([gr[1],B2]):
1506:
1507: end:
1508:
1509: #allowedaltfpl(fpl,sq) given an fpl and a square finds all the alt path fpls which involve the square and have the correct connectivity
1510: allowedaltfpl := proc(fpl,sq) local conn,alconn,i,j,altpaths,S,S2,m,c1:
1511:
1512: conn := fplconn(fpl):
1513:
1514: alconn := {seq(ei(conn,i),i=1..2*nops(fpl))} minus {conn}:
1515: #alconn := invei(conn)
1516: #alconn := {seq(alconn[i][2],i=1..nops(alconn))} minus {conn}:
1517:
1518: altpaths := apsq(fpl,sq):
1519:
1520: S := {}:
1521:
1522: for i from 1 to nops(altpaths) do
1523: c1 := fplconn(newaltfpl(fpl,altpaths[i])):
1524: if evalb(c1 in alconn) then
1525: #S := S union {[altpaths[i],newaltfpl(fpl,altpaths[i])]}:
1526: S := S union {newaltfpl(fpl,altpaths[i])}:
1527: fi:
1528: od:
1529:
1530: return S:
1531:
1532: end:
1533:
1534: #listaltfpls(n) given the size of the fpls lists all allowed fpls got by the alt path method with the number of times they appeared
1535: listaltfpls := proc(n) local i,j,fpls,asms,S:
1536:
1537: asms := asm(n):
1538: fpls := [seq(asmtofpl(asms[i]),i=1..nops(asms))]:
1539:
1540: #S := []:
1541: #for i from 1 to nops(fpls) do
1542: # for j from 1 to 2*n do
1543: # if nops(fplalt(fpls[i],j)) = 1 then
1544: # S := [op(S),op(fplalt(fpls[i],j))]:
1545: # fi:
1546: # od:
1547: #od:
1548:
1549: S := [seq(seq(fplalt22(fpls[i],j),j=1..2*n),i=1..nops(fpls))]:
1550: return convert(S, multiset):
1551:
1552: end:
1553:
1554: #listaltfpls3(n) given the size of the fpls lists all allowed fpls got by the alt path method with the number of times they appeared
1555: listaltfpls3 := proc(n) local i,j,fpls,asms,S,S2:
1556:
1557: asms := asm(n):
1558: fpls := [seq(asmtofpl(asms[i]),i=1..nops(asms))]:
1559:
1560: S := [seq(seq(fplalt22(fpls[i],j),j=1..2*n),i=1..nops(fpls))]:
1561: S2 := [seq([fpls[i],[]],i=1..nops(fpls))]:
1562:
1563: for i from 1 to nops(S) do
1564: for j from 1 to nops(fpls) do
1565: if S[i][1] = fpls[j] then
1566: S2[j] := [S2[j][1],[op(S2[j][2]),S[i][2]]]:
1567: fi:
1568: od:
1569: od:
1570:
1571: return S2:
1572:
1573: end:
1574:
1575:
1576: #detaltfpl(n,fpl) given the size of the fpls and a given fpl detects how it appeared in listaltfpls(n)
1577: detaltfpl := proc(n,fpl) local i,j,fpls,asms,S:
1578:
1579: asms := asm(n):
1580: fpls := [seq(asmtofpl(asms[i]),i=1..nops(asms))]:
1581:
1582: S := {}:
1583: for i from 1 to nops(fpls) do
1584: for j from 1 to 2*n do
1585: if evalb(fpl in fplalt2(fpls[i],j)) then
1586: S := S union {{fpls[i],j}}:
1587: fi:
1588: od:
1589: od:
1590:
1591: return S:
1592:
1593: end:
1594:
1595: #nfplalt(fpl,i) lists naively the alt paths got from starting point i in the fpl
1596: nfplalt := proc(fpl,i) local j,k,S,B,W,n,conn,iconn,ip1,ipt,ipt1,impt,F,P,F2,P2:
1597:
1598: n := nops(fpl):
1599: conn := fplconn(fpl):
1600: iconn := ei(conn,i):
1601:
1602: if iconn=conn then
1603: return {fpl}:
1604: fi:
1605:
1606: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1607: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1608:
1609: B := fpltograph(fpl)[2]:
1610: W := S minus B:
1611:
1612: if i < 2*n then
1613: ip1:=i+1:
1614: else
1615: ip1:=1:
1616: fi:
1617:
1618: if i <= floor(n/2) then
1619: ipt := [1,2*i]:
1620: elif i <= n then
1621: ipt := [2*i-n,n]:
1622: elif i <= n + floor(n/2) then
1623: ipt := [n,3*n+1-2*i]:
1624: else
1625: ipt := [4*n+1-2*i,1]:
1626: fi:
1627:
1628: if ip1 <= floor(n/2) then
1629: ipt1 := [1,2*ip1]:
1630: elif ip1 <= n then
1631: ipt1 := [2*ip1-n,n]:
1632: elif ip1 <= n + floor(n/2) then
1633: ipt1 := [n,3*n+1-2*ip1]:
1634: else
1635: ipt1 := [4*n+1-2*ip1,1]:
1636: fi:
1637:
1638:
1639: if evalb(type((ipt[1]+ipt1[1])/2,integer)) and evalb(type((ipt[2]+ipt1[2])/2,integer)) then
1640: impt := [(ipt[1]+ipt1[1])/2,(ipt[2]+ipt1[2])/2]:
1641: if evalb({ipt,impt} in B) then
1642: F := [appath(fpl,[ipt,impt,ipt1])]:
1643: P := [op(aps1(B,W,[ipt,impt,ipt1],ipt))]:
1644: else
1645: F := [appath(fpl,[ipt1,impt,ipt])]:
1646: P := [op(aps1(B,W,[ipt1,impt,ipt],ipt1))]:
1647: fi:
1648: elif (ipt[1]=1 and ipt[2]=n) or (ipt1[1]=1 and ipt1[2]=n) then
1649: impt := [1,n]:
1650: if evalb({[1,n],[2,n]} in B) then
1651: F := [appath(fpl,[[2,n],[1,n],[1,n-1]])]:
1652: P := [op(aps1(B,W,[[2,n],[1,n],[1,n-1]],[2,n]))]:
1653: else
1654: F := [appath(fpl,[[1,n-1],[1,n],[2,n]])]:
1655: P := [op(aps1(B,W,[[1,n-1],[1,n],[2,n]],[1,n-1]))]:
1656: fi:
1657: elif (ipt[1]=n and ipt[2]=n) or (ipt1[1]=n and ipt1[2]=n) then
1658: impt := [n,n]:
1659: if evalb({[n,n],[n-1,n]} in B) then
1660: F := [appath(fpl,[[n-1,n],[n,n],[n,n-1]])]:
1661: P := [op(aps1(B,W,[[n-1,n],[n,n],[n,n-1]],[n-1,n]))]:
1662: else
1663: F := [appath(fpl,[[n,n-1],[n,n],[n-1,n]])]:
1664: P := [op(aps1(B,W,[[n,n-1],[n,n],[n-1,n]],[n,n-1]))]:
1665: fi:
1666: elif (ipt[1]=1 and ipt[2]=1) or (ipt1[1]=1 and ipt1[2]=1) then
1667: impt := [1,1]:
1668: if evalb({[1,1],[2,1]} in B) then
1669: F := [appath(fpl,[[2,1],[1,1],[1,2]])]:
1670: P := [op(aps1(B,W,[[2,1],[1,1],[1,2]],[2,1]))]:
1671: else
1672: F := [appath(fpl,[[1,2],[1,1],[2,1]])]:
1673: P := [op(aps1(B,W,[[1,2],[1,1],[2,1]],[1,2]))]:
1674: fi:
1675: else
1676: impt := [n,1]:
1677: if evalb({[n,1],[n,2]} in B) then
1678: F := [appath(fpl,[[n,2],[n,1],[n-1,1]])]:
1679: P := [op(aps1(B,W,[[n,2],[n,1],[n-1,1]],[n,2]))]:
1680: else
1681: F := [appath(fpl,[[n-1,1],[n,1],[n,2]])]:
1682: P := [op(aps1(B,W,[[n-1,1],[n,1],[n,2]],[n-1,1]))]:
1683: fi:
1684: fi:
1685:
1686: return F,P;
1687:
1688: F2 := []:
1689: P2 := []:
1690: for j from 1 to nops(F) do
1691: if fplconn(F[j]) = iconn then
1692: F2 := [op(F2),F[j]]:
1693: P2 := [op(P2),P[j]]:
1694: fi:
1695: od:
1696:
1697: if nops(F2) = 0 then
1698: print(fpl,i,`None`):
1699: fi:
1700:
1701: return F2:
1702:
1703: end:
1704:
1705:
1706:
1707: #fplalt(fpl,i) lists the alt paths got from starting point i in the fpl
1708: fplalt := proc(fpl,i) local j,k,B,W,W2,W3,S3,S1,S2,S,T,T2,n,ipt,ip1,conn,iconn,cnt,d:
1709:
1710: n := nops(fpl):
1711: conn := fplconn(fpl):
1712: iconn := ei(conn,i):
1713:
1714: if iconn=conn then
1715: return {fpl}:
1716: fi:
1717:
1718: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1719: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1720:
1721: B := fpltograph(fpl)[2]:
1722: W := S minus B:
1723:
1724:
1725: if i < 2*n then
1726: ip1:=i+1:
1727: else
1728: ip1:=1:
1729: fi:
1730:
1731: S := distpaths(findpath(fpl,i),findpath(fpl,ip1)):
1732:
1733: T := []:
1734: W2 := []:
1735: cnt := 0:
1736: for j from 1 to nops(S) while cnt=0 do
1737: S1 := {}:
1738: for k from 1 to nops(B) do
1739: if evalb(S[j][1] in B[k]) then
1740: S1 := S1 union B[k] minus {S[j][1]}:
1741: fi:
1742: od:
1743: S2 := [seq(appath(fpl,[S1[k],S[j][1],S[j][2]]),k=1..nops(S1))]:
1744: S3 := [seq(op(aps1(B,W,[S1[k],S[j][1],S[j][2]],S1[k])),k=1..nops(S1))]:
1745: for k from 1 to nops(S2) do
1746: if fplconn(S2[k]) = iconn then
1747: T := [op(T),S2[k]]:
1748: W2 := [op(W2),S3[k]]:
1749: cnt := 1:
1750: fi:
1751: od:
1752: if nops(T) > 1 then
1753: d := min(seq(nops(W2[k]),k=1..nops(W2))):
1754: W3 := []:
1755: T2 := []:
1756: for k from 1 to nops(W2) do
1757: if nops(W2[k]) = d then
1758: W3 := [op(W3),W2[k]]:
1759: T2 := [op(T2),T[k]]:
1760: fi:
1761: od:
1762: T := T2:
1763: if nops(W3)>1 then
1764: print(fpl,i,W3):
1765: fi:
1766: fi:
1767: od:
1768:
1769: return T:
1770:
1771: end:
1772:
1773:
1774: inv2 := proc(fpl) local i,j,asms,fpl1,S,wfpl,n:
1775:
1776: wfpl := {op(wmapfpl(fpl))}:
1777: n := nops(fpl):
1778: asms := asm(n):
1779: fpl1 := [seq(asmtofpl(asms[i]),i=1..nops(asms))]:
1780: S := []:
1781: for i from 1 to nops(fpl1) do
1782: if evalb(op(fplalt2(fpl1[i],2*n))[1] in wfpl) then
1783: S := [op(S),fpl1[i]]:
1784: fi:
1785: od:
1786:
1787: return S:
1788:
1789: end:
1790:
1791: #fplalt22(fpl,i) uses wmapfpl() to determine the alt fpl
1792: fplalt22 := proc(fpl,i) local n,j,k,wfpl,nfpl:
1793:
1794: n := nops(fpl):
1795: if i=2*n then
1796: return fplalt3(fpl,i)[1]:
1797: #return op(fplalt3(fpl,i))[1]:
1798: fi:
1799:
1800: wfpl := wmapfpl(fpl)[2*n-i+1]:
1801: #nfpl := op(fplalt3(wfpl,2*n))[1]:
1802: nfpl := fplalt3(wfpl,2*n)[1]:
1803: return wmapfpl(nfpl)[i+1]:
1804:
1805: end:
1806:
1807:
1808: #fplalt2(fpl,i) lists the alt paths got from starting point i in the fpl
1809: fplalt2 := proc(fpl,i) local j,k,B,W,W2,W3,S3,S1,S2,S,T,T2,n,ipt,ip1,conn,iconn,cnt,d:
1810:
1811: n := nops(fpl):
1812: conn := fplconn(fpl):
1813:
1814: iconn := ei(conn,i):
1815:
1816: if iconn=conn then
1817: return [[fpl,0]]:
1818: # return [fpl]:
1819: fi:
1820:
1821: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1822: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1823:
1824: B := fpltograph(fpl)[2]:
1825: W := S minus B:
1826:
1827:
1828: if i < 2*n then
1829: ip1:=i+1:
1830: else
1831: ip1:=1:
1832: fi:
1833:
1834: S := distpaths2(findpath(fpl,i),findpath(fpl,ip1)):
1835: S1 := []:
1836: for j from 1 to nops(S) do
1837: if abs(S[j][1][1][1]-S[j][2][1][1]) + abs(S[j][1][1][2]-S[j][2][1][2]) = 1 then
1838: S1 := [op(S1),[S[j][1][2],S[j][1][1],S[j][2][1],S[j][2][2]]]:
1839: fi:
1840: if abs(S[j][1][1][1]-S[j][2][2][1]) + abs(S[j][1][1][2]-S[j][2][2][2]) = 1 then
1841: S1 := [op(S1),[S[j][1][2],S[j][1][1],S[j][2][2],S[j][2][1]]]:
1842: fi:
1843: if abs(S[j][1][2][1]-S[j][2][1][1]) + abs(S[j][1][2][2]-S[j][2][1][2]) = 1 then
1844: S1 := [op(S1),[S[j][1][1],S[j][1][2],S[j][2][1],S[j][2][2]]]:
1845: fi:
1846: if abs(S[j][1][2][1]-S[j][2][2][1]) + abs(S[j][1][2][2]-S[j][2][2][2]) = 1 then
1847: S1 := [op(S1),[S[j][1][1],S[j][1][2],S[j][2][2],S[j][2][1]]]:
1848: fi:
1849: od:
1850: #return S1:
1851:
1852: T := []:
1853: W2 := []:
1854: cnt := 0:
1855: for j from 1 to nops(S1) while cnt=0 do
1856:
1857: S2 := [appath(fpl,S1[j])]:
1858: S3 := aps1(B,W,S1[j],S1[j][1]):
1859: for k from 1 to nops(S2) do
1860: if fplconn(S2[k]) = iconn and looparea(S3[k]) <= 2*n-1 then
1861: T := [op(T),S2[k]]:
1862: W2 := [op(W2),S3[k]]:
1863: cnt := 1:
1864: fi:
1865: od:
1866: if nops(T) > 1 then
1867: d := min(seq(nops(W2[k]),k=1..nops(W2))):
1868: W3 := []:
1869: T2 := []:
1870: for k from 1 to nops(W2) do
1871: if nops(W2[k]) = d then
1872: W3 := [op(W3),W2[k]]:
1873: T2 := [op(T2),T[k]]:
1874: fi:
1875: od:
1876: T:=T2:
1877: W2:=W3:
1878: if nops(W3)>1 then
1879: print(fpl,i,W3):
1880: fi:
1881: fi:
1882:
1883: od:
1884:
1885: if nops(T)=0 then
1886: print(`None`,fpl,i,W3):
1887: fi:
1888:
1889: #T := [seq([T[k],nops(W2[k])],k=1..nops(T2))]:
1890: T := [seq([T[k],looparea(W2[k])],k=1..nops(T))]:
1891:
1892: return T:
1893:
1894: end:
1895:
1896: #fplalt3(fpl,i) lists the alt paths got from starting point i in the fpl
1897: fplalt3 := proc(fpl,i) local j,k,B,W,W2,W3,S3,S1,S2,S,T,T2,n,ipt,ip1,conn,iconn,cnt,d:
1898:
1899: n := nops(fpl):
1900: conn := fplconn(fpl):
1901: iconn := ei(conn,i):
1902:
1903: if iconn=conn then
1904: return [fpl]:
1905: fi:
1906:
1907: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1908: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1909:
1910: B := fpltograph(fpl)[2]:
1911: W := S minus B:
1912:
1913:
1914: if i < 2*n then
1915: ip1:=i+1:
1916: else
1917: ip1:=1:
1918: fi:
1919:
1920: S := distpaths2(findpath(fpl,i),findpath(fpl,ip1)):
1921: S1 := []:
1922: for j from 1 to nops(S) do
1923: if abs(S[j][1][1][1]-S[j][2][1][1]) + abs(S[j][1][1][2]-S[j][2][1][2]) = 1 then
1924: S1 := [op(S1),[S[j][1][2],S[j][1][1],S[j][2][1],S[j][2][2]]]:
1925: fi:
1926: if abs(S[j][1][1][1]-S[j][2][2][1]) + abs(S[j][1][1][2]-S[j][2][2][2]) = 1 then
1927: S1 := [op(S1),[S[j][1][2],S[j][1][1],S[j][2][2],S[j][2][1]]]:
1928: fi:
1929: if abs(S[j][1][2][1]-S[j][2][1][1]) + abs(S[j][1][2][2]-S[j][2][1][2]) = 1 then
1930: S1 := [op(S1),[S[j][1][1],S[j][1][2],S[j][2][1],S[j][2][2]]]:
1931: fi:
1932: if abs(S[j][1][2][1]-S[j][2][2][1]) + abs(S[j][1][2][2]-S[j][2][2][2]) = 1 then
1933: S1 := [op(S1),[S[j][1][1],S[j][1][2],S[j][2][2],S[j][2][1]]]:
1934: fi:
1935: od:
1936:
1937: S2 := [seq([appath(fpl,S1[j])],j=1..nops(S1))]:
1938: S3 := [seq(aps1(B,W,S1[j],S1[j][1]),j=1..nops(S1))]:
1939:
1940: #return S2,S3:
1941:
1942: T := []:
1943: W2 := []:
1944: cnt := 0:
1945: for j from 1 to nops(S2) do
1946: for k from 1 to nops(S2[j]) do
1947: if fplconn(S2[j][k]) = iconn then
1948: T := [op(T),S2[j][k]]:
1949: W2 := [op(W2),S3[j][k]]:
1950: fi:
1951: od:
1952: od:
1953:
1954: #return T,W2:
1955:
1956:
1957: if nops(T) > 1 then
1958: d := min(seq(nops(W2[k]),k=1..nops(W2))):
1959: W3 := []:
1960: T2 := []:
1961: for k from 1 to nops(W2) do
1962: if nops(W2[k]) = d then
1963: W3 := [op(W3),W2[k]]:
1964: T2 := [op(T2),T[k]]:
1965: fi:
1966: od:
1967: T := T2:
1968: fi:
1969:
1970: return T:
1971: #return [T[1]]:
1972:
1973: end:
1974:
1975: #fplalt33(fpl,i) lists the alt paths got from starting point i in the fpl
1976: fplalt33 := proc(fpl,i) local j,k,B,W,W2,W3,S3,S1,S2,S,T,T2,n,ipt,ip1,conn,iconn,cnt,d:
1977:
1978: n := nops(fpl):
1979: conn := fplconn(fpl):
1980: iconn := ei(conn,i):
1981:
1982: if iconn=conn then
1983: return [fpl,i]:
1984: fi:
1985:
1986: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
1987: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
1988:
1989: B := fpltograph(fpl)[2]:
1990: W := S minus B:
1991:
1992:
1993: if i < 2*n then
1994: ip1:=i+1:
1995: else
1996: ip1:=1:
1997: fi:
1998:
1999: S := distpaths2(findpath(fpl,i),findpath(fpl,ip1)):
2000: S1 := []:
2001: for j from 1 to nops(S) do
2002: if abs(S[j][1][1][1]-S[j][2][1][1]) + abs(S[j][1][1][2]-S[j][2][1][2]) = 1 then
2003: S1 := [op(S1),[S[j][1][2],S[j][1][1],S[j][2][1],S[j][2][2]]]:
2004: fi:
2005: if abs(S[j][1][1][1]-S[j][2][2][1]) + abs(S[j][1][1][2]-S[j][2][2][2]) = 1 then
2006: S1 := [op(S1),[S[j][1][2],S[j][1][1],S[j][2][2],S[j][2][1]]]:
2007: fi:
2008: if abs(S[j][1][2][1]-S[j][2][1][1]) + abs(S[j][1][2][2]-S[j][2][1][2]) = 1 then
2009: S1 := [op(S1),[S[j][1][1],S[j][1][2],S[j][2][1],S[j][2][2]]]:
2010: fi:
2011: if abs(S[j][1][2][1]-S[j][2][2][1]) + abs(S[j][1][2][2]-S[j][2][2][2]) = 1 then
2012: S1 := [op(S1),[S[j][1][1],S[j][1][2],S[j][2][2],S[j][2][1]]]:
2013: fi:
2014: od:
2015:
2016: S2 := [seq([appath(fpl,S1[j])],j=1..nops(S1))]:
2017: S3 := [seq(aps1(B,W,S1[j],S1[j][1]),j=1..nops(S1))]:
2018:
2019: #return S2,S3:
2020:
2021: T := []:
2022: W2 := []:
2023: cnt := 0:
2024: for j from 1 to nops(S2) do
2025: for k from 1 to nops(S2[j]) do
2026: if fplconn(S2[j][k]) = iconn then
2027: T := [op(T),S2[j][k]]:
2028: W2 := [op(W2),S3[j][k]]:
2029: fi:
2030: od:
2031: od:
2032:
2033: #return T,W2:
2034:
2035:
2036: if nops(T) > 1 then
2037: d := min(seq(nops(W2[k]),k=1..nops(W2))):
2038: W3 := []:
2039: T2 := []:
2040: for k from 1 to nops(W2) do
2041: if nops(W2[k]) = d then
2042: W3 := [op(W3),W2[k]]:
2043: T2 := [op(T2),T[k]]:
2044: fi:
2045: od:
2046: T := T2:
2047: else
2048: W3 := W2:
2049: fi:
2050:
2051: if nops(W3[1]) mod 4 = 1 then
2052: if (i+(nops(W3[1])-1)/4) > 2*n then
2053: cnt := (i+(nops(W3[1])-1)/4) - 2*n:
2054: else
2055: cnt := (i+(nops(W3[1])-1)/4):
2056: fi:
2057: elif nops(W3[1]) mod 4 = 3 then
2058: if (i+(nops(W3[1])-3)/4) > 2*n then
2059: cnt := (i+(nops(W3[1])-3)/4) -2*n:
2060: else
2061: cnt := (i+(nops(W3[1])-3)/4):
2062: fi:
2063: else
2064: cnt := 0:
2065: fi:
2066:
2067: return [T[1],cnt]:
2068:
2069: end:
2070:
2071:
2072: #bumpfpl(fpl) chooses the new fpl according the bumping procedure with minimal displacement
2073: bumpfpl := proc(fpl) local B1,B2,n,conn,iconn,i,j,k,f2,min1,S,T:
2074:
2075: n := nops(fpl):
2076: conn := fplconn(fpl):
2077:
2078: T := []:
2079:
2080: for i from 1 to 2*n do
2081:
2082: iconn := ei(conn,i):
2083: if iconn=conn then
2084: T := [op(T),fpl]:
2085: else
2086: f2 := npitofpl(iconn):
2087: B1 := fpltograph(fpl)[2]:
2088: min1 := nops(B1):
2089: S := {}:
2090:
2091: for j from 1 to nops(f2) do
2092: B2 := fpltograph(f2[j])[2]:
2093: if nops(B1 minus B2) < min1 and not evalb(f2[j] in {op(T)}) then
2094: S := {f2[j]}:
2095: min1 := nops(B1 minus B2):
2096: elif nops(B1 minus B2) = min1 and not evalb(f2[j] in {op(T)}) then
2097: S := S union {f2[j]}:
2098: fi:
2099: od:
2100:
2101: if nops(S) > 1 then
2102: print(fpl,i,`More`,nops(S)):
2103: elif nops(S) = 0 then
2104: print(fpl,i,`None`):
2105: fi:
2106: T := [op(T),op(S)]:
2107: fi:
2108: od:
2109:
2110: return T:
2111:
2112: end:
2113:
2114: #wmapalt(fpl) checks if fplalt(fpl,i) rotated returns the same fpl as fplalt(rotated fpl, i+1)
2115: wmapalt := proc(fpl) local i,j,wfpl,f2,w2,n:
2116:
2117: n := nops(fpl):
2118: wfpl := wmapfpl(fpl)[2]:
2119: f2 := [seq(wmapfpl(op(fplalt3(fpl,i)))[2],i=1..2*n)]:
2120: w2 := [seq(op(fplalt3(wfpl,i)),i=2..2*n),op(fplalt3(wfpl,1))]:
2121: j := 0:
2122: for i from 1 to 2*n do
2123: if f2[i] <> w2[i] then
2124: print(`Not equal`,fpl,i,wfpl,i+1,f2[i],w2[i]):
2125: j := 1:
2126: fi:
2127: od:
2128:
2129: if j=0 then
2130: print(`All fine`):
2131: fi:
2132:
2133: end:
2134:
2135: #brfr(n) tries the brute force algorithm for determining the correct action of e_{2n}
2136: brfr1 := proc(n) local i,j,fs,nfs,asms,conns,iconn,S,S2,Sbar,A,T:
2137:
2138: conns := numchords(1,2*n):
2139: S := []:
2140: S2 := []:
2141:
2142: for i from 1 to nops(conns) do
2143: iconn := ei(conns[i],2*n):
2144: fs := npitofpl(conns[i]):
2145: nfs := npitofpl(iconn):
2146: if iconn=conns[i] then
2147: S := [op(S),seq([fs[j],fs[j]],j=1..nops(fs))]:
2148: elif nops(nfs)=1 then
2149: S := [op(S),seq([fs[j],nfs[1]],j=1..nops(fs))]:
2150: else
2151: S2 := [op(S2),choose1(fs,nfs)]:
2152: fi:
2153: od:
2154:
2155: #return S,S2:
2156: S2 := choose2(S2):
2157:
2158: A := {}:
2159:
2160: for i from 1 to nops(S2) do
2161: Sbar := [op(S),op(S2[i])]:
2162: T := convert([seq(op(wmapfpl(Sbar[j][2])),j=1..nops(Sbar))],multiset):
2163: if {seq(T[j][2],j=1..nops(T))} = {2*n} then
2164: A := A union {Sbar}:
2165: fi:
2166: od:
2167:
2168: A:
2169:
2170: end:
2171:
2172: #choose1(L1,L2) returns a list of all possible ways of matching them
2173: choose1 := proc(L1,L2) local i,j,m,n,Ve2,Ve,S:
2174:
2175: S := []:
2176: n:=nops(L1):
2177: m:=nops(L2):
2178:
2179: Ve2 := { seq(convert(i,base,m) ,i=0..m^n-1) }:
2180: Ve := {}:
2181:
2182: for i from 1 to nops(Ve2) do
2183: if nops(Ve2[i]) < n then
2184: Ve := Ve union {[op(Ve2[i]),0$(n-nops(Ve2[i]))]}:
2185: else
2186: Ve := Ve union {Ve2[i]}:
2187: fi:
2188: od:
2189:
2190: for i from 1 to nops(Ve) do
2191: S := [op(S),[seq([L1[j],L2[Ve[i][j]+1]],j=1..nops(L1))]]:
2192: od:
2193:
2194: return S:
2195:
2196: end:
2197:
2198: choose2 := proc(S) local i,j,L,m,n,Ve2,Ve,cnt:
2199:
2200: L := [seq(nops(S[i]),i=1..nops(S))]:
2201: n:= nops(L):
2202: m := max(op(L)):
2203:
2204: Ve2 := { seq(convert(i,base,m) ,i=0..m^n-1) }:
2205: Ve := {}:
2206:
2207: for i from 1 to nops(Ve2) do
2208: if nops(Ve2[i]) < n then
2209: Ve := Ve union {[op(Ve2[i]),0$(n-nops(Ve2[i]))]}:
2210: else
2211: Ve := Ve union {Ve2[i]}:
2212: fi:
2213: od:
2214:
2215: Ve2 := Ve:
2216: Ve:= {}:
2217: for i from 1 to nops(Ve2) do
2218: cnt := 0:
2219: for j from 1 to nops(L) do
2220: if Ve2[i][j]+1 > L[j] then
2221: cnt := 1:
2222: fi:
2223: od:
2224: if cnt=0 then
2225: Ve := Ve union {Ve2[i]}:
2226: fi:
2227: od:
2228:
2229: return [seq([seq(op(S[j][Ve[i][j]+1]),j=1..nops(Ve[i]))],i=1..nops(Ve))]:
2230:
2231: end:
2232:
2233:
2234: ######################################Procedures about counting FPLs by looking at Lattice Paths#########
2235:
2236:
2237: #roads(stpart,ept,bound) given the starting part of the path, the ending point and the boundary returns the set of all possible non-intersecting paths within the boundary
2238: roads := proc(stpart,ept,bound) local i,j,p1,p2,rds,spt:
2239: option remember:
2240:
2241: if stpart[nops(stpart)] = ept then
2242: return {stpart}:
2243: fi:
2244:
2245: if evalb(stpart[nops(stpart)] in bound) then
2246: return {}:
2247: fi:
2248:
2249: spt := stpart[nops(stpart)]:
2250:
2251: p1 := {[spt[1]+1,spt[2]],[spt[1]-1,spt[2]],[spt[1],spt[2]+1],[spt[1],spt[2]-1]}:
2252: p1 := p1 minus convert(stpart,set):
2253:
2254: p2 := {}:
2255:
2256: for i from 1 to nops(p1) do
2257: p2 := p2 union roads([op(stpart),p1[i]],ept,bound):
2258: od:
2259:
2260: return p2:
2261:
2262: end:
2263:
2264:
2265: #pitoppl(conn) given a connectivity finds all possible partially packed loops
2266: pitoppl := proc(conn) local i,j,bdry,dim,rdconn,paths,lnodes:
2267:
2268: dim := nops(conn):
2269:
2270: bdry := {seq([0,i],i=0..dim+1),seq([i,0],i=0..dim+1),seq([dim+1,i],i=0..dim+1),seq([i,dim+1],i=0..dim+1)}:
2271: bdry := bdry union {seq([1,2*i],i=1..floor(dim/2))} union {seq([dim,dim+1-2*i],i=1..floor(dim/2))} union {seq([2*ceil(dim/2)+1-2*i,1],i=1..ceil(dim/2))} union {seq([2*i+dim-2*ceil(dim/2),dim],i=1..ceil(dim/2))}:
2272:
2273: rdconn := subs({seq(i=[1,2*i],i=1..floor(dim/2)),
2274: seq(floor(dim/2)+i=[2*i+dim-2*ceil(dim/2),dim],i=1..ceil(dim/2)),
2275: seq(dim+i=[dim,dim+1-2*i],i=1..floor(dim/2)),
2276: seq(dim+floor(dim/2)+i=[2*ceil(dim/2)+1-2*i,1],i=1..ceil(dim/2))},conn):
2277:
2278: paths := parentroad(rdconn,bdry):
2279:
2280:
2281: return paths:
2282:
2283: end:
2284:
2285: #pitofpl(conn) given a connectivity finds all possible fpls
2286: pitofpl := proc(conn) local i,j,bdry,dim,rdconn,paths,paths2,lnodes,allnodes,lpnodes:
2287:
2288: dim := nops(conn):
2289:
2290: #cc :=subs({seq([0,2*i]=i,i=1..floor(dim/2))},cc):
2291: #cc :=subs({seq([2*i+dim-2*ceil(dim/2),dim+1]=floor(dim/2)+i,i=1..ceil(dim/2))},cc):
2292: #cc :=subs({seq([dim+1,dim+1-2*i]=dim+i,i=1..floor(dim/2))},cc):
2293: #cc :=subs({seq([2*ceil(dim/2)+1-2*i,0]=dim+floor(dim/2)+i,i=1..ceil(dim/2))},cc):
2294:
2295: bdry := {seq([0,i],i=0..dim+1),seq([i,0],i=0..dim+1),seq([dim+1,i],i=0..dim+1),seq([i,dim+1],i=0..dim+1)}:
2296: bdry := bdry union {seq([1,2*i],i=1..floor(dim/2))} union {seq([dim,dim+1-2*i],i=1..floor(dim/2))} union {seq([2*ceil(dim/2)+1-2*i,1],i=1..ceil(dim/2))} union {seq([2*i+dim-2*ceil(dim/2),dim],i=1..ceil(dim/2))}:
2297:
2298: rdconn := subs({seq(i=[1,2*i],i=1..floor(dim/2)),
2299: seq(floor(dim/2)+i=[2*i+dim-2*ceil(dim/2),dim],i=1..ceil(dim/2)),
2300: seq(dim+i=[dim,dim+1-2*i],i=1..floor(dim/2)),
2301: seq(dim+floor(dim/2)+i=[2*ceil(dim/2)+1-2*i,1],i=1..ceil(dim/2))},conn):
2302:
2303: paths := parentroad(rdconn,bdry):
2304: paths2 := {}:
2305: allnodes := {seq(seq([i,j],i=1..dim),j=1..dim)}:
2306:
2307: for i from 1 to nops(paths) do
2308: lnodes := allnodes minus {seq(seq(paths[i][j][k],k=1..nops(paths[i][j])),j=1..nops(paths[i]))}:
2309: if nops(lnodes) = 0 then
2310: paths2 := paths2 union {paths[i]}:
2311: else
2312: lpnodes := fillloop(lnodes):
2313: if nops(lpnodes)>0 and lpnodes <> {{}} then
2314: paths2 := paths2 union {seq({op(paths[i]),lpnodes[j]},j=1..nops(lpnodes))}:
2315: fi:
2316: fi:
2317: od:
2318:
2319: return paths2:
2320:
2321: end:
2322:
2323:
2324: childroad := proc(spt,ept,bdry) local bdr:
2325: option remember:
2326:
2327: bdr := bdry minus {spt}:
2328:
2329: return roads([spt],ept,bdr):
2330:
2331: end:
2332:
2333: parentroad := proc(rdconn,bdry) local i,j,croad,proad,p2road:
2334: option remember:
2335:
2336: if rdconn={} then
2337: return {{}}:
2338: fi:
2339:
2340: proad := {}:
2341:
2342: croad := childroad(rdconn[1][1],rdconn[1][2],bdry):
2343:
2344: for i from 1 to nops(croad) do
2345: p2road := parentroad(rdconn minus {rdconn[1]},bdry union {op(croad[i])}):
2346: proad := proad union {seq({op(p2road[j]),croad[i]},j=1..nops(p2road))}:
2347: od:
2348:
2349: return proad:
2350:
2351: end:
2352:
2353: #fillloops(sites) finds all possible sets of loops which fill all sites
2354: fillloops := proc(sites) local i,j,k,s2,cnt,lps:
2355:
2356: s2 := {}:
2357: for i from 1 to nops(sites) do
2358: cnt:=0:
2359: for j from 1 to nops(s2) do
2360: for k from 1 to nops(s2[j]) do
2361: if sites[i]=[s2[j][k][1]+1,s2[j][k][2]] or sites[i]=[s2[j][k][1]-1,s2[j][k][2]] or sites[i]=[s2[j][k][1],s2[j][k][2]+1] or sites[i]=[s2[j][k][1],s2[j][k][2]-1] then
2362: s2 := {op(1..j-1,s2),{op(1..nops(s2[j]),s2[j]),sites[i]},op(j+1..nops(s2),s2)}:
2363: cnt:=1:
2364: fi:
2365: od:
2366: od:
2367: if cnt=0 then
2368: s2 := {op(s2),{sites[i]}}:
2369: fi:
2370: od:
2371:
2372: lps := {seq(fillloop(s2[i]),i=1..nops(s2))}:
2373:
2374: return s2:
2375:
2376: end:
2377:
2378: #fillloop(sites) finds all loops which fills all sites and come back home
2379: fillloop := proc(sites) local lps,lps2,lps3,i,j:
2380: option remember:
2381:
2382: if nops(sites) < 4 then
2383: return {{}}:
2384: fi:
2385:
2386: lps2 := {}:
2387:
2388: for i from 4 to nops(sites) do
2389: lps := distn(sites,sites[1],i):
2390: for j from 1 to nops(lps) do
2391: if lps[j][nops(lps[j])] = sites[1] then
2392: lps2 := lps2 union {lps[j]}:
2393: fi:
2394: od:
2395: od:
2396:
2397: lps := lps2:
2398: lps2 := {}:
2399:
2400: for i from 1 to nops(lps) do
2401: if not evalb([lps[i][1],seq(lps[i][nops(lps[i])+1-j],j=2..nops(lps[i]))] in lps2) then
2402: lps2 := lps2 union {lps[i]}:
2403: fi:
2404: od:
2405:
2406: #return lps2:
2407:
2408: lps := {}:
2409:
2410: for i from 1 to nops(lps2) do
2411: lps3 := fillloop(sites minus {op(lps2[i])}):
2412: lps := lps union {seq({lps2[i],op(lps3[j])},j=1..nops(lps3))}:
2413: od:
2414:
2415: lps2 := {}:
2416: for i from 1 to nops(lps) do
2417: if {seq(seq(lps[i][j][k],k=1..nops(lps[i][j])),j=1..nops(lps[i]))} = sites then
2418: lps2 := lps2 union {lps[i]}:
2419: fi:
2420: od:
2421:
2422: return lps2:
2423:
2424: end:
2425:
2426: fllp := proc(sites,pathsofar) local i,j,n,lastpt,S:
2427: option remember:
2428:
2429: n := nops(pathsofar):
2430: lastpt := pathsofar[n]:
2431:
2432: S := {}:
2433:
2434: if nops(sites)=0 then
2435: if ([lastpt[1]+1,lastpt[2]]=pathsofar[1] or [lastpt[1]-1,lastpt[2]]=pathsofar[1] or [lastpt[1],lastpt[2]+1]=pathsofar[1] or [lastpt[1],lastpt[2]-1]=pathsofar[1]) and nops(pathsofar)>3 then
2436: return {pathsofar}:
2437: else
2438: return {}:
2439: fi:
2440: fi:
2441:
2442: for i from 1 to nops(sites) do
2443: if [lastpt[1]+1,lastpt[2]]=sites[i] or [lastpt[1]-1,lastpt[2]]=sites[i] or [lastpt[1],lastpt[2]+1]=sites[i] or [lastpt[1],lastpt[2]-1]=sites[i] then
2444: S := S union {[op(pathsofar),sites[i]]}:
2445: fi:
2446: od:
2447:
2448: return {seq(op(fllp(sites minus {S[i][nops(S[i])]},S[i])),i=1..nops(S))}:
2449:
2450: end:
2451:
2452:
2453: dist1:=proc(sites,v) local i,S:
2454:
2455: S:={}:
2456:
2457: for i from 1 to nops(sites) do
2458: if [v[1]+1,v[2]]=sites[i] or [v[1]-1,v[2]]=sites[i] or
2459: [v[1],v[2]+1]=sites[i] or [v[1],v[2]-1]=sites[i] then
2460: S := S union {sites[i]}:
2461: fi:
2462: od:
2463:
2464: return S:
2465:
2466: end:
2467:
2468: distn:=proc(sites,v,n) local i,j,k,S,T,S2:
2469:
2470: S := {[v]}:
2471:
2472: for i from 1 to n do
2473: S2 := {}:
2474: for j from 1 to nops(S) do
2475: T := dist1(sites,S[j][nops(S[j])]):
2476: S2 := S2 union {seq([op(S[j]),T[k]],k=1..nops(T))}:
2477: od:
2478: S := S2:
2479: od:
2480:
2481: S2 := {}:
2482:
2483: for i from 1 to nops(S) do
2484: if nops({op(1..nops(S[i])-1,S[i])}) = nops([op(1..nops(S[i])-1,S[i])]) and nops({op(2..nops(S[i]),S[i])}) = nops([op(2..nops(S[i]),S[i])]) then
2485: S2 := S2 union {S[i]}:
2486: fi:
2487: od:
2488:
2489: return S2:
2490:
2491: end:
2492:
2493: ##################Procedures about chordal relationships in link patterns#######
2494: #dset(pat) returns the distance set of a given pattern
2495: dset := proc(pat) local i,ans:
2496:
2497: ans := []:
2498:
2499: for i from 1 to nops(pat) do
2500: if abs(pat[i][1]-pat[i][2]) < nops(pat) then
2501: ans:= [op(ans),abs(pat[i][1]-pat[i][2])]:
2502: else
2503: ans:= [op(ans),2*nops(pat)-abs(pat[i][1]-pat[i][2])]:
2504: fi:
2505: od:
2506:
2507: return convert(ans,multiset):
2508:
2509: end:
2510:
2511:
2512:
2513: #part2(S) given a set S, returns the set of all possible 2-pairings of the set
2514: part2 := proc(S) local i,S2,ans:
2515: option remember:
2516:
2517: if nops(S) mod 2 = 1 then
2518: ERROR(`The set must have an even number of elements.`):
2519: fi:
2520:
2521: if nops(S) = 2 then
2522: return {{{S[1],S[2]}}}:
2523: fi:
2524:
2525: ans := {}:
2526:
2527: S2 := combinat[choose](S,2):
2528:
2529: for i from 1 to nops(S2) do
2530: ans := ans union {seq({S2[i],op(part2(S minus S2[i])[j])},j=1..nops(part2(S minus S2[i])))}:
2531: od:
2532:
2533: return ans:
2534:
2535: end:
2536:
2537: #labchords(n) depicts the non-intersecting chords on the labelled set {1,...,2n}
2538: labchords := proc(n) local S,i,j,k,C,C2,cij,cik:
2539:
2540: S := {seq(i,i=1..2*n)}:
2541:
2542: C := part2(S):
2543:
2544: C2 := C:
2545:
2546: for i from 1 to nops(C) do
2547: for j from 1 to nops(C[i]) do
2548: for k from 1 to nops(C[i]) do
2549:
2550: cij := sort([op(C[i][j])]):
2551: cik := sort([op(C[i][k])]):
2552:
2553: if cik[1] < cij[1] then
2554: if cik[2] < cij[2] and cik[2] > cij[1] then
2555: C2 := C2 minus {C[i]}:
2556: fi:
2557: elif cik[1] < cij[2] then
2558: if cik[2] > cij[2] then
2559: C2 := C2 minus {C[i]}:
2560: fi:
2561: fi:
2562: od:
2563: od:
2564: od:
2565:
2566: return C2:
2567:
2568: end:
2569:
2570: #add1(S) adds one to each element in the given bipartition
2571: add1 := proc(S) local n,i,j,S2:
2572:
2573: n := nops(S):
2574:
2575: S2 := [[0$2]$n]:
2576:
2577: for i from 1 to n do
2578: for j from 1 to 2 do
2579: if S[i][j]=2*n then
2580: S2[i][j] := 1:
2581: else
2582: S2[i][j] := S[i][j]+1:
2583: fi:
2584: od:
2585: od:
2586:
2587: return {seq({op(S2[i])},i=1..n)}:
2588:
2589: end:
2590:
2591:
2592:
2593: #unlabchords(n) returns the distance-set of chords on unlabelled points along with the number of times it appears in labchords(n)
2594: unlabchords := proc(n) local S,C,C2,D,i,j:
2595:
2596: C := labchords(n):
2597:
2598: C2 := [seq(dset(C[i]),i=1..nops(C))]:
2599:
2600: S := {op(C2)}:
2601:
2602: D := [0$nops(S)]:
2603:
2604: for i from 1 to nops(C2) do
2605: for j from 1 to nops(S) do
2606: if C2[i] = S[j] then
2607: D[j] := D[j]+1:
2608: fi:
2609: od:
2610: od:
2611:
2612: return seq({S[i],D[i]},i=1..nops(S)):
2613:
2614:
2615: end:
2616:
2617:
2618: #numchords(n1,n2) returns the non-intersecting chords of the points {n1,...,n2} on the circle
2619: numchords := proc(n1,n2) local k,i,j,S,s1,s2:
2620: option remember:
2621:
2622: if n2 <= n1 then
2623: return {}:
2624: fi:
2625:
2626: if n2-n1=1 then
2627: return {{{n1,n2}}}:
2628: fi:
2629:
2630: #S := {seq(seq(seq({{n1,2*k},numchords(n1+1,2*k-1)[i],numchords(2*k+1,n2)[j]},i=1..nops(numchords(n1+1,2*k-1))),j=1..nops(numchords(2*k+1,n2))),k=floor(n1/2)+1..floor(n2/2))}:
2631:
2632: S := {}:
2633:
2634: for k from n1+1 to n2 by 2 do
2635:
2636: s1:=numchords(n1+1,k-1):
2637: s2:=numchords(k+1,n2):
2638:
2639: if nops(s1) = 0 then
2640: if nops(s2)=0 then
2641: S := S union {{n1,k}}:
2642: else
2643: S := S union {seq({{n1,k},op(s2[i])},i=1..nops(s2))}:
2644: fi:
2645: else
2646: if nops(s2)=0 then
2647: S := S union {seq({{n1,k},op(s1[i])},i=1..nops(s1))}:
2648: else
2649: S := S union {seq(seq({{n1,k},op(s1[i]),op(s2[j])},i=1..nops(s1)),j=1..nops(s2))}:
2650: fi:
2651: fi:
2652: od:
2653:
2654: return S:
2655:
2656: end:
2657:
2658: #ineqchords(n) returns the inequivalent chords on 2n points in a circle
2659: ineqchords := proc(n) local i,j,k,S,S2,cnt:
2660:
2661: S := numchords(1,2*n):
2662:
2663: S2 := {}:
2664:
2665: for i from 1 to nops(S) do
2666: cnt:=0:
2667: for j from 1 to 2*n-1 do
2668: if evalb(subs({seq(k=k+j,k=1..2*n-j),seq(k=k+j-2*n,k=2*n-j+1..2*n)},S[i]) in S2) then
2669: cnt:=1:
2670: fi:
2671: od:
2672: if cnt=0 then
2673: S2 := S2 union {S[i]}:
2674: fi:
2675: od:
2676:
2677: return S2:
2678:
2679:
2680: end:
2681:
2682:
2683:
2684: ######################################Procedures about Height Functions#########
2685: #asmtohtfn(asm) given an asm returns the corresponding height function
2686: asmtohtfn := proc(asm) local i,j,k,l,htfn,n:
2687:
2688: n := nops(convert(asm,listlist)):
2689:
2690: htfn := [[0$(n+1)]$(n+1)]:
2691:
2692: for i from 1 to n+1 do
2693: for j from 1 to n+1 do
2694: htfn[i][j] := i+j-2-2*add(add(asm[k-1,l-1],l=2..j),k=2..i):
2695: od:
2696: od:
2697:
2698: return htfn:
2699:
2700: end:
2701:
2702: #htfntoasm(htfn) given a height function returns the corresponding asm
2703: htfntoasm := proc(htfn) local i,j,k,l,asm,n,cor:
2704:
2705: n:= nops(htfn):
2706:
2707: cor := [seq([seq((i+j-2-htfn[i][j])/2,j=1..n)],i=1..n)]:
2708:
2709: asm := [seq([seq(cor[i][j]+cor[i-1][j-1]-cor[i][j-1]-cor[i-1][j],j=2..n)],i=2..n)]:
2710:
2711: return asm:
2712:
2713: end:
2714:
2715: #wmap(htfn) acts on the height function htfn by the map G defined in Wieland's paper and returns the new height function
2716: wmap := proc(htfn) local i,j,h2,n:
2717:
2718: n := nops(htfn):
2719: h2 := htfn:
2720:
2721: for i from 2 to n-1 do
2722: for j from 2 to n-1 do
2723: if (i+j) mod 2 =0 then
2724: if h2[i][j-1]=h2[i][j+1] and h2[i][j-1]=h2[i+1][j] and h2[i][j-1]=h2[i-1][j] then
2725: if h2[i][j] < h2[i][j-1] then
2726: h2[i][j] := h2[i][j]+2:
2727: else
2728: h2[i][j] := h2[i][j]-2:
2729: fi:
2730: fi:
2731: fi:
2732: od:
2733: od:
2734:
2735: for i from 2 to n-1 do
2736: for j from 2 to n-1 do
2737: if (i+j) mod 2 = 1 then
2738: if h2[i][j-1]=h2[i][j+1] and h2[i][j-1]=h2[i+1][j] and h2[i][j-1]=h2[i-1][j] then
2739: if h2[i][j] < h2[i][j-1] then
2740: h2[i][j] := h2[i][j]+2:
2741: else
2742: h2[i][j] := h2[i][j]-2:
2743: fi:
2744: fi:
2745: fi:
2746: od:
2747: od:
2748:
2749:
2750: return h2:
2751:
2752: end:
2753:
2754: #wmapfpl(fpl) given an fpl finds all other fpls which are related to it by rotation
2755: wmapfpl := proc(fpl) local htfn,i,j,S:
2756:
2757: htfn := wmap(asmtohtfn(fpltoasm(fpl))):
2758: S := [fpl]:
2759: #printfpl(fpl):
2760:
2761: #for i from 1 while asmtofpl(htfntoasm(htfn)) <> fpl do
2762: for i from 1 to 2*nops(fpl)-1 do
2763: #print(i):
2764: #printfpl(asmtofpl(htfntoasm(htfn))):
2765: S := [op(S),asmtofpl(htfntoasm(htfn))]:
2766: htfn := wmap(htfn):
2767: od:
2768:
2769: #printfpl(asmtofpl(htfntoasm(wmap(htfn)))):
2770:
2771: return S:
2772:
2773: end:
2774:
2775:
2776:
2777:
2778: ######################################Procedures from CLIQUE written for Math640 in 2006 by Doron Zeilberger#########
2779:
2780: #Neig1(G,v): the set of neighbors of vertex v in G
2781: Neig1:=proc(G,v) local S,e,V,E:
2782: S:={}: V:=G[1]: E:=G[2]:
2783:
2784: for e in E do
2785: if member(v,e) then
2786: S:=S union {(e minus {v})[1]} :
2787: fi:
2788: od:
2789:
2790: S:
2791: end:
2792:
2793:
2794: #Neig(G,S): the set of all neighbors of set of vertices S
2795: Neig:=proc(G,S) local V,s:
2796:
2797: {seq(op(Neig1(G,s)), s in S)}:
2798: end:
2799:
2800:
2801:
2802: ##CC(G,v): Inputs a simple graph G and a vertex v
2803: #outputs the set of vertices that can be reached from v
2804: CC:=proc(G,v) local V,E,S1,S2:
2805:
2806: V:=G[1]: E:=G[2]:
2807: S1:={v}:
2808:
2809: S2:= {v} union Neig(G,S1):
2810:
2811: while S1<>S2 do
2812: S1:=S2:
2813: S2:=S2 union Neig(G,S2):
2814: od:
2815: S2:
2816: end:
2817:
2818:
2819: #CCD(G): inputs a graph and outputs its set of connected
2820: #components
2821: CCD:=proc(G) local V,E,S,cc,v:
2822: V:=G[1]: E:=G[2]:
2823:
2824: S:={}:
2825:
2826: while V<>{} do
2827: v:=V[1]:
2828:
2829: cc:=CC(G,v):
2830: S:= S union {cc}:
2831: V:= V minus cc:
2832: od:
2833:
2834: S:
2835: end:
2836:
2837:
2838:
2839: ##################Procedures from ROBBINS by Doron Zeilberger#########
2840: ASM:=proc(k)
2841: local i,gu,asm:
2842:
2843: gu:=GOGset(k,k):
2844:
2845: print(`There are`, nops(gu),`Alternating Sign Matrices of size`,k):
2846: print(`Here they all are:`):
2847:
2848: for i from 1 to nops(gu) do
2849: asm:=GOGTOASM(op(i,gu)):
2850: print(op(asm)):
2851: od:
2852:
2853:
2854: end:
2855:
2856:
2857: #GOGa(k,n,a) gives the set of k by n Gog-trapezoids such that
2858: #the rightmost border is the vector a
2859:
2860: GOGa:=proc(k,n,a)
2861: local pip,kvu,firow,b,mu,gu,i,j,l,trap,trap1:
2862:
2863: if not k>=1 or not n>=k or not nops(a)=k then
2864: ERROR(`Improper intput`):
2865: fi:
2866:
2867:
2868: if n=k and k=1 then
2869: if not op(1,a)=1 then
2870: RETURN({}):
2871: else
2872: RETURN({[[1]]}):
2873: fi:
2874: fi:
2875:
2876: if n=k then
2877: if not op(1,a)=k then
2878: ERROR(`Wrong input`):
2879: fi:
2880: mu:=GOGa(k-1,k,[op(2..k,a)]):
2881: gu:={}:
2882:
2883: for i from 1 to nops(mu) do
2884: trap1:=op(i,mu):
2885: firow:=op(1,trap1):
2886:
2887: gu:=gu union {[[op(firow),k],op(2..k,trap1)]}:
2888: od:
2889: RETURN(gu):
2890: fi:
2891:
2892: gu:={}:
2893:
2894: kvu:=Tkn(k,n,a):
2895:
2896:
2897: for pip from 1 to nops(kvu) do
2898: b:=op(pip,kvu):
2899:
2900: mu:=GOGa(k,n-1,b):
2901:
2902: for j from 1 to nops(mu) do
2903: trap:=op(j,mu):
2904: trap1:=[op(1..n-k,trap)]:
2905:
2906: for l from n-k+1 to n-1 do
2907: trap1:=[op(trap1),[op(op(l,trap)),op(l-(n-k),a)]]:
2908: od:
2909:
2910: trap1:=[op(trap1),[op(k,a)]]:
2911: gu:=gu union {trap1}:
2912:
2913: od:
2914:
2915:
2916: od:
2917:
2918: gu:
2919:
2920: end:
2921:
2922: GOG:=proc(k,n)
2923: local i,gu,lu:
2924:
2925: lu:=LOGOG(k,n):
2926: gu:={}:
2927:
2928: for i from 1 to nops(lu) do
2929: gu:=gu union GOGa(k,n,op(i,lu)):
2930: od:
2931:
2932: gu:
2933:
2934: print(`The number of Gog Trapezoids with k=`,k,`and n=`,n,`equals`,nops(gu)):
2935: print(`Here they all are`):
2936:
2937: for i from 1 to nops(gu) do
2938: yafe(op(i,gu)):
2939: lprint(``):
2940: od:
2941:
2942: gu:
2943:
2944: end:
2945:
2946:
2947: GOGset:=proc(k,n)
2948: local i,gu,lu:
2949:
2950: lu:=LOGOG(k,n):
2951: gu:={}:
2952:
2953: for i from 1 to nops(lu) do
2954: gu:=gu union GOGa(k,n,op(i,lu)):
2955: od:
2956:
2957: gu:
2958:
2959: gu:
2960:
2961: end:
2962:
2963: GOGTOASM:=proc(mt)
2964: local k,mat,mat1,ro,i,j:
2965:
2966: k:=nops(mt):
2967:
2968: mat:=array(1..k,1..k):
2969: mat1:=array(1..k,1..k):
2970:
2971: for i from 1 to k do
2972: for j from 1 to k do
2973: mat[i,j]:=0:
2974: od:
2975: od:
2976:
2977:
2978: for i from 1 to k do
2979: ro:=op(i,mt):
2980: for j from 1 to nops(ro) do
2981: mat[i,op(j,ro)]:=1:
2982: od:
2983: od:
2984:
2985: for i from 1 to k-1 do
2986: for j from 1 to k do
2987: mat1[i,j]:=mat[i,j]-mat[i+1,j]:
2988: od:
2989:
2990: for j from 1 to k do
2991: mat1[k,j]:=mat[k,j]:
2992: od:
2993:
2994: od:
2995:
2996: mat1:
2997:
2998: end:
2999:
3000:
3001: DECSEQ:=proc(k,n)
3002: local gu,gu1,i1:
3003: option remember:
3004:
3005: if n=1 and k=1 then
3006: RETURN({[1]}):
3007: fi:
3008:
3009: if k=0 and n>=1 then
3010: RETURN({[]}):
3011: fi:
3012:
3013: if n<1 or k<1 then
3014: RETURN({}):
3015: fi:
3016:
3017: gu:=DECSEQ(k,n-1):
3018: gu1:=DECSEQ(k-1,n):
3019:
3020: for i1 from 1 to nops(gu1) do
3021: gu:=gu union {[n,op(op(i1,gu1))]}:
3022: od:
3023:
3024: gu:
3025:
3026: end:
3027:
3028:
3029: DECSEQ0:=proc(k,n)
3030: local gu,gu1,i1:
3031: option remember:
3032:
3033: if n=0 and k=1 then
3034: RETURN({[0]}):
3035: fi:
3036:
3037: if k=0 and n>=1 then
3038: RETURN({[]}):
3039: fi:
3040:
3041: if n<0 or k<1 then
3042: RETURN({}):
3043: fi:
3044:
3045: gu:=DECSEQ0(k,n-1):
3046: gu1:=DECSEQ0(k-1,n):
3047:
3048: for i1 from 1 to nops(gu1) do
3049: gu:=gu union {[n,op(op(i1,gu1))]}:
3050: od:
3051:
3052: gu:
3053:
3054: end:
3055:
3056:
3057: LOGOG:=proc(k,n)
3058: local gu,gu1,i,i1,vec,nakh:
3059:
3060: if not k>=1 or not n>=k then
3061: RETURN({}):
3062: fi:
3063:
3064: gu1:=DECSEQ(k,n):
3065:
3066: gu:={}:
3067:
3068:
3069: for i from 1 to nops(gu1) do
3070: vec:=op(i,gu1):
3071: nakh:=1:
3072: for i1 from 1 to k do
3073: if not op(i1,vec)>=k-i1+1 then
3074: nakh:=0:
3075: exit:
3076: fi:
3077: od:
3078:
3079: if nakh=1 then
3080: gu:=gu union {vec}:
3081: fi:
3082: od:
3083:
3084:
3085: gu:
3086:
3087: end:
3088:
3089:
3090: ELOGOG:=proc(k,n)
3091: local gu,gu1,i,i1,vec,nakh:
3092:
3093: if not k>=1 or not n>=k then
3094: RETURN({}):
3095: fi:
3096:
3097: gu1:=DECSEQ0(k,n+1):
3098:
3099: gu:={}:
3100:
3101:
3102: for i from 1 to nops(gu1) do
3103: vec:=op(i,gu1):
3104: nakh:=1:
3105:
3106: if op(1,vec)=n+1 and op(2,vec)>n then
3107: nakh:=0:
3108: fi:
3109:
3110: if op(1,vec)=n and n=k and op(2,vec)=k then
3111: nakh:=0:
3112: fi:
3113:
3114: for i1 from 1 to k do
3115: if not op(i1,vec)>=k-i1 then
3116: nakh:=0:
3117: exit:
3118: fi:
3119: od:
3120:
3121: if nakh=1 then
3122: gu:=gu union {vec}:
3123: fi:
3124: od:
3125:
3126:
3127: gu:
3128:
3129: end:
3130:
3131:
3132:
3133: #Tkn gives the set T_k(n;a), where a=[a_1, ..., a_k] defined in the
3134: #proof of 1.2.1.1
3135:
3136: Tkn:=proc(k,n,a)
3137: local nakh,i1,b,i,gu,mu:
3138:
3139: mu:=DECSEQ(k,n-1):
3140: gu:={}:
3141:
3142: for i from 1 to nops(mu) do
3143: b:=op(i,mu):
3144:
3145: nakh:=1:
3146:
3147:
3148:
3149: for i1 from 1 to 1 do
3150: if not ( k-i1+1<=op(i1,b) and op(i1,b)<=op(i1,a) )
3151: then
3152: nakh:=0:
3153: fi:
3154:
3155: od:
3156:
3157: for i1 from 2 to k do
3158: if not ( k-i1+1<=op(i1,b) and op(i1,b)<=min( op(i1,a),op(i1-1,a)-1 ) )
3159: then
3160: nakh:=0:
3161: fi:
3162:
3163: od:
3164:
3165:
3166: if nakh=1 then
3167: gu:=gu union {b}:
3168: fi:
3169:
3170: od:
3171:
3172: gu:
3173:
3174: end:
3175:
3176:
3177:
3178:
3179: ############################################Rejected Algorithms##########################################
3180:
3181:
3182:
3183:
3184:
3185:
3186:
3187: #exfplalt(fpl,i) lists the alt paths got from starting point i in the fpl
3188: exfplalt := proc(fpl,i) local j,k,B,W,S1,S2,S,n,ipt,ip1,conn,iconn,ap1,ap2,stpart,sq,fs1,fs2:
3189:
3190: n := nops(fpl):
3191: conn := fplconn(fpl):
3192: iconn := ei(conn,i):
3193:
3194: if iconn=conn then
3195: return {fpl}:
3196: fi:
3197:
3198: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
3199: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
3200:
3201: B := fpltograph(fpl)[2]:
3202:
3203: W := S minus B:
3204:
3205: if i <= floor(n/2) then
3206: ipt := [1,2*i]:
3207: elif i <= n then
3208: ipt := [2*i-n,n]:
3209: elif i <= n + floor(n/2) then
3210: ipt := [n,3*n+1-2*i]:
3211: else
3212: ipt := [4*n+1-2*i,1]:
3213: fi:
3214:
3215: if i < floor(n/2) then
3216: ip1 := [1,2*(i+1)]:
3217: elif i < n then
3218: ip1 := [2*(i+1)-n,n]:
3219: elif i < n + floor(n/2) then
3220: ip1 := [n,3*n+1-2*(i+1)]:
3221: elif i < 2*n then
3222: ip1 := [4*n+1-2*(i+1),1]:
3223: else
3224: ip1 := [1,2]:
3225: fi:
3226:
3227: ip1 := ipt:
3228:
3229: if i < floor(n/2) then
3230: stpart := [ipt,[1,ipt[2]+1],[1,ipt[2]+2]]:
3231: sq := {ipt,[1,ipt[2]+1]}:
3232: elif i = floor(n/2) and n mod 2 = 1 then
3233: stpart := [ipt,[1,ipt[2]+1],[2,ipt[2]+1]]:
3234: sq := {ipt}:
3235: elif i = floor(n/2) and n mod 2 = 0 then
3236: stpart := [[1,ipt[2]-1],ipt,[2,ipt[2]]]:
3237: sq := {[1,ipt[2]-1]}:
3238: ip1 := [1,ipt[2]-1]:
3239: elif i < n then
3240: stpart := [ipt,[ipt[1]+1,n],[ipt[1]+2,n]]:
3241: sq := {[ipt[1],n-1],[ipt[1]+1,n-1]}:
3242: elif i = n then
3243: stpart := [[n-1,n],ipt,[n,n-1]]:
3244: sq := {[n-1,n-1]}:
3245: ip1 := [n-1,n]:
3246: elif i < n+floor(n/2) then
3247: stpart := [ipt,[n,ipt[2]-1],[n,ipt[2]-2]]:
3248: sq := {[n-1,ipt[2]-1],[n-1,ipt[2]-2]}:
3249: elif i = n+floor(n/2) and n mod 2 = 0 then
3250: stpart := [[n,2],ipt,[n-1,1]]:
3251: sq := {[n-1,1]}:
3252: ip1 := [n,2]:
3253: elif i = n+floor(n/2) and n mod 2 = 1 then
3254: stpart := [ipt,[n,1],[n-1,1]]:
3255: sq := {[n-1,1]}:
3256: elif i < 2*n then
3257: stpart := [ipt,[ipt[1]-1,1],[ipt[1]-2,1]]:
3258: sq := {[ipt[1]-1,1],[ipt[1]-2,1]}:
3259: elif i = 2*n then
3260: stpart := [[2,1],ipt,[1,2]]:
3261: sq := {ipt}:
3262: ip1 := [2,1]:
3263: fi:
3264:
3265: #altpaths := aps1(B,W,stpart,ip1):
3266: #if evalb(iconn in {seq(fplconn(newaltfpl(fpl,altpaths[j])),j=1..nops(altpaths))}) then
3267: # print(`Yes`):
3268: #else
3269: # print(`No`):
3270: #fi:
3271: #return altpaths:
3272:
3273: S1 := {}:
3274: S2 := {}:
3275:
3276: if nops(sq) = 1 then
3277: ap1 := apsq(fpl,sq[1]):
3278: fs1 := [seq(newaltfpl(fpl,ap1[j]),j=1..nops(ap1))]:
3279: for j from 1 to nops(fs1) do
3280: if fplconn(fs1[j])=iconn then
3281: S1 := S1 union {fs1[j]}:
3282: fi:
3283: od:
3284: if nops(S1) = 0 then
3285: print(`nothing`,fpl,i):
3286: fi:
3287: return S1:
3288: else
3289: ap1 := apsq(fpl,sq[1]):
3290: ap2 := apsq(fpl,sq[2]):
3291: fs1 := [seq(newaltfpl(fpl,ap1[j]),j=1..nops(ap1))]:
3292: fs2 := [seq(newaltfpl(fpl,ap2[j]),j=1..nops(ap2))]:
3293: for j from 1 to nops(fs1) do
3294: if fplconn(fs1[j])=iconn then
3295: S1 := S1 union {fs1[j]}:
3296: fi:
3297: od:
3298: for j from 1 to nops(fs2) do
3299: if fplconn(fs2[j])=iconn then
3300: S2 := S2 union {fs2[j]}:
3301: fi:
3302: od:
3303: if nops(S1) = 1 and nops(S2) = 1 then
3304: print(`Houston`,fpl,i):
3305: return S1 union S2:
3306: elif nops(S1) = 1 then
3307: return S1:
3308: elif nops(S2) = 1 then
3309: return S2:
3310: elif nops(S1) = 0 and nops(S2) = 0 then
3311: print(`nothing`,fpl,i):
3312: return S1 union S2:
3313: else
3314: print(`Both`,fpl,i):
3315: return S1 union S2:
3316: fi:
3317: fi:
3318:
3319:
3320: end:
3321:
3322:
3323:
3324:
3325: #invfplalt(fpl) lists the inverse of the alt paths which can be got from the given fpl
3326: invfplalt := proc(fpl) local i,j,k,B,W,S1,S2,S,n,ipt,ip1,conn,iconn,ap1,ap2,stpart,sq,fs1,fs2,i2,c2:
3327:
3328: n := nops(fpl):
3329: conn := fplconn(fpl):
3330: iconn := invei(conn):
3331:
3332: i2 := {seq(iconn[i][1],i=1..nops(iconn))}:
3333: c2 := [seq({},i=1..nops(i2))]:
3334:
3335: for i from 1 to nops(iconn) do
3336: for j from 1 to nops(i2) do
3337: if iconn[i][1] = i2[j] then
3338: c2[j] := c2[j] union {iconn[i][2]}:
3339: fi:
3340: od:
3341: od:
3342: c2 := [seq(c2[i] minus {conn},i=1..nops(c2))]:
3343:
3344: #return i2,c2:
3345:
3346: S := {seq(seq({[j,k],[j+1,k]},j=0..n),k=1..n)}
3347: union {seq(seq({[j,k],[j,k+1]},k=0..n),j=1..n)}:
3348:
3349: B := fpltograph(fpl)[2]:
3350: W := S minus B:
3351:
3352: S1 := {}:
3353: S2 := {}:
3354:
3355: for i from 1 to nops(i2) do
3356: if i2[i] <= floor(n/2) then
3357: ipt := [1,2*i2[i]]:
3358: elif i2[i] <= n then
3359: ipt := [2*i2[i]-n,n]:
3360: elif i2[i] <= n + floor(n/2) then
3361: ipt := [n,3*n+1-2*i2[i]]:
3362: else
3363: ipt := [4*n+1-2*i2[i],1]:
3364: fi:
3365:
3366: if i2[i] < floor(n/2) then
3367: stpart := [ipt,[1,ipt[2]+1],[1,ipt[2]+2]]:
3368: sq := {ipt,[1,ipt[2]+1]}:
3369: elif i2[i] = floor(n/2) and n mod 2 = 1 then
3370: stpart := [ipt,[1,ipt[2]+1],[2,ipt[2]+1]]:
3371: sq := {ipt}:
3372: elif i2[i] = floor(n/2) and n mod 2 = 0 then
3373: stpart := [[1,ipt[2]-1],ipt,[2,ipt[2]]]:
3374: sq := {[1,ipt[2]-1]}:
3375: ip1 := [1,ipt[2]-1]:
3376: elif i2[i] < n then
3377: stpart := [ipt,[ipt[1]+1,n],[ipt[1]+2,n]]:
3378: sq := {[ipt[1],n-1],[ipt[1]+1,n-1]}:
3379: elif i2[i] = n then
3380: stpart := [[n-1,n],ipt,[n,n-1]]:
3381: sq := {[n-1,n-1]}:
3382: ip1 := [n-1,n]:
3383: elif i2[i] < n+floor(n/2) then
3384: stpart := [ipt,[n,ipt[2]-1],[n,ipt[2]-2]]:
3385: sq := {[n-1,ipt[2]-1],[n-1,ipt[2]-2]}:
3386: elif i2[i] = n+floor(n/2) and n mod 2 = 0 then
3387: stpart := [[n,2],ipt,[n-1,1]]:
3388: sq := {[n-1,1]}:
3389: ip1 := [n,2]:
3390: elif i2[i] = n+floor(n/2) and n mod 2 = 1 then
3391: stpart := [ipt,[n,1],[n-1,1]]:
3392: sq := {[n-1,1]}:
3393: elif i2[i] < 2*n then
3394: stpart := [ipt,[ipt[1]-1,1],[ipt[1]-2,1]]:
3395: sq := {[ipt[1]-1,1],[ipt[1]-2,1]}:
3396: elif i2[i] = 2*n then
3397: stpart := [[2,1],ipt,[1,2]]:
3398: sq := {ipt}:
3399: ip1 := [2,1]:
3400: fi:
3401:
3402:
3403: ap1 := {seq(op(apsq(fpl,sq[j])),j=1..nops(sq))}:
3404: fs1 := {seq(newaltfpl(fpl,ap1[j]),j=1..nops(ap1))}:
3405: for j from 1 to nops(fs1) do
3406: if evalb(fplconn(fs1[j]) in c2[i]) then
3407: #S1 := S1 union {fs1[j]}:
3408: S1 := S1 union {[i2[i],fs1[j]]}:
3409: fi:
3410: od:
3411:
3412: od:
3413:
3414: return S1:
3415:
3416: end:
3417: