macro( SixStepsLoop = 1, # *-o-*O # SixSteps2Loop = 2, # o-*==*-o # clean6 dessins SixStepsTriangle = 3, # |> # SixStepsSquare = 4, # square # SixStepsBridge = 5, # >-< # Reverse = -1, # o-*==* and o- in == # TwoStepsg0 = 020, # o-*-o # deg-2 black vertex TwoSteps = 101, # *-o-* # clean dessins (deg-2 white vertices) OneStep = 10, # *-o # every dessin if we skip optimizations Min1 = 0, Max1 = 1, Max2 = 2, AllInserts = `FindDessins/AllInserts`, CandidatePairs = `FindDessins/CPairs`, CountL = `FindDessins/CountL`, CountOneCycles = `FindDessins/Count1c`, DecreaseDegreeBy1 = `FindDessins/Dec1`, DecreaseEach = `FindDessins/DecEach`, DecreaseMinMax = `FindDessins/DecMM`, DecreaseMult = `FindDessins/DecM`, DeleteEntry = `FindDessins/DelEntry`, DeletePair = `FindDessins/DelPair`, InRange = `FindDessins/InRange`, InRange2 = `FindDessins/InRange2`, Insert = `FindDessins/Insert`, Insert2Loop = `FindDessins/Insert2Loop`, InsertBridge = `FindDessins/InsertBridge`, InsertLoop = `FindDessins/InsertLoop`, InsertSquare = `FindDessins/InsertSquare`, InsertTriangle = `FindDessins/InsertTriangle`, Insertg0deg2 = `FindDessins/Insertg0deg2`, InsertsClean = `FindDessins/InsertsClean`, Inverse = `FindDessins/Inv`, MakeMin1Positive = `FindDessins/MkPos`, MergeFaces = `FindDessins/MergeF`, NopsDisjCyc = `FindDessins/NDisjCyc`, ReduceF = `FindDessins/Reduce`, RoadMap = `FindDessins/RoadMap`, SWB = `FindDessins/SWB`, ShouldCover = `FindDessins/Cover`, SumOver = `FindDessins/SumOver`, UI = `FindDessins/UI`, UniqueRepresentative = `FindDessins/UR`, # Later addition: ReduceToCleanDessin= `FindDessins/R2D2`, ChooseNext = `FindDessins/ChooseNext`, AddN = `FindDessins/AddN`, g0tog1 = `FindDessins/g0tog1`, Merge3m = `FindDessins/Merge3m`, UseClean2 = `FindDessins/UseClean2`, UseClean6 = `FindDessins/UseClean6`, Swap02 = `FindDessins/Swap02` ): # Input: branching pattern B0,B1,B2. # Output: up to simultaneous conjugacy, all [g0, g1] # for which is transitive in Sn, # g0 has cycle structure B0, # g1 has cycle structure B1, # and g0*g1 has cycle structure B2. FindDessins := proc(B0::list(posint), B1::list(posint), B2::{list(posint),set(list(posint))}) local N, i, nF, g, T, A, t0, n, Algo; N := map(convert, {B0,B1,`if`(type(B2,list),B2,op(B2))}, `+`); if nops(N)>1 then error "Input should be partitions of the same positive integer" elif args[-1]<>'permlist' then # Output T below uses 'permlist' format, convert to "Perm" format: return {seq(map(convert,i, Perm), i=procname(args,'permlist'))} elif _Env_NoSWAP <> true and SumOver(2,B0) < SumOver(2,B1) then return {seq([i[2],i[1]], i=procname(B1,B0,args[3..-1]))} elif _Env_NoSWAP <> true and type(B2, list) and Swap02(B0,B1,B2, N[1]) then return {seq([Inverse(i[1][i[2]]),i[2]], i=procname(B2,B1,B0,args[4..-1]))} fi; t0 := time(); N := N[1]; # N = degree(dessin) = Number of egdes (also called "half-edges") if type(B2,set) then nF := map(nops,B2); if nops(nF)<>1 then return `union`(seq( procname(B0,B1,{seq(`if`(nops(i)=n,i,NULL),i=B2)},args[4..-1]),n=nF)) fi; nF := nF[1] else nF := nops(B2) # nF = number of Faces fi; # Euler: 2-2*g = #vertices - #edges + #faces = (nops(B0)+nops(B1)) - N + nF g := (N+2-nops(B0)-nops(B1)-nF)/2; userinfo(1, 'FindDessins', cat(`Genus `, convert(g,string))); if not type(g,nonnegint) then return {} elif UseClean6(B0,B1,N) then _Env_FD_Only_B1 := false; return ReduceToCleanDessin(B0, B1, `if`(type(B2,set),B2,{B2})) elif N>10 and type(B2,list) and max(B2)>2 and UseClean2(B0,B1,B2) then _Env_FD_Only_B1 := true; return ReduceToCleanDessin(B0, B1, {B2}) fi; i := `if`(type(B2,list),{B2},B2); A := RoadMap(N,g, sort(B0,`>`),sort(B1,`>`),map(sort,i,`>`)); T := {[[], []]}; Algo := OneStep; for n to N do if Algo = OneStep then # General case (only case if you uncomment optimizations) T := AllInserts(T, n, op(2..-1,A[n])) elif type(Algo,set) then n := n+5; T := `union`(seq(`if`( i[1]=SixStepsBridge, InsertBridge, `if`( i[1]=SixStepsSquare, InsertSquare, `if`( i[1]=SixStepsTriangle, InsertTriangle, `if`( i[1]=SixSteps2Loop, Insert2Loop, `if`( i[1]=SixStepsLoop, InsertLoop, 0)))) )(T, n, i[2], op(2..-1,A[n])), i=Algo)) elif Algo[1] = TwoSteps then n := n+1; T := InsertsClean(T, n, Algo[2], op(2..-1,A[n])) elif Algo = TwoStepsg0 then n := n+1; T := Insertg0deg2(T, n, op(2..-1,A[n])) fi; Algo := A[n][1]; userinfo(1, 'FindDessins', cat(` `, nops(T), ` dessins of degree `,n,`/`,N, ` after `, convert(time()-t0,string),` seconds`)) od; T end: SumOver := proc(K,B) local i; add(max(i-K,0),i=B) end: Inverse := proc(v) local i,A; for i to nops(v) do A[v[i]] := i od; [seq(A[i],i=1..nops(v))] end: ################################################# # RoadMap Algorithm # ################################################# RoadMap := proc(N, G, B0::list, B1::list, B2::set(list) ) local B0n,B1n,B2n,B2ns, B6_1,B6_2,B6_3,B6_4,B6_5, n0, n1, nF, A,g,n,SkipFcheck,i,clean,clean1,clean6,ChooseAlgo,SameF, c0m, c0M, c1m, c1M, c2m, c2M, S, S01; # B0n = [Min1, Max1] where Min1 and Max1 are potential cycle-structures of g0 # with minimal resp. maximal number of 1-cycles. B0n := [B0,B0]; B1n := [B1,B1]; B2n := B2; # n0 = number of cycles in g0 = number of black vertices # n1 = number of cycles in g1 = number of white vertices # nF = number of cycles in g2 = number of faces n0, n1, nF := nops(B0), nops(B1), nops(B2[1]); g := G; SkipFcheck := false; SameF := 1; clean1 := evalb(max(B1)=2); S, S01 := infinity$2; for n from N to 1 by -1 do if nF = 1 then SkipFcheck := true # Don't check Face degrees when there's only one fi; B2ns := map(sort,B2n,`>`); SameF := SameF-1; if SameF <= 0 then B2n := B2ns fi; c2m, c2M := seq(CountOneCycles(B2n,i), i=[Min1, Max1]); c0m, c0M := op(map(CountOneCycles,B0n)); c1m, c1M := op(map(CountOneCycles,B1n)); S01 := `if`(n =1, 2, min(S01, c0M+c1M)); # Bound for #1-cycles in g0,g1 S := `if`(n<=3, 3, min(S, S01+c2M)); # Bound for #1-cycles in g0,g1,g2 A[n] := [ChooseAlgo, SkipFcheck, B2ns, [c2m,c2M], nF, S, S01, B0n,B0, [c0m,c0M], n0, B1n,B1, [c1m,c1M], n1, g]; ChooseAlgo := OneStep; # Only choice if we uncomment optimizations. clean := evalb({op(map(op,B1n))}={2}); clean6 := evalb({op(map(op,B0n))}={3}) and clean; if clean6 and n>6 then if nF = 1 then g, nF := g-1, 2; B2n := {seq([n-6-i,i],i=1..(n-6)/2)}; ChooseAlgo := {[SixStepsBridge,0], [SixStepsLoop,0], [SixSteps2Loop,0]} else i := select(has, B2n, 4); B6_4 := ReduceF(DeleteEntry(i,4),1,1); B2n := B2n minus i; i := select(has, B2n, 3); B6_3 := ReduceF(DeleteEntry(i,3),1,1,1); B2n := B2n minus i; i := select(has, B2n, 2); B6_2 := ReduceF(DeleteEntry(i,2),2,2); B2n := B2n minus i; i := select(has, B2n, 1); B6_1 := ReduceF(DeleteEntry(i,1),4,1); B2n := MergeFaces(B2n minus i, clean); B6_5 := ReduceF({seq(sort([i[1]-3, op(i[2..-1])],`>`), i = B2n)},1,1); ChooseAlgo := {seq(`if`(i[2]={}, NULL, i), i = [ [SixStepsLoop, B6_1], [SixSteps2Loop, B6_2], [SixStepsTriangle, B6_3], [SixStepsSquare, B6_4], [SixStepsBridge, B6_5]])}; nF := nF-1; B2n := map(sort, B6_1 union B6_2 union B6_3 union B6_4 union B6_5, `>`) fi; S := n; # no longer used n := n-5; n0 := n0-2; B0n := DeleteEntry(B0n,3,3); n1 := n1-3; B1n := DeleteEntry(B1n,2,2,2) elif n>2 and clean1 and member(2,B0n[1]) and member(2,B0n[2]) and c0m=c0M then B0n := DeleteEntry(B0n,2); n0 := n0-1; # TwoStepsg0 B1n := DeleteEntry(B1n,2); n1 := n1-1; to 2 do if SameF>0 then B2n := {seq(`if`(i[1]=1,NULL, subsop(1=i[1]-1, i)), i=B2n)} else B2n := map(sort, DecreaseEach(B2n), `>`) fi; SameF := SameF - 1 od; S := S+1; # There is a deg-4 dessin for which +2 can occur but n := n-1; # that's caught by the above S := `if`(n<=2... ChooseAlgo := TwoStepsg0 elif c1m > 0 and (clean1 or SkipFcheck or c0m = 0 or c1M <= c0M) then if {op(map(op,A[n+1][12]))} = {2} then # (if clean was true in previous step) ChooseAlgo := [TwoSteps, B0n] # Insert a full edge (2 half-edges) fi; B1n, B0n := DeleteEntry(B1n,1), DecreaseMult(B0n, c1m, 'i'); if SameF > 0 then B2n := {seq(`if`(i[1]=1, NULL, subsop(1=i[1]-1, i)), i=B2n)} else B2n := DecreaseEach(B2n, c1m, i) fi; n1 := n1-1 elif c0m > 0 and (clean1 or SkipFcheck or c0M = c0m) then # or c2m = 0 or c0M <= c2M) B0n, B1n := DeleteEntry(B0n,1), DecreaseMult(B1n, c0m, 'i'); B2n := DecreaseEach(B2n, c0m, i); n0 := n0-1; if clean then SameF := 2 fi elif nF > 1 then nF := nF - 1; B0n := DecreaseMinMax(B0n,false); # false, not clean: FindDessins([3, 3, 5], [1, 1, 1, 2, 2, 2, 2], [1, 2, 8]): B1n := DecreaseMult(B1n, max(1,c2m)); if clean and has(B2n,2) then S := S+1 fi; B2n := MergeFaces(B2n, clean); S01 := S01 + 1; S := max(S, S01); if clean then SameF := 2 fi elif g>0 then # Alternate nF between 1 and 2 until g=0. g, nF := g-1, 2; B0n := DecreaseMinMax(B0n, clean); B1n := DecreaseMinMax(B1n); B2n := {[n-2, 1]}; # B2n is now irrelevant because SkipFcheck = true S01 := S01 + 1; S := S01 # (in case c0M+c1M < S01 and S01 decreases) else # Tree stage. From here on, g=0 and nF=1. if n1>n0 then # Tree with more white than black vertices has a deg-1 white vertex B1n := MakeMin1Positive(B1n) else B0n := MakeMin1Positive(B0n) # There is a deg-1 black vertex fi; n := n+1 # Return to the beginning of the loop with the same n fi od; A end: CountOneCycles := proc(B,M) local i; # Determine (a bound for) the number of 1-cycles if type(B,set) then `if`(M=Min1, min, max)(map(procname, B)) # Only used for B2 else add(`if`(i=1,1,0),i=B) fi end: MakeMin1Positive := proc(B) # Reduce a smallest entry to 1, move the difference to the largest entry: [subsop(1=B[1]+B[-1]-1, -1=1, B[1]), B[2]] end: DeleteEntry := proc(L,F) local i; if nargs > 2 then procname(procname(L,F),args[3..-1]) elif type(L,list(list)) or type(L,set(list)) then map(procname,L,F) else for i to nops(L) do if L[i]=F then return subsop(i=NULL,L) fi od; error "should not reach this point" fi end: DecreaseEach := proc(L,m,b) # Reduce each entry > 1 by 1. local i,j,S; if type(L,set) then map(procname,L,args[2..-1]) elif L[1]=1 then if nops(L)>1 then NULL # This discards L. Decreasing L[1] would make make it 0 # eliminating a face. But the value of nF is chosen by AR. else [] # L = [1] so a degree-decrease produces the empty dessin. fi else j := nops(L); if nargs=3 and b then # if L <> sort(L,`>`) then error "unexpected" fi; S := 0; for j from j to 2 by -1 do S := S + L[j]-1; if S >= m then break fi od fi; # Decrease a face-degree by 1 and move it to the first entry (i.e. L[1]). seq(`if`(L[i]>1, [L[i]-1, op(subsop(i=NULL,L))], NULL),i=1..j) fi end: # This program decreases the degree of g0 while keeping the number of cycles the # same. This means that if [n1 >= n2 >= ... >= nk] is the cycle-structure, a list # of positive integers, you reduce one of those integers by 1, but not a number # that was already 1. # # The cycle-structure of g0 has a range of possible values, and the list B = [B[1], B[2]] # gives the end points of that range: # B[1] having the Minimal possible number of 1-cycles, and # B[2] having the Maximal possible number of 1-cycles. # # The range of possible cycle-structures of g0 can be ordered lexicograhically. This # ordering is a chain because they all have the same degree (= sum of entries) and all # have the same number of entries. B[1] and B[2] are the two end points in this ordering. # DecreaseMinMax := proc(B, c) [DecreaseDegreeBy1(B[1], Min1), DecreaseDegreeBy1(B[2], `if`(nargs>1 and c and B[2][1]>2, Max2, Max1))] end: DecreaseDegreeBy1 := proc(L,M) local j; if L[1]=1 then if nops(L)>1 then error "should not happen" else [] fi else j := 1; while nops(L)>j and ( (M=Min1 and L[j+1]=L[1]) # Min1 --> Reduce largest entry by 1 or (M=Max1 and L[j+1]>1) # Max1 --> Reduce smallest >1 entry by 1 or (M=Max2 and L[j+1]>2) ) # Max2 --> Reduce smallest >2 entry by 1 do j:=j+1 od; subsop(j = L[j]-1, L) # Remained sorted fi end: # This program is similar to DecreaseMinMax except that it takes multiplicity into account. DecreaseMult := proc(B,m,b) local S,j; S := 0; for j from nops(B[2]) to 2 by -1 do S := S + B[2][j]-1; if S >= m then break fi od; if nargs=3 then b := evalb(B[2][j] = min(eval(B[2],1=NULL))) fi; [DecreaseDegreeBy1(B[1], Min1), sort(subsop(j = B[2][j]-1, B[2]),`>`)] end: ReduceF := proc(L,F) local i; # Reduce degree of Face by F if nargs > 2 then procname(procname(L,F),args[3..-1]) elif type(L,set) then map(sort,map(procname,L,F),`>`) else seq(`if`(L[i]>F, subsop(i=L[i]-F,L), NULL), i=1..nops(L)) fi end: MergeFaces := proc(L,c) local v; if type(L,set) then # Lists in L must be sorted, uncomment this if bug: if map(sort,L,`>`) <> L then error "not sorted" fi; map(procname,L,c) elif nops(L) <= 1 then error "Need at least two faces to merge" elif nops(L) = 2 then [L[1]+L[2]-1] else seq(DeletePair(L, v), v = CandidatePairs(L,c)) fi end: CandidatePairs := proc(L,c) local i,j; if c and member(2, L) then j := 2 else j := L[-1] # if j>1 and L[-2]=j then # Look for something of multiplicity 1: # for i from 1 to nops(L)-2 do # if (i=1 or L[i]<>L[i-1]) and L[i]<>L[i+1] then j := L[i] # fi od fi # makes little difference fi; # Merge a face with minimal degree/multiplicity, or degree 2 if clean if {op(L)} = {j} then {[j,j]} else {seq([i, j], i={op(L)} minus {j})} fi end: DeletePair := proc(L, v) [v[1]+v[2]-1, op(DeleteEntry(DeleteEntry(L,v[1]),v[2]))] end: ################################################# # Insert edges # ################################################# AllInserts := proc(T,n, SkipB2Check,B2,R2,nF, S,S01, B0,b0,R0,n0, B1,b1,R1,n1, g) local v,ct,i,j, C0,g0,c0, C1,g1,c1, C2,g2,ginf,ANS; if B2 = {} then return {} elif 2-2*g <> (n0+n1) - n + nF then error "Bug: violated Eulers formula" # g is only used here fi; ct := 0; # Instead of v looping through a set T, we can also make v loop through a text-file # called "Tsorted" by splitting "Tsorted" (unix: split) into reasonable-sized pieces, # and then applying Maple's readdata to obtain v's from those pieces. for v in T do for i to n do g0[i] := Insert(v[1],i,n); C0[i] := CountL(g0[i], n); c0[i] := InRange(C0[i],R0) and InRange2(NopsDisjCyc(g0[i],n),op(B0),b0); g1[i] := Insert(v[2],i,n); C1[i] := CountL(g1[i],n); c1[i] := InRange(C1[i],R1) and InRange2(NopsDisjCyc(g1[i],n),op(B1),b1); od; for j to n do if c1[j] then for i to n do if c0[i] and C0[i]+C1[j] <= S01 then # if {i,j}={n} and n>1 it would be a bug g2 := g0[i][g1[j]]; C2 := CountL(g2, n); if C0[i]+C1[j]+C2 > S or not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0[i],g1[j]], n, [g0[i], g1[j], g2], [C0[i], C1[j], C2]) # Rather than appending the output of UniqueRepresentative to a # table "ANS", we can use Maple's "writedata[APPEND]" to put it in a # file called "Tnotsorted" instead. # These writes are sequential; perfect for a traditional hard drive. fi fi od fi od: od; userinfo(2, UI(ct,4)); {seq(ANS[i],i=1..ct)} # If we used the file "Tnotsorted" then remove duplicates with unix commands "sort" # and "uniq" and put the result in the file "Tsorted". end: UI := proc(ct,n) 'FindDessins', cat(` `$n, ct ,` pairs before discarding conjugates`) end: Insert := proc(g,k,n) # Insert new entry in 'permlist' permutation if k=n then [op(g),n] else [op(g[1..k-1]), n, op(g[k+1..-1]), g[k]] fi end: CountL := proc(v,n) # Count 1-cycles for a permutation in permlist-notation local i,s; s := 0; for i to n do if i=v[i] then s := s+1 fi od; s end: InRange := proc(c, R) # Quick check (may be omitted; sub-check of InRange2) evalb(c >= R[1] and c <= R[2]) end: InRange2 := proc(v, m, M, B) local a,s,S,i; if nops(v)<>nops(m) then return false fi; a,s,S := 0,0,0; for i to nops(v)-1 do a,s,S := a+v[i], s+m[i], S+M[i]; if aS or v[i]>B[i] then return false fi od; true # Means that v is between m and M in lexicographic ordering end: NopsDisjCyc := proc(L,n) # cycle-lengths when L is converted to disjoint-cycle local l,i,j,k,c,cyc,dn; l := 0; for i to n do if dn[i]<>0 then l := l+1; c := L[i]; for k while c<>i do dn[c] := 0; c := L[c] od; cyc[l] := k fi od; sort([seq(cyc[j],j=1..l)],`>`) end: InsertsClean := proc(T,n, prevB0, SkipB2Check,B2,R2,nF, S,S01, B0,b0,R0) local g0a,g0b,v,ct,i,C0,C2,g0,g1,j,g2,ginf,ANS; if R0[2]<>S01 then error "unexpected" fi; ct := 0; for v in T do g0 := v[1]; g1 := [op(v[2]),n,n-1]; for i to n-2 do g0a := Insert(g0, i, n-1); if InRange2(NopsDisjCyc(g0a, n-1), op(prevB0),b0) then for j from i+1 to n do g0b := Insert(g0a, j, n); C0 := CountL(g0b,n); if InRange(C0,R0) and InRange2(NopsDisjCyc(g0b,n),op(B0),b0) then g2 := g0b[g1]; C2 := CountL(g2, n); if C0+C2 > S or not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0b,g1], n, [g0b,g2],[C0,C2]) fi fi od fi od od; userinfo(2, UI(ct,2)); {seq(ANS[i],i=1..ct)} end: Insertg0deg2 := proc(T,n, SkipB2Check,B2,R2,nF, S) local v,ct,i,C0,C1,C2,g0,g1,g1a,j,g2,ginf,ANS; ct := 0; for v in T do g0 := [op(v[1]),n,n-1]; C0 := CountL(g0,n); g1 := v[2]; C1 := CountL(g1, n-2); # if C0+C1 > S01 then error "unexpected" fi; for i to n-2 do j := g1[i]; if j >= i then if j>i then g1a := [op(subsop(i=n-1, j=n, g1)), i, j] else g1a := [op(subsop(i=n-1, g1)), i, n] fi; g2 := g0[g1a]; C2 := CountL(g2, n); if C0+C1+C2 > S or not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0,g1a], n, [g0, g1a, g2], [C0, C1, C2]) fi fi od od; userinfo(2, UI(ct,2)); {seq(ANS[i],i=1..ct)} end: InsertLoop := proc(T,n,B2old, SkipB2Check,B2,R2,nF) local v,ct,i,C2,g0,g1,g1a,j,g2,ginf,ANS; ct := 0; for v in T do if ShouldCover(v,B2old) then g1 := [op(v[2]), (n-4,n-5), (n-2,n-3)]; # 2-cycles g0 := [op(v[1]), (n-4,n-3,n-5), (n-1,n,n-2)]; # 3-cycles for i to n-6 do j := g1[i]; if j=i or g1[j]<>i then error "bug" fi; g1a := [op(subsop(i=n-1, j=n, g1)), i, j]; g2 := g0[g1a]; C2 := CountL(g2, n); if not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0,g1a], n, [g2], [C2]) fi od fi od; userinfo(2, UI(ct,4)); {seq(ANS[i],i=1..ct)} end: Insert2Loop := proc(T,n,B2old, SkipB2Check,B2,R2,nF) local v,ct,i,C2,g0,g1,g1a,j,g2,ginf,ANS; ct := 0; for v in T do if ShouldCover(v,B2old) then g1 := [op(v[2]), (n-4,n-5), (n-2,n-3)]; # 2-cycles g0 := [op(v[1]), n-1,n-3,n,n-5,n-2,n-4 ]; # 3-cycles (n-5 n-1 n-2)(n n-4 n-3) if args[-1] = Reverse then g0 := [op(v[1]), n-2,n-3,n,n-1,n-5,n-4 ] # 3-cycles (n-5 n-2 n-1)(n n-4 n-3) fi; for i to n-6 do j := g1[i]; if j>i then # if g1[j]<>i then bug g1a := [op(subsop(i=n-1, j=n, g1)), i, j]; g2 := g0[g1a]; C2 := CountL(g2, n); if not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0,g1a], n, [g2], [C2]) fi fi od fi od; userinfo(2, UI(ct,3)); {seq(ANS[i],i=1..ct)} end: InsertTriangle := proc(T,n,B2old, SkipB2Check,B2,R2,nF) local v,ct,i,C2,g0,g0a,g1,j,k,g2,ginf,ANS; ct := 0; for v in T do if ShouldCover(v,B2old) then g1 := [op(v[2]), (n-4,n-5), (n-2,n-3), (n, n-1)]; # 2-cycles g0 := v[1]; for i to n-6 do j := g0[i]; k := g0[j]; if i>j and i>k then # if g0[k]<>i then bug g0a := [op(subsop(i=n, j=n-2, k=n-4, g0)), i, n-3, k, n-1, j, n-5]; g2 := g0a[g1]; C2 := CountL(g2, n); if not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0a,g1], n, [g2], [C2]) fi fi od fi od; userinfo(2, UI(ct,0)); {seq(ANS[i],i=1..ct)} end: InsertSquare := proc(T,n,B2old, SkipB2Check,B2,R2,nF) local v,ct,i,C2,g0,g1,g1a,j,g2,ginf,ANS; ct := 0; for v in T do if ShouldCover(v,B2old) then g1 := [op(v[2]), (n-4,n-5), (n-2,n-3)]; for i to n-6 do j := g1[i]; if j>i then # if g1[j]<>i then bug g0 := v[1]; if j = g0[i] or i = g0[j] then next fi; g0 := [op(subsop( j=g0[j], g0[j]=n-5, g0[g0[j]]=n-1, i=g0[i], g0[i]=n-2, g0[g0[i]]=n, g0)), j,g0[g0[j]], g0[g0[i]],i ,n-4,n-3 ]; # 3-cycles g1a := [op(subsop(i=n-1, j=n, g1)), i, j]; # 2-cycles g2 := g0[g1a]; C2 := CountL(g2, n); if not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0,g1a], n, [g2], [C2]) fi fi od fi od; userinfo(2, UI(ct,2)); {seq(ANS[i],i=1..ct)} end: InsertBridge := proc(T,n,B2old, SkipB2Check,B2,R2,nF) local v,ct,i,C2,g0,g1,g1a,j,g2,ginf,ANS,k,l; ct := 0; for v in T do if ShouldCover(v,B2old) then g0 := [op(v[1]), (n-3, n-5, n-4), (n-1, n, n-2)]; # 3-cycles g1 := v[2]; for i to n-6 do j := g1[i]; for k to n-6 do l := g1[k]; if min(i,j) < min(k,l) then g1a := [op(subsop(i=n-2, j=n, k=n-3, l=n-4, g1)), n-1, l, k, i, n-5, j]; g2 := g0[g1a]; C2 := CountL(g2, n); if not (SkipB2Check or InRange(C2, R2)) then next fi; ginf := NopsDisjCyc(g2, n); if nops(ginf) = nF and (SkipB2Check or member(ginf,B2)) then ct := ct+1; ANS[ct] := UniqueRepresentative([g0,g1a], n, [g2], [C2]) fi fi od od fi od; userinfo(2, UI(ct,2)); {seq(ANS[i],i=1..ct)} union `if`(nF-2 = n/6, {}, Insert2Loop(args, Reverse)) end: ShouldCover := proc(v, B) B = 0 or member(sort(NopsDisjCyc(v[1][v[2]], nops(v[1])),`>`), B) end: # Find g in with 1-cycles and loop SWB over those: UniqueRepresentative := proc(D::list, n, g, C) local b,i; if nargs=3 then # Call SWB for each 1-cycle b in g: sort([seq(`if`(g[b]=b, SWB(D, b, n), NULL), b = 1..n)])[1] elif nargs=4 then b := {op(C)} minus {0}; if b={} then b := g[-1][g[-1]]; i := 0; while CountL(b,n)=0 do i := i+1; b:=b[`if`(irem(irem(i,5),2)=1, D[1], g[-1])] od; procname(D, n, b) else b := min(b); # Select g with fewest 1-cycles: for i while C[i]<>b do od: procname(D, n, g[i]) fi elif nargs=2 then b := [op(D), D[1][D[-1]]]; # [g0,g1, g0g1] procname(D, n, b, map(CountL,b,n)) elif not type(D[1],list(posint)) then # Convert to permlist notation b := max(map(op,map(op,D))); map(convert,procname([seq(convert(i,'permlist',b),i=D)]), Perm) else procname(D, nops(D[1])) fi end: SWB := proc(D, b, n) # D = [g0,g1,..] with each g in permlist-notation local pi,invpi,g,l,k,found,r; pi[1] := b; invpi[b] := 1; for g in D do l[g] := 1 od; for k to n-1 do # Find first pair (g in D, l in 1..k) with g(pi(l)) not in pi(1)..pi(k) found := false; for g in D do while l[g] <= k and not found do r := g[pi[l[g]]]; if not assigned(invpi[r]) then # Found (g,l). Now let pi(k+1) := g(pi(l)). found := true; pi[k+1] := r; invpi[r] := k+1 fi; l[g] := l[g]+1 od od; if not found then error "Input of UniqueRepresentative should be transitive" fi od; # Compute product(invpi,g,pi) for each g in D: [seq([seq(invpi[g[pi[k]]],k=1..n)],g=D)] end: ############################################### # Reduce to "clean" or to "3-2-clean" dessins # ############################################### ReduceToCleanDessin := proc(B0, B1, B2::set) local m,n,C,g; n := convert(B0,`+`); C := CountOneCycles(B0), CountOneCycles(B1); g, m := ChooseNext(B0, B1); if g = 1 then g0tog1(procname([op(B0),m], [op(DeleteEntry(B1,m)), 2$m], AddN(B2,1$m)) , m, n, C, map(sort,B2,`>`)) elif g = 0 and _Env_FD_Only_B1 <> true then Merge3m(procname([op(DeleteEntry(B0,m)),m-1,3], [op(B1),2], AddN(B2,1,1)) , m-1, n, C, map(sort,B2,`>`)) else FindDessins(args, 'permlist') fi end: # Needs fine tuning. ChooseNext := proc(B0,B1) local m; m := max(B1); if m > 2 then 1, m else m := max(B0); if m > 3 then 0, m else 2, 0 fi fi end: AddN := proc(S::set, N::posint) local i,L; if nargs=2 then map(sort,{seq(seq(subsop(i = L[i]+N, L), i=1..nops(L)),L=S)},`>`) else procname(procname(S,N),args[3..-1]) fi end: g0tog1 := proc(T, m, n, C0,C1, B2) local v,ct,i,g0,g1,g1a,j,g2,ginf,ANS, a,b,c,d,t,g01; ct := 0; for v in T do g0, g1 := op(v); for i to n+1 do t[i]:=0 od: # Search for an m-cycle in g0 for i to n+1 do if t[i]=0 then c[1] := i; b := g1[i]; if b=i or g1[b]<>i then next fi; d[1] := b; for j to m-1 do a := g0[c[j]]; b := g1[a]; t[a] := 1; if a <=i or b=a or g1[b]<>a then break fi; c[j+1] := a; d[j+1] := b od; if j=m and g0[c[m]]=i then # Found an m-cycle in g0 connected to 2-cycles in g1 # cycle: c[1] .. c[m] # This g0-cycle will be erased with SWB. # cycle: d[1] .. d[m] # This will be the new g1-cycle. if has({seq(c[j],j=1..m)}, {seq(d[j],j=1..m)}) then next # Some edges loop back to the same g0-cycle fi; g1a := subsop( seq(d[j]=d[j+1], j=1..m-1), d[m]=d[1], g1); g01 := SWB([g0, g1a], d[1], n); g2 := g01[1][g01[2]]; ginf := NopsDisjCyc(g2,n); if member(ginf,B2) then ct := ct+1; ANS[ct] := UniqueRepresentative(g01,n,[op(g01),g2],[C0,C1,CountOneCycles(ginf)]) fi fi fi od od; userinfo(1, UI(ct,3)); {seq(ANS[i],i=1..ct)} end: # Merge a g0-3-cycle and a g0-m-cycle that are connected by a g1-2-cycle Merge3m := proc(T, m, n, C0,C1, B2) # Let (i j) be the 2-cyle along which we want to merge a 3-cycle with an m-cycle. # Entries i j have to disappear, say, with SWB. # Then we have to build a cycle like this: (g0[i] g0^2[i] g0[j] g0^2[j] g0^3[j]) # To build that, g0^2[i] should point to g0[j] and g0^(m-1)[j] should point to g0[i] # Diagram for m=4 # # g0[i] g0^3[j] # \ / # *-i-j-*-- g0^2[j] # / \ # g0^2[i] g0[j] local v,ct,i,g0,g1,j,g2,ginf,ANS, a,c,g0a,i1,i2,k,g01; ct := 0; for v in T do g0, g1 := op(v); for i to n+2 do j := g1[i]; if i<>j and g1[j]=i and (m>3 or j>i) then i1 := g0[i]; i2 := g0[i1]; if i1=i or g0[i2]<>i then next fi; c[1] := j; for k to m-1 do a := g0[c[k]]; if a=j or a=i1 or a=i2 then break fi; c[k+1] := a od; if k=m and g0[c[m]]=j then # Found an m-cycle connected to a 3-cycles g0a := subsop(i2 = c[2], c[m] = i1, g0); g01 := SWB([g0a, g1], i1, n); g2 := g01[1][g01[2]]; ginf := NopsDisjCyc(g2,n); if member(ginf,B2) then ct := ct+1; ANS[ct] := UniqueRepresentative(g01,n,[op(g01),g2],[C0,C1,CountOneCycles(ginf)]) fi fi fi od od; userinfo(1, UI(ct,3)); {seq(ANS[i],i=1..ct)} end: UseClean2 := proc(B0,B1,B2) local df, k, j; df := add(`if`(k=2,2,0),k=B1) - add(CountOneCycles(k), k=args) - (nops({op(B1)}) - 1) - (nops({op(B0)}) - 1) - 2 * nops({op(B1)} minus {2,op(B0)}); if df <= 0 then return false fi; j := add(`if`(k>2, k, 0), k=B1) / df; # Increase/Decrease the cutoff 1 to use Clean2 more/less often. evalb(j > 0 and j <= 1) end: Swap02 := proc(B0,B1,B2,N) local s0,s2; if SumOver(2,B2) < SumOver(2,B1) then return true fi; if N > 10 then s0, s2 := SumOver(3,B0), SumOver(3,B2); if s2 < s0 and (s2=0 or UseClean6(B2,B1,N)) then return true elif s0 < s2 and (s0=0 or UseClean6(B0,B1,N)) then return false fi fi; evalb( nops(B0) < nops(B2) ) end: UseClean6 := proc(B0,B1,N) local i,j; if N < 11 then return false fi; i := 2*SumOver(3,B0) + 3*SumOver(2,B1); # These numbers 0.5 0.8 and 1.6 are found by trial and error, it # is not so clear how to optimize them. evalb(i > 0 and i < 0.5 * (N * `if`(max(B1)=2, 0.8, 1.5)-add(`if`(j=1,3,0),j=B1)-add(`if`(j=1,4,`if`(j=2,2,0)),j=B0)) ) end: macro( P = `DecomposeDessin/P`, AttachSet = `DecomposeDessin/AttachSet`, PrincipalSubfields = `DecomposeDessin/PS`, AllSubfields = `DecomposeDessin/AllSubfields`, SubDessin = `DecomposeDessin/SubDessin`, BranchPattern = `DecomposeDessin/BP`, B_to_String = `DecomposeDessin/BtoS` ): # http://www.cs.otago.ac.nz/staffpriv/mike/Papers/GroupTheory/BlocksAlgorithm.pdf # # An Algorithm for Finding the Blocks of a Permutation Group, by M.D. Atkinson # Math Comp 29, No 131, p 911-913, 1975. # P := proc(W, D) local n,e,f,C,a,b,j,g,d,fg,fd; n := nops(D[1]); for e to n do f[e] := e od; for e in W do f[e] := 1 od; C := W; while C<>{} do b := C[1]; C := C minus {b}; a := f[b]; j := 0; while jf[g] then g,d := d,g fi; if f[d] 1 and not member(L, RL) then RN := RN union {e}; RL := RL union {L} fi od; n, RN, RL end: AllSubfields := proc(D) local n, RN, RL, L, i, Q, R, S, e; n, RN, RL[1] := PrincipalSubfields(D); Q := [1$n]; for e do R := map(AttachSet, RL[e]); S := {seq(seq(`if`(member(i,L[2]), NULL, P({i} union L[2], D)), i=RN), L=R)}; RL[e+1] := (S minus {Q}) minus RL[e]; RL[e] := R; if RL[e+1] = {} then break fi od; sort([seq(op(RL[i]), i=1..e)], proc(i,j) nops(i[2])1 then L := [seq([op(i[1..-2]), lhs(i[-1]) = map(convert,rhs(i[-1]), Perm)], i=eval(L))] fi; return A fi; V := AllSubfields(D); if nargs>1 then G := {}: Top := {seq(i,i=1..nops(V))}; Bot := Top; A := NULL; for i to nops(V) do fnd := NULL; B := NULL; for j from i+1 to nops(V) do if V[i][2] minus V[j][2] = {} and not member({}, [seq(k minus V[j][2], k=[fnd])]) then fnd := fnd, V[j][2]; k := nops(V[j][2])/nops(V[i][2]); G := G union {[[F[i],F[j]], k]}; Top := Top minus {j}; Bot := Bot minus {i}; B := cat(B, " = F",j,"(deg ", k,")") fi od; d := SubDessin(V[i][1], D); b := BranchPattern(d); g := (nops(d[1])+2-nops(b[1])-nops(b[2])-nops(b[3]))/2; A := A, [cat("F",i,": ",`if`(g=0,"P1", `if`(g=1,"EllipticCurve", cat("CurveGenus(",g,")"))), "-->P1"), `if`(B=NULL,"indecomposable", cat("F",i,B)), "Degree" = nops(d[1]), cat("BranchPattern = (", op(map(B_to_String,b)[1..-2]), ")"), "Dessin" = d] od; G := G union {seq([[F,F[i]], nops(V[i][2])], i=Top)} union {seq([[F[i],P1], nops(D[1])/nops(V[i][2])], i=Bot)}: if V=[] then G := {[[F, P1], nops(D[1])]} fi; L := [A]; fi; if nargs>2 then Gr := GraphTheory:-DrawNetwork(GraphTheory:-Digraph(G)) fi; if V=[] then "indecomposable" else cat("F",seq(cat(" = F", i, "(deg ", nops(V[i][2]),")"), i=1..nops(V))) fi end: SubDessin := proc(L, D) local S, M, i, g; S := sort([op({op(L)})]); M := subsop(seq(S[i]=i,i=1..nops(S)), L); UniqueRepresentative( [seq(M[L[g[S]]], g=D)] ) end: BranchPattern := proc(D) local i,p; p := D[1]; for i from 2 to nops(D) do p := p[D[i]] od: [seq(NopsDisjCyc(i, nops(p)), i=[op(D), p])] end: B_to_String := proc(B) local S,j,m,t; S := "["; for j in sort([op({op(B)})]) do m := add(`if`(t=j,1,0),t=B); S := S, j, `if`(m>1, cat("$", m), NULL); if j = max(op(B)) then S := S, "]" else S := S, ", " fi od; S, ", " end: save FindDessins, AllInserts,CandidatePairs,CountL,CountOneCycles,\ DecreaseDegreeBy1,DecreaseEach,DecreaseMinMax,DecreaseMult,\ DeleteEntry,DeletePair,InRange,InRange2,Insert,Insert2Loop,\ InsertBridge,InsertLoop,InsertSquare,InsertTriangle,Insertg0deg2,\ InsertsClean,Inverse,MakeMin1Positive,MergeFaces,NopsDisjCyc,\ ReduceF,RoadMap,SWB,ShouldCover,SumOver,UI,UniqueRepresentative,\ ReduceToCleanDessin, ChooseNext, AddN, g0tog1, Merge3m, UseClean2,\ UseClean6, Swap02, P, AttachSet, PrincipalSubfields, AllSubfields,\ DecomposeDessin, SubDessin, BranchPattern, B_to_String, "Combined.m":