HanLibname:="": # HanFill {{{ # HanFill: Han Fill (generating combinatorial objects) # # HAN 04/06/1999, 2005/07/24 23:26 # HAN 2006/06/24 17:23: add ReuseLetter global option # # USAGE # > HanFill("help"); # ########################################################################### # Need : # - `HanAtom/Base/ShowHelpText` in `HanFill/help` # Note : # - quote: always use "", but for boolean comparaison use ``, convert( `+`) # # BUG : # > HanFill("choose", ListOfBiword, 2); ERROR TODO 2008/01/14 09:32 # > Now use ("choose", 54, 2) then subustitue each letter by biword `HanFill/Name`:="HanFill": `HanFill/Option/ReuseLetter`:=false; `HanFill/ListFillObj`:=proc(relamat, lettres) # {{{ # # see help # # HanFill("help"); # local i,res, relamat_V3_, EvalRelation, AjouterUneLettreM; EvalRelation:=proc(a,r,b) local res; res:=evalb(r(a,b)); if not(type(res, boolean)) then res:=true; fi; res; end; # procedure AjouterUneLettreM:=proc(C,R,M) # C, R deux list. Creer une seq des pair [c,r], obtenu par # ajouter une lettre de R dans C. # M list de contraite comme [`>`,1,`>=`,3] local added, isgood,i,j, c,r,res; added:=NULL; res:=NULL; for i to nops(R) do if R[i]<>added then isgood:=true; for j by 2 to nops(M) do if not(EvalRelation(R[i], M[j], C[M[j+1]])) then isgood:=false; break; fi; od; if isgood then added:=R[i]; c:=[op(C), added]; if `HanFill/Option/ReuseLetter` then r:=R; else r:=subsop(i=NULL, R); fi; res:=res, [c,r]; fi; fi; od; res; end; # procedure # continue res:=[AjouterUneLettreM([], lettres, [])]; for i from 1 to nops(relamat) do relamat_V3_:=relamat[i]; res:=map(z->AjouterUneLettreM(z[1], z[2], relamat_V3_), res); od; map(z->z[1], res); end; # Han very old written # }}} `HanFill/PartId2Coor`:=proc(pa, pb) # {{{ local k,ss,dd,i,j,bb,l,res1, res2; l:=nops(pa); bb:=[op(pb), 0$(l-nops(pb))]; dd:=NULL; for i from 1 to l do dd:=dd, pa[i]-bb[i]; od; dd:=[dd]; ss:=NULL; for i from 1 to l do ss:=ss, sum(dd[j],j=i..nops(dd));od; ss:=[ss,0]; res1:=NULL; res2:=NULL; for k to ss[1] do for j from 2 to l do if k>ss[j] then break; fi; od; j:=j-1; i:=bb[j]+k-ss[j+1]; res1:=res1, k=[i,j]; res2:=res2, [i,j]=k; od; [table([res1]), table([res2]), ss[1]]; end; # }}} `HanFill/Part2ConditionMat`:=proc(pa, pb, wLeft, wTop) # {{{ # # a # c b # # (b wLeft c), (b wTop a) local i,id2coor, coor2id, res, M, ma, curid, leftid, topid, cur; res:=`HanFill/PartId2Coor`(pa,pb); id2coor:=res[1]; coor2id:=res[2]; M:=NULL; for curid from 2 to res[3] do ma:=NULL; cur:=id2coor[curid]; leftid:=coor2id[[cur[1]-1, cur[2]]]; topid :=coor2id[[cur[1], cur[2]+1]]; if type(leftid,integer) then ma:=ma, wLeft, leftid; fi; if type(topid, integer) then ma:=ma, wTop, topid; fi; M:=M, [ma]; od; [M]; end; # }}} `HanFill/Line2SkewObj`:=proc(lobj, i2c, im, len) # {{{ local cor,i; for i to nops(lobj) do cor:=i2c[i]; im[len+1-cor[2], cor[1]]:=lobj[i]; od; evalm(im); end; # }}} `HanFill/Compo2BiPart`:=proc(compo) # {{{ local i, r,b; r:=[compo[1]]; b:=NULL; for i from 2 to nops(compo) do if r[1]-1>0 then b:= r[1]-1,b; fi; r:=[ r[1]-1+compo[i], op(r)]; od; [r, [b]]; end; # }}} `HanFill/nextpart`:=proc(p) # {{{ # Partition, NextPartition. Han, 1999.4.14 ######################################################## # Remplacer combinat/nextpart: # mynextpart is 20 times more fast than # maple/combinat/nextpart # # SEE `HanFill/part` # local i,r,n,k,A,L; L:=nops(p); for k from L by -1 while p[k]=1 do od; n:=L-k+1; A:=p[k]-1; r:=irem(n, A); if r=0 then r:=NULL; fi; [op(p[1..k-1]), seq(A, i=0..iquo(n, A)), r]; end; # }}} 2007/12/06 23:02 # ########################################################################### # public: HanFill `HanFill/help`:=proc(topic) #{{{ local tpc; if nargs=0 then tpc:="HanFill" ; else tpc:=topic; fi; if tpc="tab" or tpc="ctab" or tpc="pp" or tpc="cpp" then tpc:="tab"; fi; if tpc<>"HanFill" then tpc:=cat("\`HanFill/", tpc, "\`"); fi; `HanAtom/Base/ShowHelpText`(cat(HanLibDir,`HanFill/Name`, ".mpl"), tpc); end; # }}} `HanFill/tab`:=proc(quoi, lettres, pa, pb) # {{{ # # FUNCTION: HanFill("tab" ,...) - list of skew young tableaux. # HanFill("ctab",...) - list of skew young contre-tableaux. # HanFill("pp" ,...) - list of skew planar partitions. # HanFill("cpp" ,...) - list of skew contre-planar partitions. # # CALLING SEQUENCE: # # The same for "tab", "ctab", "pp", "cpp". # # HanFill("tab", letters, pa) # HanFill("tab", letters, pa, pb) # HanFill("tab", letters, pa, "mat") # HanFill("tab", letters, pa, pb, "mat") # # HanFill("tab", ...) = `HanFill/tab`("tab", ...) # # PARAMETERS: # letters = the list of letters will be filled # letters = "std" means letters= [1,2,...,n] # pa = first partition # pb = second partition, for skew partition = pa/pb # # SYNOPSIS: # - The option "mat" gives the output a planar format like matrix. # - We can have excess letters. # - letters may have repetitions. # # # EXAMPLES: # > HanFill("tab", "std", [3,2],"mat"); # # [2 4 ] [2 5 ] [3 4 ] [3 5 ] # [[ ], [ ], [ ], [ ], # [1 3 5] [1 3 4] [1 2 5] [1 2 4] # # [4 5 ] # [ ]] # [1 2 3] # # > HanFill("pp", [1,1,2,2,3,3,3], [4,4,1],[2]); # # [[1, 3, 2, 2, 1, 3, 3], [1, 3, 3, 2, 1, 3, 2], # # [2, 3, 2, 1, 1, 3, 3], [2, 3, 3, 1, 1, 3, 2], # # [2, 3, 3, 2, 1, 3, 1], [3, 3, 2, 1, 1, 3, 2], # # [3, 3, 2, 2, 1, 3, 1], [3, 3, 3, 1, 1, 2, 2], # # [3, 3, 3, 2, 1, 2, 1]] # # > HanFill("ctab", [1,1,2,2,3,3,3], [4,4,1],[2],"mat"); # # [1 ] [1 ] [2 ] # [ ] [ ] [ ] # [[3 2 2 1], [3 3 2 1], [3 2 1 1], # [ ] [ ] [ ] # [ 3 3] [ 3 2] [ 3 3] # # [2 ] # [ ] # [3 3 1 1]] # [ ] # [ 3 2] # # >`HanFill/Option/ReuseLetter`:=true; # > HanFill("tab", [1,2,3], [3,2],"mat"); # [2 2 0] [2 2 0] [2 2 0] [2 3 0] [2 3 0] # [[ ], [ ], [ ], [ ], [ ], # [1 1 1] [1 1 2] [1 1 3] [1 1 1] [1 1 2] # # [2 3 0] [2 3 0] [2 3 0] [3 3 0] [3 3 0] # [ ], [ ], [ ], [ ], [ ], # [1 1 3] [1 2 2] [1 2 3] [1 1 1] [1 1 2] # # [3 3 0] [3 3 0] [3 3 0] [3 3 0] [3 3 0] # [ ], [ ], [ ], [ ], [ ]] # [1 1 3] [1 2 2] [1 2 3] [2 2 2] [2 2 3] # local PB, Lett, wleft, wtop, ma, res, id2coor, im, i,j; if (nargs=3 or (nargs=4 and not(type(args[4],list)))) then PB:=[]; else PB:=pb; fi; Lett:=lettres; if lettres="std" then Lett:=[seq(i, i=1..((convert(pa, `+`)-convert(PB, `+`))))]; fi; if quoi="tab" then wleft:=`>=`; wtop:= `<`; fi; if quoi="ctab" then wleft:=`<=`; wtop:= `>`; fi; if quoi="pp" then wleft:=`<=`; wtop:= `>=`; fi; if quoi="cpp" then wleft:=`>=`; wtop:= `<=`; fi; ma:=`HanFill/Part2ConditionMat`(pa, PB, wleft, wtop); res:=`HanFill/ListFillObj`(ma, Lett); if (nargs=4 and args[4]= "mat") or (nargs=5 and args[5]= "mat") then id2coor:=`HanFill/PartId2Coor`(pa,PB)[1]; im:=array(1..nops(pa), 1..pa[1]); for i to nops(pa) do for j to pa[1] do im[i,j]:=0; od;od; res:=map(`HanFill/Line2SkewObj`, res, id2coor, im, nops(pa)); fi; res; end; # }}} `HanFill/compo`:=proc(lettres, pa, pb) # {{{ # # - list of skew young tableau of composition form. # - variation of permutation or word of given DES type # # CALLING SEQUENCE: # # HanFill("compo", letters, compo) # HanFill("compo", letters, compo, "mat") # # HanFill("compo", ... ) = `HanFill/compo`(...) # # PARAMETERS: # letters = the list of letters will be filled # letters = "std" means letters= [1,2,...,n] # compo = any list denoting a composition # # SYNOPSIS: # - The option "mat" gives the output a planar format like matrix. # - We can have excess letters. # - letters may have repetitions. # # EXAMPLES: # > HanFill("compo", [1,1,2,3,4], [2,3], "mat"); # # [1 2 ] [1 3 ] [1 4 ] # [[ ], [ ], [ ], # [ 1 3 4] [ 1 2 4] [ 1 2 3] # # [2 3 ] [2 4 ] [3 4 ] # [ ], [ ], [ ]] # [ 1 1 4] [ 1 1 3] [ 1 1 2] # # > HanFill("compo", "std", [2,3]); # [[1, 3, 2, 4, 5], [1, 4, 2, 3, 5], [1, 5, 2, 3, 4], [2, 3, 1, 4, 5], # [2, 4, 1, 3, 5], [2, 5, 1, 3, 4], [3, 4, 1, 2, 5], # [3, 5, 1, 2, 4], [4, 5, 1, 2, 3]] # # > `HanFill/Option/ReuseLetter`:=true; # > HanFill("compo", [1,2], [2,3]); # [[1, 2, 1, 1, 1], [1, 2, 1, 1, 2], [1, 2, 1, 2, 2], [2, 2, 1, 1, 1], # [2, 2, 1, 1, 2], [2, 2, 1, 2, 2]] local res; res:=`HanFill/Compo2BiPart`(pa); if nargs=3 and args[3]= "mat" then RETURN(`HanFill/tab`("tab", lettres, res[1], res[2], "mat")); else RETURN(`HanFill/tab`("tab", lettres, res[1], res[2])); fi; end; #}}} `HanFill/des`:=proc(len, lettres, DS) # {{{ # # - all word of given DS type of len # - a variation of "compo" # # CALLING SEQUENCE: # # HanFill("des", len, letters, DS) # # HanFill("des", ... ) = `HanFill/des`(...) # # PARAMETERS: # len = lenght of permutation or word # letters = the list of letters will be filled, can repete # letters = "std" means letters= [1,2,...,n] # DS = any list denoting a set of desents = DES(sigma) # # SYNOPSIS: # - We can have excess letters. # - letters may have repetitions. # # EXAMPLES: # # > HanFill("des", 5, "std", [2]); # [[1, 3, 2, 4, 5], [1, 4, 2, 3, 5], [1, 5, 2, 3, 4], [2, 3, 1, 4, 5], # [2, 4, 1, 3, 5], [2, 5, 1, 3, 4], [3, 4, 1, 2, 5], # [3, 5, 1, 2, 4], [4, 5, 1, 2, 3]] # # > HanFill("des", 5, [1,1,2,2,2], [2]); # [[1, 2, 1, 2, 2], [2, 2, 1, 1, 2]] # # > `HanFill/Option/ReuseLetter`:=true; # > HanFill("des", 5, [1,2], [2]); # [[1, 2, 1, 1, 1], [1, 2, 1, 1, 2], [1, 2, 1, 2, 2], [2, 2, 1, 1, 1], # [2, 2, 1, 1, 2], [2, 2, 1, 2, 2]] local res,pa,i; if DS=[] then pa:=[len]; else pa:=[DS[1]]; for i from 1 to nops(DS)-1 do pa:=[op(pa), DS[i+1]-DS[i]]; od; pa:=[op(pa), len-DS[nops(DS)]]; fi; res:=`HanFill/Compo2BiPart`(pa); if nargs=3 and args[3]= "mat" then RETURN(`HanFill/tab`("tab", lettres, res[1], res[2], "mat")); else RETURN(`HanFill/tab`("tab", lettres, res[1], res[2])); fi; end; #}}} `HanFill/choose`:=proc(lettres, pa) # {{{ # # - list of young tableau of row form. # # CALLING SEQUENCE: # HanFill("choose", letters, k) # # HanFill("choose", ...)=`HanFill/choose`(...) # # PARAMETERS: # letters = the list of letters will be filled # letters = n means [1,2,...,n] # k = integer denoting the number of boxes in the row # # SYNOPSIS: # - letters may have repetitions. # - "choose" means without order. see "perm" for with order. # # EXAMPLES: # > HanFill("choose", [1,7,8,9],2); # [[1, 7], [1, 8], [1, 9], [7, 8], [7, 9], [8, 9]] # # > HanFill("choose", 3,2); # [[1, 2], [1, 3], [2, 3]] # # > HanFill("choose", [7,8,9],2); # # [[7, 8], [7, 9], [8, 9]] # # > `HanFill/Option/ReuseLetter`:=true; # > HanFill("choose", {7,8,9},2); # # [[7,7], [7, 8], [7, 9], [8,8], [8, 9], [9,9]] # # > HanFill("choose", 3,2); # # [[1,1], [1, 2], [1, 3], [2,2], [2, 3], [3,3]] # # SEE ALSO: HanFill("perm",...), HanFill("rchoose",...) # local i,Lett; Lett:=lettres; if type(lettres, integer) then Lett:=[seq(i, i=1..lettres)]; fi; if pa=0 then RETURN([[]]);fi; # fix BUG, 2005/07/25 00:50 `HanFill/tab`("tab", Lett, [pa]); end; #}}} `HanFill/mchoose`:=proc(lettres, p) # {{{ # # - multi choose, card=multi-nomial(a+b+c;a,b,c) # # CALLING SEQUENCE: # HanFill("mchoose", letters, list) # # HanFill("mchoose", ...)=`HanFill/mchoose`(...) # # PARAMETERS: # letters = the list of letters will be filled # letters = n means [1,2,...,n] # p = list such that sum(p)=nops(letters) # # SYNOPSIS: # # EXAMPLES: # > HanFill("mchoose", 6, [3,1,2]); # [[1,1], [1, 2], [1, 3], [2,2], [2, 3], [3,3]] # # SEE ALSO: HanFill("perm",...), HanFill("rchoose",...), HanFill("choose",...) # local i,S, z,r, k, R, SS,u; S:=lettres; if type(lettres, integer) then S:=[seq(i, i=1..lettres)]; fi; if nops(p)=1 then RETURN([[S]]); fi; R:=[]; r:=HanFill("choose", S, p[1]); for k in r do SS:=[op({op(S)} minus {op(k)})]; u:=procname(SS, p[2..nops(p)]); R:=[op(R), op(map(z->[k, op(z)], u))]; od; R; end; #}}} `HanFill/part`:=proc(n) # {{{ # # - list of partitions of n # a partition is (p1 >= p2 >= p3 ... >= pl >0) # # CALLING SEQUENCE: # HanFill("part", n) # # HanFill("perm", ...)=`HanFill/perm`(...) # # PARAMETERS: # n = integer, the number of boxes # # SYNOPSIS: # # EXAMPLES: # > HanFill("part", 5); # # [[5], [4, 1], [3, 2], [3, 1, 1], [2, 2, 1], [2, 1, 1, 1], [1, 1, 1, 1, 1]] # # REMARK : # # Here we rewrite nextpart(p). We could use also the META enumerate method # in this file, like `HanFill/perm`. # local r,P; P:=[n]; r:=[P]; while P[1]>1 do P:=`HanFill/nextpart`(P): r:=[op(r),P]; od: r; end; # }}} `HanFill/perm`:=proc(lettres, pa, pb) # {{{ # # - list of permutations. i.e., skew young tableau of independent boxes. # # CALLING SEQUENCE: # HanFill("perm", letters) # HanFill("perm", letters, k) # # HanFill("perm", ...)=`HanFill/perm`(...) # # PARAMETERS: # letters = the list of letters will be filled # letters = n means [1,2,...,n] # k = integer, the number of boxes # # SYNOPSIS: # - letters may have repetitions. # - "perm" means with order. see "choose" for without order. # # EXAMPLES: # > HanFill("perm", [7,8,9],2); # # [[7, 8], [7, 9], [8, 7], [8, 9], [9, 7], [9, 8]] # # > HanFill("perm", 3,2); # # [[1, 2], [1, 3], [2, 1], [2, 3], [3, 1], [3, 2]] # # > HanFill("perm", ["a", "b"]); # # [[a, b], [b, a]] # # > HanFill("perm", 3); # # [[1, 2, 3], [1, 3, 2], [2, 1, 3], [2, 3, 1], [3, 1, 2], [3, 2, 1]] # # > `HanFill/Option/ReuseLetter`:=true; # > # then will be the same as `HanFill/all` # > HanFill("perm", [7,8,9],2); # [[7, 7], [7, 8], [7, 9], [8, 7], [8, 8], [8, 9], [9, 7], [9, 8], [9, 9]] # # > HanFill("perm", 3); # [[1,1,1],[1,1,2],[1,1,3],[1,2,1],[1,2,2],[1,2,3],[1,3,1], # [1,3,2],[1,3,3],[2,1,1],[2,1,2],[2,1,3],[2,2,1], # [2,2,2],[2,2,3],[2,3,1],[2,3,2],[2,3,3],[3,1,1], # [3,1,2],[3,1,3],[3,2,1],[3,2,2],[3,2,3],[3,3,1], # [3,3,2],[3,3,3]] # local Lett,j,i,ma; Lett:=lettres; if type(lettres, integer) then Lett:=[seq(i, i=1..lettres)]; fi; if nargs=1 then j:=nops(Lett); else j:=pa; fi; if j=0 then RETURN([[]]);fi; # fix BUG, 2005/07/25 00:50 ma:=NULL; for i from 2 to j do ma:=ma, []; od; `HanFill`([ma], Lett); end; # }}} # add more (not initial idea of Fill) 2005/12/31 10:26 `HanFill/rchoose`:=proc(lettres, pa) # {{{ # # - list of young tableau of row form, filled by lettres, each letter # can be occured more than one times. (can have repetition) # # CALLING SEQUENCE: # HanFill("rchoose", letters, k) # # HanFill("rchoose", ...)=`HanFill/rchoose`(...) # # PARAMETERS: # letters = the set of letters will be filled # letters = n means [1,2,...,n] # k = integer denoting the number of boxes in the row # # SYNOPSIS: # - letters is a set (must be no repetitions). # - "choose" means without order. # # EXAMPLES: # > HanFill("choose", [7,8,9],2); # # [[7, 8], [7, 9], [8, 9]] # # > HanFill("rchoose", {7,8,9},2); # # [[7,7], [7, 8], [7, 9], [8,8], [8, 9], [9,9]] # # > HanFill("rchoose", 3,2); # # [[1,1], [1, 2], [1, 3], [2,2], [2, 3], [3,3]] # # SEE ALSO: HanFill("perm",...), HanFill("choose",...) # local saveopt, res; global `HanFill/Option/ReuseLetter`; saveopt:=`HanFill/Option/ReuseLetter`; `HanFill/Option/ReuseLetter`:=true; res:=`HanFill/choose`(args[1..-1]); `HanFill/Option/ReuseLetter`:=saveopt; res; end; #}}} `HanFill/subset`:=proc(lettres) # {{{ # # - all subset of a set total # # CALLING SEQUENCE: # HanFill("subset", letters) # # HanFill("subset", ...)=`HanFill/subset`(...) # # PARAMETERS: # letters = the set total # letters = n means {1,2,...,n} # # SYNOPSIS: # - letters is a set {} (not a list []). # # EXAMPLES: # # > HanFill("subset", {7,8,9}); # # [[], [7], [8], [9], [7, 8], [7, 9], [8, 9], [7, 8, 9]] # # > HanFill("subset", 3); # # [[], [1], [2], [3], [1, 2], [1, 3], [2, 3], [1, 2, 3]] # # local L, i,del, N, k, A; if type(lettres, set) then N:=nops(lettres); fi; if type(lettres, list) then print("error: subset param need set but not list "); fi; if type(lettres, integer) then N:=lettres; fi; L:=[]; for i from 0 to N do L:=[op(L), op(HanFill("choose", lettres, i))]; od; L; end; #}}} `HanFill/all`:=proc(lettres, len) # {{{ # # -1. all(lettres, len): all words generated by lettres of len # all(lettres, len, Cond) # # -2. all(lettres_list): all words generated by lettres_list # all(lettres_list, Cond) # # Cond: Check at len i (i=1..len), if false, stop generation with this # left factor; continue by using other left factors # # Cond(z) : z is a list of integer # # CALLING SEQUENCE: # HanFill("all", letters, len) # HanFill("all", letters, len, Condition) # HanFill("all", letters_list) # HanFill("all", letters_list, Condition) # # HanFill("all", ...)=`HanFill/all`(...) # # PARAMETERS 1: # letters = the set total # letters = n means {1,2,...,n} # len = number means the length of word # # PARAMETERS 2: # letters_list = list of letters [S1,S2,...,Slen], # that means word [x1,x2,...,xlen] with x1 in S1, x2 in S2,... # S1,S2,... are set # # SYNOPSIS: # - letters is a set {} (not a list []). # # EXAMPLES: # # > HanFill("all", {7,8},2); # # [[7,7], [7, 8], [8,7], [8, 8]] # # > HanFill("all", 2,3); # # [[1,1,1],[1,1,2],[1,2,1],[1,2,2],[2,1,1],[2,1,2],[2,2,1],[2,2,2]] # # > HanFill("all", 2,3, z-> evalb(convert(z,`+`)<=4)); # # [[1, 1, 1], [1, 1, 2], [1, 2, 1], [2, 1, 1]] # # > HanFill("all", [{1,8},{7,8,9}]); # # [[1, 7], [1, 8], [1, 9], [8, 7], [8, 8], [8, 9]] # # SEE ALSO # "all"({0,1},n) is equivalent of "subset"(n) # # > HanFill("all", {0,1}, 3); # > HanFill("subset", 3); # local L, i,del, N, k, A, a,G,j,x, LEN, Cond, r; a:=NULL; Cond:=NULL; if type(lettres, set) then a:=lettres; fi; if type(lettres, integer) then a:={seq(i,i=1..lettres)}; fi; if a<>NULL then LEN:=len; if nargs=3 then Cond:=args[3]; fi; fi; if type(lettres, list) then A:=lettres; LEN:=nops(A); if nargs=2 then Cond:=args[2]; fi; fi; L:=[[]]; for x from 1 to LEN do if type(lettres, list) then a:=A[x]; fi; G:=[]; for j in L do for i in a do r:=[op(j),i] ; if Cond=NULL or Cond(r) then G:=[op(G), [op(j),i]] ; fi; od; od; L:=G; od; L; end; #}}} `HanFill/sudoku`:=proc(AS, RS) # {{{ # # - find mini-sudoku problem solution list # # AS : list of set [S1,S2,...,Sn] # will generate some word [x1,x2,...,xn] with x1 in S1, x2 in S2 # like HanFill("all", AS), but with following restriction # # RS : restriction relations list [R2,R3,...,Rn] # that means that the word [x1,x2,...,xn] satisfies # xi != xj for j HanFill("sudoku", [{2,7}, {2,5}, {2,7}, {5,7}], [{1}, {1}, {2,3}] ); # that means list of all words [x1,x2,x3,x4] such that # x1 in {2,7} # x2 in {2,5} # x3 in {2,7} # x4 in {5,7} # x2 != x1 # x3 != x1 # x4 != x2, x4!=x3 # # [[7, 2, 2, 5], [7, 2, 2, 7], [7, 5, 2, 7]] # local R,i,k,r,step1; step1:=proc(L, AS, NS) # {{{ # L=list of vector of same length n = [ [1,2,3],[1,3,4],...] (n=3) # AS= add set ={1,3,7,8} # NS=subset of [n] # # This program add one number x in AS to the end of each vector p in L, # if x is not equal to p[i] for each i in NS # # > L:=[ [1,2,3], [1,3,4]]; AS:={1,3,7}; NS:={2,3}; # > MakeList_1(L,AS,NS); # > [ [1,2,3,1], [1,3,4,1], [1,2,3,7], [1,3,4,7]] # because [1,2,3,3] (x=p3), [1,3,4,3] (x=p2) are not valid. local p,n,i,x, R,B; if L=[] then return []; fi; n:=nops(L[1]); R:=[]; for x in AS do for p in L do B:=map(z->p[z], NS); if not(member(x , B)) then R:=[op(R), [op(p), x]]; fi; od; od; R; end; # }}} R:=[op(map(z->[z], AS[1]))]; k:=nops(AS); for i from 2 to k do R:=step1(R, AS[i], RS[i-1]); od; R; end; # }}} `HanFill/shuffle`:=proc(a, b) # {{{ # # - shuffle of two words # # CALLING SEQUENCE: # HanFill("shuf", a, b) # # HanFill("shuf", ...)=`HanFill/shuffle`(...) # # PARAMETERS: # a = word # b = word # return = list of words # # # EXAMPLES: # > HanFill("shuf", [x,y],[1,2]); # # [[x,y,1,2],[x,1,y,2],[x,1,2,y],[1,x,y,2],[1,x,2,y],[1,2,x,y]] # # SEE ALSO: HanFill("choose",...) # local na,nb,ch,p,r,id, q; r:=[]; na:=nops(a); nb:=nops(b); id:={seq(i,i=1..na+nb)}; ch:=`HanFill/choose`(na+nb, na); for p in ch do q:= sort([op(id minus {op(p)})]) ; p:=seq([p[i], a[i]], i=1..na); q:=seq([q[i], b[i]], i=1..nb); sort([p,q], (x,y)-> x[1]z[2], %); r:=[op(r), %]; od; r; end; #}}} `HanFill/avoidfactor`:=proc(SL, AF, Deg) option remember; # {{{ # # - fill with letters in SL, avoid factor in AF, of lenght Deg # # - if all avoid factors have length 2, AF can be a boolean function: # [a,b] in AF means AF(a,b)=true # # CALLING SEQUENCE: # # `HanFill/avoidfactor`(SL, AF, Deg) # `HanFill/avoidfactor`(SL, AF, Deg, SelectProc) # # HanFill("-factor", SL, AF, Deg) # # PARAMETERS: # SL = the list of letters # AF = the list of all avoid factors, each factor is a word # AF = boolean function, AF(a,b)=true means [a,b] in AF for list # Deg = the length of a good word # SelectProc = (option) Keep only w such that SelectProc(w)=true # return = list of good word # # EXAMPLES: # > AF:= [[x,y],[z,x],[y,y],[x,x],[x,z,z]]; # > `HanFill/avoidfactor`([x,y,z], AF, 4); nops(%); # # [[x, z, y, x], [y, z, y, x], [z, z, y, x], [y, x, z, y], [z, y, z, y], # [y, z, z, y], [z, z, z, y], [z, y, x, z], [x, z, y, z], [y, z, y, z], # [z, z, y, z], [z, y, z, z], [y, z, z, z], [z, z, z, z]] # # 14 # # > `HanFill/avoidfactor`( [x,y,z], AF, 4, p->p[2]=y); # # [[z, y, z, y], [z, y, x, z], [z, y, z, z]] # # > sp:=proc(a,b) if a=x or b=y or (a=z and b=x) then RETURN(true);fi;false;end; # > `HanFill/avoidfactor`([x,y,z], sp, 3); # # [[y, z, z], [z, z, z]] # # SEE ALSO: # HanFill("help", "onlyfactor"); local R,K, a,b,c, s, ok, withsel, sel; if nargs=4 then withsel:=true; sel:=args[4];else withsel:=false; fi; if Deg=1 then RETURN(map(z->[z], SL)); fi; K:=procname(SL,AF,Deg-1); R:=[]; for a in SL do for b in K do c:=[op(b), a]; if type(AF, list) then for s in AF do ok:=true; if c[nops(c)-nops(s)+1 ..nops(c)]=s then ok:=false; break; fi; od; else ok:= not(AF(b[nops(b)], a)); fi; if ok then R:=[op(R), c]; fi; od; od; if withsel then R:=map(z-> if sel(z) then z fi, R);fi; R; end; # 2007/09/10 09:10 # }}} `HanFill/onlyfactor`:=proc(SL, AF, Deg) option remember; # {{{ # # - fill with letters in SL, with only factor in AF, of lenght Deg # # - Note: all only factors have length 2, AF can be a boolean function: # [a,b] in AF means AF(a,b)=true # # It can be seen as an automat to generate words # # CALLING SEQUENCE: # # `HanFill/onlyfactor`(SL, AF, Deg) # `HanFill/onlyfactor`(SL, AF, Deg, SelectProc) # # HanFill("factor", SL, AF, Deg) # # PARAMETERS: # SL = the list of letters # AF = the list of all only factors (of lenght=2), each factor is a word # AF = boolean function, AF(a,b)=true means [a,b] in AF for list # Deg = the length of a good word # SelectProc = (option) Keep only w such that SelectProc(w)=true # return = list of good word # # EXAMPLES: # > AF:= [[x,y],[z,x],[y,y],[x,x]]; # > `HanFill/onlyfactor`([x,y,z], AF, 4); # # [[x, x, x, x], [z, x, x, x], [x, x, x, y], [z, x, x, y], # [x, x, y, y], [z, x, y, y], [x, y, y, y], [y, y, y, y]] # # > `HanFill/onlyfactor`([x,y,z], AF, 4, p->p[2]=y); # # [[x, y, y, y], [y, y, y, y]] # # > sp:=proc(a,b) if a=x or b=y or (a=z and b=x) then RETURN(true);fi;false;end; # > `HanFill/onlyfactor`([x,y,z], sp, 3, p->p[2]=x); # # [[x, x, x], [z, x, x], [x, x, y], [z, x, y], [x, x, z], [z, x, z]] # # SEE ALSO: # HanFill("help", "avoidfactor"); local R,K, a,b,c, s, ok, withsel, sel; if nargs=4 then withsel:=true; sel:=args[4];else withsel:=false; fi; if Deg=1 then RETURN(map(z->[z], SL)); fi; K:=procname(SL,AF,Deg-1); R:=[]; for a in SL do for b in K do c:=[op(b), a]; if type(AF, list) then for s in AF do ok:=false; if c[nops(c)-nops(s)+1 ..nops(c)]=s then ok:=true; break; fi; od; else ok:= AF(b[nops(b)], a); fi; if ok then R:=[op(R), c]; fi; od; od; if withsel then R:=map(z-> if sel(z) then z fi, R);fi; R; end; # 2007/09/10 09:10 # }}} `HanFill/concat`:=proc(SL) # {{{ # SL : [ W1, W2, ..., Wk] where Wi is a list of words # output: all words of form w1w2...wk with (wi \in Wi) # # Example # > `HanFill/concat`([[[x,x],[y]], [[1],[2]], [3]]); # [[x, x, 1, 3], [x, x, 2, 3], [y, 1, 3], [y, 2, 3]] # # SEE ALSO: HanFill/prod # SEE ALSO: HanFill/all (for product cartesien, or concat for list of letters) local R, do2; do2:=proc(A,B) # A, B are list of words local a,b,r; r:=[]; for a in A do for b in B do r:=[op(r), [op(a), op(b)]]; od; od; r; end; if nops(SL)=2 then RETURN (do2(SL[1], SL[2])); fi; do2(SL[1], procname(SL[2..nops(SL)])); end; # Han 2007/09/12 10:59 # }}} `HanFill/prod`:=proc(AlphaSet, DigitSet) # {{{ # product of set of words of the same length (i.e.: add index) # # > `HanFill/prod`( [[x,y],[z,x]], [[1,2],[2,2]]); # [[x1,y2], [x2,y2], [z1,x2], [z2,x2]] # # SEE ALSO: HanFill/concat # SEE ALSO: HanFill/all (for product cartesien) local R, a,d,r,i; R:=[]; for a in AlphaSet do for d in DigitSet do r:=[]; for i from 1 to nops(a) do r:=[op(r), cat(a[i], d[i])]; od; R:=[op(R), r]; od; od; R; end; # Han 2007/09/12 11:32 # }}} `HanFill/proc`:=proc(MselProc, lettres, Len) # {{{ # # Fill by Proc. May replace the very big general procedure HanFill/ListFillObj # it use Selection Proc # # EXAMPLES # # alternating permutation # > selp:=proc(C,r) # C=(c1, c2, ..., cn) obj already generated, try add r. # local n; # n:=nops(C); # if n=0 then RETURN(true); fi; # if type(n, even) then RETURN(evalb(C[n]> r));fi; # evalb(evalb(C[n]< r)); # end; # > `HanFill/proc`(selp, [1,2,3,4,5,6], 6); # # SEE ALSO # > `HanFill/ListFillObj` # local i,res, AjouterUneLettreM; AjouterUneLettreM:=proc(C,R,MselProc) # C, R deux list. Creer une seq des pair [C,r], obtenu par # ajouter une lettre de R dans C. # MselProc(C,r)=true means good obj, add [C,r] local added, i,j, c,r,res; added:=NULL; res:=NULL; for i to nops(R) do if R[i]<>added then if MselProc(C, R[i]) then added:=R[i]; c:=[op(C), added]; if `HanFill/Option/ReuseLetter` then r:=R; else r:=subsop(i=NULL, R); fi; res:=res, [c,r]; fi; fi; od; res; end; # procedure # continue res:=[AjouterUneLettreM([], lettres, MselProc)]; for i from 1 to Len-1 do res:=map(z->AjouterUneLettreM(z[1], z[2], MselProc), res); od; map(z->z[1], res); end; # Han 2007/09/12 19:46 # }}} `HanFill/ckchoose`:=proc(L,k, CheckGood) # {{{ # -------------------------------- # - Choose and check remain letters by check proc # # Final GOAL: # # Given L list of letters # Given k integer # Generat all w = [u1, u2, ..., uk] in L^k # And there is some condition for these w: # CheckGood(u1, u2) must be true, and also u1<>u2 # # # EXAMPLE # Choose 3 elements from L=[1..7] such that all elements have same parity # # > gd:=proc(a,b) evalb(type(a,even)=type(b,even)); end; # > `HanFill/ckchoose`([seq(i,i=1..7)], 3, gd); # [[1, 3, 5], [1, 3, 7], [1, 5, 7], [2, 4, 6], [3, 5, 7]] local step1,i, UpdateL; # # Iteration Procedure: (step1) # # For some k we already generat all w. Next we do new_k=k+1. # The partial result until k are stoked in RES. It not only contains all w, # but also, for each word w, a different TodoL which compatible with w. # # WL=[ [w, TodoL], [w, TodoL], .... ] # # EXAMPLE # Choose 3 elements from L=[1..7] such that all elements have same parity # # > gd:=proc(a,b) evalb(type(a,even)=type(b,even)); end; # > [[[], [seq(i,i=1..7)]]]; # > step1(%, gd); step1(%, gd); step1(%, gd); # > map(p->p[1], %); # # [[1, 3, 5], [1, 3, 7], [1, 5, 7], [2, 4, 6], [3, 5, 7]] # UpdateL:=proc(Deja, Todo, CheckGood) # Deja = list of letters # Todo = list of letters # A good letter x in Todo is such that CheckGood(x,y)=true for every y in Deja. # # return : all good letter local g,r,x,y; r:=[]; for x in Todo do g:=true; for y in Deja do if CheckGood(x,y)=false then g:=false; break; fi; od; if g then r:=[op(r), x]; fi; od; r; end; # UpdateL step1:=proc(WL, CheckGood) local i,j, w, tL, Out, h, ntL,R; Out:=[]; for R in WL do w:=R[1]; tL:=R[2]; if nops(tL)>=1 then for i from 1 to nops( tL) do h:=[op(w), tL[i]]; ntL:=UpdateL([tL[i]], tL[i+1..nops(tL)], CheckGood); Out:=[op(Out), [h, ntL]]; od; fi; od; Out; end; # step1 [[[], L]]; for i from 1 to k do step1(%, CheckGood); od; map(p->p[1], %); end; # Han 2007/09/13 10:04 # }}} # dispatcher HanFill:=proc(quoi, lettres, pa, pb) # {{{ # # FUNCTION: HanFill(...) - list of linear objets obtained by filling some boxes # using given letters. Young tableau is an example of such objets. # # CALLING SEQUENCE: # # HanFill(relation, letters) # # HanFill("help") # HanFill("help", "tab") # fill young tableau # HanFill("help", "ctab") # fill contre tableau # HanFill("help", "pp") # fill planar partition # HanFill("help", "cpp") # fill contre planar partition # HanFill("help", "compo") # fill composition (skew partition) # HanFill("help", "des") # all word of given DES type # HanFill("help", "choose") # fill choose (row tableau) # HanFill("help", "mchoose") # multi choose (multi binomial) # HanFill("help", "shuffle") # shuffle of two words # HanFill("help", "part") # all partitions of n # HanFill("help", "perm") # fill permutaion (independant boxes) # HanFill("help", "rchoose") # fill choose (row tableau) with repetition # HanFill("help", "subset") # all subset of a set # HanFill("help", "all") # all word generated by lettres # HanFill("help", "sudoku") # all word generated by lettres, with restriction # HanFill("help", "onlyfactor") # generated by lettres, with only factors # HanFill("help", "avoidfactor") # generated by lettres, avoid factors # HanFill("help", "concat") # concatenate words # HanFill("help", "prod") # product of words of same length (add index) # HanFill("help", "proc") # very general fill, using select proc # HanFill("help", "ckchoose") # choose and check remain letter by check proc # # these help give many others calling sequences. # # PARAMETERS: # # relation = a list describing the objets # letters = the list of letters will be filled, # letters = "std" means letters= [1,2,...,n] # # OPTION: # # `HanFill/Option/ReuseLetter`= true : re-use letter (with repetition) # # SYNOPSIS: # - If we need fill n boxes, relation is a list of (n-1) elements. The k-th # element is a list describing the condition for filling the (k+1)-th box, # in the format [`>`, i, `<=`, j ,...], it means that the (k+1)-th box must # be filled by an integer bigger than the integer in i-th box, small or equal # to the integer in j-th box. # # - We can have excess letters. # # - letters may have repetitions. # # EXAMPLES: fill 4 boxes: # > HanFill([[`>`, 1], [`>`,1], [`>`,1,`>=`,3]], [1,2,3,3]); # [[1, 2, 3, 3], [1, 3, 2, 3]] # # > HanFill([[`>`, 1], [`>`,1], [`>`,1,`>=`,3]], [1,2,3]); # [] # (because fill 4 boxes with only 3 values) # # > HanFill([[`>`, 1], [`>`,1], [`>`,1,`>=`,3]], "std"); # [[1, 2, 3, 4], [1, 3, 2, 4], [1, 4, 2, 3]] # # > `HanFill/Option/ReuseLetter`:=true; # # > HanFill([[`>`, 1], [`>`,1], [`>`,1,`>=`,3]], [1,2,3,3]); # [[1, 2, 2, 2], [1, 2, 2, 3], [1, 2, 3, 3], [1, 3, 2, 2], [1, 3, 2, 3], # [1, 3, 3, 3], [2, 3, 3, 3]] # # > HanFill([[`>`, 1], [`>`,1], [`>`,1,`>=`,3]], [1,2,3]); # [[1, 2, 2, 2], [1, 2, 2, 3], [1, 2, 3, 3], [1, 3, 2, 2], [1, 3, 2, 3], # [1, 3, 3, 3], [2, 3, 3, 3]] # # > HanFill([[`>`, 1], [`>`,1], [`>`,1,`>=`,3]], "std"); # [[1, 2, 2, 2], [1, 2, 2, 3], [1, 2, 2, 4], [1, 2, 3, 3], [1, 2, 3, 4], # [1, 2, 4, 4], [1, 3, 2, 2], [1, 3, 2, 3], [1, 3, 2, 4], [1, 3, 3, 3], # [1, 3, 3, 4], [1, 3, 4, 4], [1, 4, 2, 2], [1, 4, 2, 3], [1, 4, 2, 4], # [1, 4, 3, 3], [1, 4, 3, 4], [1, 4, 4, 4], [2, 3, 3, 3], [2, 3, 3, 4], # [2, 3, 4, 4], [2, 4, 3, 3], [2, 4, 3, 4], [2, 4, 4, 4], [3, 4, 4, 4]] # local Lett, PB, i,j,ma, wleft, wtop,res, im, id2coor; if quoi="help" then RETURN(`HanFill/help`(args[2..-1])); fi; Lett:=lettres; # (relation_mat, lettres) if nargs=2 and type(quoi, list) then if lettres="std" then Lett:=[seq(i, i=1..nops(quoi)+1)]; fi; RETURN(`HanFill/ListFillObj`(quoi, Lett)); fi; if (quoi="tab" or quoi="ctab" or quoi="pp" or quoi="cpp") then RETURN(`HanFill/tab`(args)); fi; if quoi="compo" then RETURN(`HanFill/compo`(args[2..-1])); fi; if quoi="des" then RETURN(`HanFill/des`(args[2..-1])); fi; if quoi="choose" then RETURN(`HanFill/choose`(args[2..-1])); fi; if quoi="mchoose" then RETURN(`HanFill/mchoose`(args[2..-1])); fi; if quoi="shuf" then RETURN(`HanFill/shuffle`(args[2..-1])); fi; if quoi="part" then RETURN(`HanFill/part`(args[2..-1])); fi; if quoi="perm" then RETURN(`HanFill/perm`(args[2..-1])); fi; if quoi="rchoose" then RETURN(`HanFill/rchoose`(args[2..-1])); fi; if quoi="subset" then RETURN(`HanFill/subset`(args[2..-1])); fi; if quoi="all" then RETURN(`HanFill/all`(args[2..-1])); fi; if quoi="sudoku" then RETURN(`HanFill/sudoku`(args[2..-1])); fi; if quoi="factor" then RETURN(`HanFill/onlyfactor`(args[2..-1])); fi; if quoi="-factor" then RETURN(`HanFill/avoidfactor`(args[2..-1])); fi; if quoi="concat" then RETURN(`HanFill/concat`(args[2..-1])); fi; if quoi="prod" then RETURN(`HanFill/prod`(args[2..-1])); fi; if quoi="proc" then RETURN(`HanFill/proc`(args[2..-1])); fi; if quoi="ckchoose" then RETURN(`HanFill/ckchoose`(args[2..-1])); fi; end; # }}} # ########################################################################### HanLibname:=`HanFill/Name`, HanLibname: # }}} # HanTab {{{ #============================================================================= # MatAdm: Enumeration of all admissible matrix of KKR # Guo-Niu Han, # - 2006/04/11 07:57 AdmMat # - 2006/04/13 09:36 Kostka, change matrix format #============================================================================= # Usage: # # > `HanTab/Kiri/MatAdm`(ev,fm) ; # # Input format: # # ev and fm are two partitions # ev = transpose of evaluation of tableau, ev=[n] means standard tableau # fm = form of tableau # # Output format: # # output = list of admissible matrix m # format of m = list of rows (standard) # # Example 1: list of all admissible matrices # # > `HanTab/Kiri/MatAdm`([6],[3,2,1]): # forme [3,2,1], standard tableau [6] # > map(evalm, %); # # 6 6 6 # 2 3 and 3 # 1 1 1 # # Example 2: Kostka polynomial # # > `HanTab/Kiri/Kostka`([6],[3,2,1]): factor(%); # q^4*(q+1)^3*(q^2+1)*(q^2-q+1) # # Example 3: number of standard Young tableau, verification and benchmark # # > `HanTab/Kiri/Kostka`([15],[5,4,3,2,1]): simplify(%): subs(q=1,%); # 292864 # (4.66 sec in PIV 3.0Ghz?) # > 15! /(3^4*5^3*7^2*9); # verification by hook formula # 292864 # # REFERENCE: # [SLC/B31a] #============================================================================= `HanTab/Name` := "HanTab": # 0. Util `HanTab/Util/Format/Array2Mat`:=proc(atab) # {{{ # - convert Ytab as array to Ytab as matrix # # Input format: # # atab = [[1, 1, 1, 1, 2, 3, 3, 5], [2, 2, 2, 3, 4, 5], [3, 4, 7], [6]]; # # Output format: # # atab = [ [6, 0, 0, 0, 0, 0, 0, 0], # [3, 4, 7, 0, 0, 0, 0, 0], # [2, 2, 2, 3, 4, 5, 0, 0], # [1, 1, 1, 1, 2, 3, 3, 5] ]; # # # # Example: # > atab := [[1, 1, 1, 1, 2, 3, 3, 5], [2, 2, 2, 3, 4, 5], [3, 4, 7], [6]]; # > `HanTab/Util/Format/Array2Mat`(atab); # > evalm(%); local i,L,n,m,j; n:=nops(atab[1]); L:=[seq(atab[nops(atab)-i+1] , i=1..nops(atab))]; for i from 1 to nops(L) do L[i]:=[op(L[i]), seq(0, k=1..n-nops(L[i]))]; od; L; end; # Han 2007/07/17 01:02 # }}} # 1. Enumerating all admissible matrix `HanTab/Kiri/MatClean`:=proc(m) # {{{ # # - Clean a matrix. That means # (1) remove the rightmost colon if it is the same as the 2th-rightmost colon; # repeat this operation; # (2) remove the bottom row if it is [0,0,...,0]; # repeat this operation. # # format of matrix m = list of colons (non -standard!) # # EXAMPLE: # # > A:=[3,2,1,1,0,0]; B:=[8,4,1,0,0,0]; # > `HanTab/Kiri/MatClean`([A,A,B,B,B]); # [[3, 2, 1, 1], [3, 2, 1, 1], [8, 4, 1, 0]] # local len,i,r,R; r:=map(z->`HanWord/LRemove0`(z),m); len:=max(op(map(z->nops(z), r))); r:=map(z->`HanWord/LAdd0`(z,len),r); R:=[]; for i from nops(r) to 2 by -1 do if r[i]<>r[i-1] then break;fi; od; r[1..i]; end; # 2006/04/12 00:00 # }}} `HanTab/Kiri/MatTr`:=proc(m) # {{{ # # - Transpose matrix, switch colons and rows , useful for print matrix # # EXAMPLE: # # > `HanTab/Kiri/MatTr`([[6,2,1],[6,3,1]]); # [[6, 6], [2, 3], [1, 1]] # > `HanTab/Kiri/MatTr`(%); # [[6,2,1],[6,3,1]] # local i,j,nc,nr; nc:=nops(m); nr:=nops(m[1]); [seq([seq(m[i][j], i=1..nc)], j=1..nr)]; end; # 2006/04/12 00:00 # }}} `HanTab/Kiri/MakeColsList`:=proc(n,Len) option remember; # {{{ # # - Make possible colon list for a given integer; add 0 for lenght=Len; # a possible colon is a colon which can be in the admissible matrix. # we just verify some inequalities. # # EXAMPLE: # > `HanTab/Kiri/MakeColsList`(4,4); # [[4, 0, 0, 0], [4, 1, 0, 0], [4, 2, 0, 0], [4, 2, 1, 0], [4, 3, 2, 1]] # local R,k,r,RR,a,na; R:=[[n]]; for k from 1 to n-1 do r:=`HanTab/Kiri/MakeColsList`(k,0); R:=[op(R), op(map(z-> [n,op(z)], r))] od; RR:=[]; for k from 1 to nops(R) do a:=R[k]; na:=nops(a); if (na>=3 and a[1]+a[3]>=2*a[2]) or ( na=2 and a[1]>=2*a[2]) or na=1 then if Len>0 then RR:=[op(RR), `HanWord/LAdd0`(a,Len) ]; else RR:=[op(RR), a ]; fi; fi; od; RR; end; #Han 2006/04/12 00:11 # }}} `HanTab/Kiri/MatAdm_`:=proc(ev, fm) # {{{ # - make admissible matrix list, but for intern use only. # (don't try to mix MatAdm_ and MatAdm!) # # PARAMETERS: # ev = partition, cumul sum of the transpose of the evaluation # fm = partition, cumul sum of the form # for the direction of the cumul sum, see example. # output = list of admissible matrix, but need to MatClean # # format of matrix = list of colons (non-standard!) # # EXAMPLE: tableau(evaluation^tr= [11,2], form=[8,3,2]), take # > `HanTab/Kiri/MatAdm_`([11,13,13,13,13,13,13], [13,5,2]); # #output very long list, first composant has many 13! # local R,M,m,c,i,k,RR,Len,a,na,keep,j; Len:=ev[nops(ev)]; R:=[]; if nops(ev)=1 then RETURN([[`HanWord/LAdd0`(fm,Len)]]); fi; m:=`HanTab/Kiri/MatAdm_`(ev[2..nops(ev)],fm); c:=`HanTab/Kiri/MakeColsList`(ev[1],Len); for i from 1 to nops(c) do R:=[op(R), op(map(z-> [c[i],op(z)], m))]; od; RR:=[]; for k from 1 to nops(R) do a:=R[k]; na:=nops(a); keep:=true; if na>=2 then for j from 1 to Len do if 2*a[1][j]a[2][j] then keep:=false;break;fi; od; fi; if na>=3 and keep=true then for j from 1 to Len do if 2*a[2][j]a[2][j] then keep:=false;break;fi; od; fi; if keep=true then RR:=[op(RR), a ]; fi; od; RR; end; # Han 2006/04/12 00:18 # }}} `HanTab/Kiri/MatAdm`:=proc(ev,fm) # {{{ # Input format: # # ev and fm are two partitions # ev = transpose of evaluation of tableau, ev=[n] means standard tableau # fm = form of tableau # # Output format: # # output = list of admissible matrix m # format of m = list of rows # # Example: # # > `HanTab/Kiri/MatAdm`([6],[3,2,1]); # forme [3,2,1], standard tableau [6] # > map(evalm, %); # # 6 6 6 # 2 3 and 3 # 1 1 1 #============================================================================= local R,F,i,EV,mx; F:=[]; # fm=[8,3,2] -> F:=[13,5,2] for i from nops(fm) to 1 by -1 do if (nops(F)>0) then F:=[fm[i]+F[1], op(F)];else F:=[fm[i]];fi; od; EV:=[]; for i from 1 to nops(ev) do if (nops(EV)>0) then EV:=[op(EV), ev[i]+EV[nops(EV)]];else EV:=[ev[i]];fi; od; mx:=EV[nops(EV)]; EV:=[op(EV), seq( mx,i=1.. mx-nops(EV))]; R:=`HanTab/Kiri/MatAdm_`(EV,F); map(`HanTab/Kiri/MatTr`,map(`HanTab/Kiri/MatClean`, R)); end; # }}} # 2. Kostka polynomials `HanTab/Kiri/MatCumulSum`:=proc(m, opr, fix) # {{{ # # m = matrix # opr = "+" or "-" # fix = "Top", "Bottom", "Left", "Right", means the line with fixed value # # format of m = list of rows (standard) # # EXAMPLES: # > m:= [[6, 6], [2, 3], [1, 1]]: evalm(m); # # 6 6 # 2 3 # 1 1 # # > `HanTab/Kiri/MatCumulSum`(m, "+", "Left"): evalm(%); # # 6 12 # 2 5 # 1 2 # # > `HanTab/Kiri/MatCumulSum`(m, "+", "Right"): evalm(%); # # 12 6 # 5 3 # 2 1 # # > `HanTab/Kiri/MatCumulSum`(m, "-", "Left"): evalm(%); # # 6 0 # 2 1 # 1 0 # # > `HanTab/Kiri/MatCumulSum`(m, "-", "Right"): evalm(%); # # 0 6 # -1 3 # 0 1 # # > `HanTab/Kiri/MatCumulSum`(m, "+", "Top"): evalm(%); # # 6 6 # 8 9 # 9 10 # # # > `HanTab/Kiri/MatCumulSum`(m, "+", "Bottom"): evalm(%); # # 9 10 # 3 4 # 1 1 # # # > `HanTab/Kiri/MatCumulSum`(m, "-", "Top"): evalm(%); # # 6 6 # -4 -3 # -1 -2 # # # > `HanTab/Kiri/MatCumulSum`(m, "-", "Bottom"): evalm(%); # # 4 3 # 1 2 # 1 1 # local i,R,a,nc,nr,b,fixtr; nr:=nops(m); nc:=nops(m[1]); R:=[]; fixtr:=""; if fix="Left" or fix="Right" then for i from 1 to nr do b:=`HanWord/CumulSum`(m[i],opr,fix); R:=[op(R),b]; od; fi; if fix="Top" then fixtr:="Left" fi; if fix="Bottom" then fixtr:="Right" fi; if fixtr<>"" then R:=`HanTab/Kiri/MatTr`( `HanTab/Kiri/MatCumulSum`(`HanTab/Kiri/MatTr`(m), opr, fixtr)); fi; R; end; # }}} `HanTab/Kiri/FiveMat`:=proc(m) # {{{ # - computer the five matrices in order [e,E,V,F,f] (see ref [SLC/B31a]) # # EXAMPLE: # # > m:=[[11,13,13],[3,4,5], [1,2,2]]: evalm(m); # > `HanTab/Kiri/FiveMat`(m): map(evalm,%); # # output see [SLC/B31a] local e,E,V,F,f; E:=`HanTab/Kiri/MatCumulSum`(m, "-", "Left"); e:=`HanTab/Kiri/MatCumulSum`(E, "-", "Right"); F:=`HanTab/Kiri/MatCumulSum`(m, "-", "Bottom"); f:=`HanTab/Kiri/MatCumulSum`(F, "-", "Bottom"); V:=`HanTab/Kiri/MatCumulSum`(F, "-", "Left"); [e,E,V,F,f]; end; # }}} `HanTab/Kiri/MatKostka`:=proc(m) # {{{ # - Kostka polynomial for one admissible matrix # # > m:=[[11,13,13],[3,4,5], [1,2,2]]: evalm(m); # > `HanTab/Kiri/MatKostka`(m); # local cv, R,i,j, nc,nr, m5, e,E,V,F,f; R:=1; cv:=0; nr:=nops(m); nc:=nops(m[1]); m5:=`HanTab/Kiri/FiveMat`(m); V:=m5[3]; e:=m5[1]; f:=m5[5]; for i from 1 to nr do for j from 1 to nc do cv:=cv+ V[i][j]*(V[i][j]-1)/2; od;od; for i from 1 to nr-1 do for j from 1 to nc do R:=R* `HanSeries/Multinomial/q`([e[i+1][j], f[i][j]], q); od;od; q^cv*R; end; # Han 2006/04/13 09:01 # }}} `HanTab/Kiri/Kostka`:=proc(ev,fm) # {{{ # - Kostka polynomial for given form and evaluation # # Input format: # # ev and fm are two partitions # ev = transpose of evaluation of tableau, ev=[n] means standard tableau # fm = form of tableau # # Output format: # # output = polynomial in q # # Example: # # > `HanTab/Kiri/Kostka`([6],[3,2,1]); # forme [3,2,1], standard tableau [6] # > factor(%); # q^4*(q+1)^3*(q^2+1)*(q^2-q+1) local mlist; mlist:=`HanTab/Kiri/MatAdm`(ev,fm); map(`HanTab/Kiri/MatKostka`, mlist); convert(%, `+`); end; # Han 2006/04/13 09:01 # }}} # 3. Bijection: Path matrix -> YTab `HanTab/Kiri/Pathmat2Ytab/Example`:= # W in paper SLC [B31a], p.6 [ [[1,1], [1,1], [], [1,1,1]], [[0,0,0], [0,0,0,1], [0,0,0], [0,1,1,0]], [[1], [0], [0,1], [0,0,0]], [[1], [0], [0,0], [0,0]], [[0], [0], [0], [0]] ]; `HanTab/Kiri/Pathmat2Ytab/Print`:=proc(pm) # {{{ # - Path Matrix -> Young Tab # # Input format: # # pm = path matrix [ [[0,0,1,1,1], [1,0,0] , ...], [], ....] # Reference: Han SLC [B31a](1994) , 0=a, 1=b. # # Example: # > `HanTab/Kiri/Pathmat2Ytab/Print`(`HanTab/Kiri/Pathmat2Ytab/Example`); # > local i,j,k, L; printf("_______________________\n"); for i from 1 to nops(pm) do L:=pm[i]; for j from 1 to nops(L) do for k from 1 to nops(L[j]) do printf("%d", L[j][k]); od; printf(","); od; printf("\n"); od; end; # Han 2007/07/17 01:02 # }}} `HanTab/Kiri/Pathmat2Ytab/Bij/Move1Step`:=proc(PM,x,y, ab) # {{{ # - Move 1 step, after trace 1 step # - Modify pm without output local i,j, pm,v; pm:=PM; v:=pm[x][y]; v:=v[1..nops(v)-1]; pm[x][y]:=v; if ab=1 and y>1 then pm[x][y-1]:=[op(pm[x][y-1]), ab]; fi; if ab=0 and x>2 then pm[x-1][y]:=[op(pm[x-1][y]), ab]; fi; pm; end; # }}} `HanTab/Kiri/Pathmat2Ytab/Bij/1Step`:=proc(PM) # {{{ # - Path Matrix -> Young Tab # # Input format: # # pm = path matrix [ [[0,0,1,1,1], [1,0,0] , ...], [], ....] # Reference: Han SLC [B31a](1994) , 0=a, 1=b. # # Output format: # # output = Young tab as integral matrix # # Example: # local i,mlist, pm,x,y,k,d, L, R; pm:=PM; L:=convert(map( z->convert(z, `+`), pm[1]), `+`); # find entre point x:=1; d:=1; for y from 1 to nops(pm[x]) do if pm[x][y]<>[] then break; fi; od; # print(y); #`HanTab/Kiri/Pathmat2Ytab/Print`(pm); for k from 1 to nops(pm)+nops(pm[1])+2 do if pm[x][y]=[] then print("ERROR, bad path matrix"); RETURN(""); fi; d:=pm[x][y][nops(pm[x][y])]; # print(x,y,d); pm:=`HanTab/Kiri/Pathmat2Ytab/Bij/Move1Step`(pm,x,y,d); #`HanTab/Kiri/Pathmat2Ytab/Print`(pm); if d=1 then x:=x+1 ; else y:=y+1; fi; if x>nops(pm) then print("ERROR, x over"); RETURN(""); fi; if y>nops(pm[1]) then break; fi; od; #print(k, x,y, nops(pm[1])); R:=x-1; [pm, L,R]; end; # Han 2007/07/17 01:02 # }}} `HanTab/Kiri/Pathmat2Ytab/Bij`:=proc(PM) # {{{ # - Path Matrix -> Young Tab # # Input format: # # pm = path matrix [ [[0,0,1,1,1], [1,0,0] , ...], [], ....] # Reference: Han SLC [B31a](1994) , 0=a, 1=b. # # Output format: # # output = Young tab as integral matrix # # Example: # # > `HanTab/Kiri/Pathmat2Ytab/Bij`(`HanTab/Kiri/Pathmat2Ytab/Example`); # > map(z-> if z=0 then `.` else z fi, evalm(%)); local t,l, r,pm,k, L, R, Ls, Rs,kk; pm:=PM; Ls:=[]; Rs:=[]; for k from 1 do r:=`HanTab/Kiri/Pathmat2Ytab/Bij/1Step`(pm); pm:=r[1]; L:=r[2]; R:=r[3]; # `HanTab/Kiri/Pathmat2Ytab/Print`(pm); # print(L,R); Ls:=[op(Ls), L]; Rs:=[op(Rs), R]; l:=convert(map( z->convert(z, `+`), pm[1]), `+`); if l=0 then break; fi; od; [Rs, Ls]; t:=[ seq([], kk=1..nops(pm)-1)]; for k from 1 to nops(Rs) do t[Rs[k]]:=[Ls[k], op(t[Rs[k]])]; od; `HanTab/Util/Format/Array2Mat`(t); end; # Han 2007/07/17 01:02 # }}} # 4. All Path matrix -> All Ytab (like Path Mat -> Kostka) `HanTab/Kiri/Mat2Ytab`:=proc(m) # {{{ # - List of all path matrix and corresponding ytab for one admissible matrix # # Input format: # m = admissible matrix # # Output format: # # output = list [[pm, ytab] , [], ...] # # > m:=[[5, 6], [2, 3], [1, 1]] : evalm(m); # > `HanTab/Kiri/Mat2Ytab`(m); # > for i in % do print(i[1], evalm(i[2])); od; local p, cv, R,i,j, nc,nr, m5, e,E,V,F,f, A, ProdList, pm, tab, Rs; R:=1; cv:=0; nr:=nops(m); nc:=nops(m[1]); m5:=`HanTab/Kiri/FiveMat`(m); V:=m5[3]; e:=m5[1]; f:=m5[5]; p:=[seq([seq([], i=1..nc)], j=1..nr+1)]; A:=(x,y) -> HanFill("perm", [seq(0, i=1..y), seq(1, i=1..x)]); ProdList:=z -> HanFill("all", map(y-> {op(y)}, z)); for j from 1 to nc do p[1][j]:=A(e[1][j], 0); od; for i from 1 to nr-1 do for j from 1 to nc do p[i+1][j]:=A(e[i+1][j], f[i][j]); od; od; for j from 1 to nc do p[nr+1][j]:=A(0, f[nr][j]); od; p; p:=map(ProdList, p); p:=ProdList(p); Rs:=[]; for pm in p do tab:=`HanTab/Kiri/Pathmat2Ytab/Bij`(pm); Rs:=[op(Rs), [pm, tab]]; od; Rs; end; # Han 2007/07/17 09:25 # }}} `HanTab/Kiri/AllYtab`:=proc(ev,fm) # {{{ # - List of all path matrix and corresponding ytab for # given form and evaluation # # Input format: # # ev and fm are two partitions # ev = transpose of evaluation of tableau, ev=[n] means standard tableau # fm = form of tableau # # Output format: # # output = list [[pm, ytab] , [], ...] # # Example: # # > `HanTab/Kiri/AllYtab`([5,1],[3,2,1]); # forme [3,2,1],letters=[1,1,2,3,4,5] # > for i in % do print(i[1], evalm(i[2])); od; local mlist; mlist:=`HanTab/Kiri/MatAdm`(ev,fm); map(z-> op(`HanTab/Kiri/Mat2Ytab`(z)), mlist); end; # Han 2007/07/17 09:24 # }}} #============================================================================= # Hook: 2007/12/06 23:10 `HanTab/hook`:=proc(p, pi,pj) # {{{ # # Hook of a point (pi, pj) for the partition p # # O # O O # O h O O h=4 at (1,2) # # EXAMPLE # > `HanTab/hook`([4,2,1], 1, 2); # local h,i,j; h:=0; if p[pi]=pj then h:=h+1; fi; od; h:=h+p[pi]-pj+1; end; # }}} `HanTab/hook/la`:=proc(p, pi,pj) # {{{ # # Hook of a point (pi, pj) for the partition p, [leg, arm]: # hook = leg + arm +1 # # O # O O # O h O O h=4 at (1,2) # # EXAMPLE # > `HanTab/hook/la`([4,2,1], 1, 2); # [1,2] local h,i,j; h:=0; if p[pi]=pj then h:=h+1; fi; od; [h, p[pi]-pj]; end; # }}} `HanTab/b`:=proc(p, pi,pj) # {{{ # # b of a point (pi, pj) for the partition p (see Stanley Vol. 2) # # 2 # 1 1 # 0 h 0 0 h=0 at (1,2) # # EXAMPLE # > `HanTab/b`([4,2,1], 1, 2); # local h,i,j; pi-1; end; # }}} `HanTab/validbox`:=proc(p) # {{{ # all valid box in a partition # # O (3,1) # O O (2,1), (2,2) # O 0 O O (1,1), (1,2), (1,3), (1,4) # # EXAMPLE # > `HanTab/validbox`([4,2,1]); # [[1, 1], [1, 2], [1, 3], [1, 4], [2, 1], [2, 2], [3, 1]] # local h,i,j; h:=[]; for i from 1 to nops(p) do for j from 1 to p[i] do h:=[op(h), [i,j]]; od; od; h; end; # }}} 2007/12/06 23:17 `HanTab/hook/formula`:=proc(n) # {{{ # Check hook formula, for testing, or example # (see Stanley Vol. 2) # # The formula is (Stanley Vol.2, p. 385) # #TEX! \def\l{\lambda} #TEX! Let $\l$ be a partition and $v$ a box in $\l$. Define #TEX! $h_\l(v)$ and $b_\l(v)$. We have #TEX! $$\sum_{n\geq 0} \Bigl(\sum_{\l\vdash n} #TEX! \prod_v {(pq)^{b_\l(v)}\over (1-p^{h_\l(v)})(1-q^{h_\l(v)})}\Bigr) y^n #TEX! = \prod {1\over 1-p^iq^jy} #TEX! =\exp\Bigl( #TEX! \sum_{n\geq 1} {1\over n} {y^n\over (1-p^n)(1-q^n)} #TEX! \Bigr) $$ #TEX! # # EXAMPLE # > `HanTab/hook/formula`(3); # local h,i,j, p, PL, ev,T1, T3; # calculate term left T1 PL:=map(k->op(ListPart(k)) , [seq(i,i=1..n)]); ev:=proc(pa) local LB; LB:=`HanTab/validbox`(pa); map(v-> (p*q)^`HanTab/b`(pa, v[1], v[2])*y /(1-p^`HanTab/hook`(pa, v[1], v[2])) /(1-q^`HanTab/hook`(pa, v[1], v[2])), LB); convert(%, `*`); end; map(p->ev(p), PL); T1:=convert(%,`+`); # calculate term right T3 sum(1/k*y^k/(1-p^k)/(1-q^k),k=1..n); series(exp(%), y, n+1); T3:=convert(%,polynom)-1; # compare simplify(T1-T3); end; # }}} `HanTab/HookList`:=proc(p) # {{{ # p = partition # out = list of all hook # local v; `HanTab/validbox`(p); map(v-> `HanTab/hook`(b, v[1], v[2]), %); end; # HAN, 2008/03/06 09:14 # }}} `HanTab/HookDev`:=proc(CL,x) # {{{ # Hook Development # # CL=1+c1*x +c2*x^2 + c3*x^3 + ... + xn x^n polynom # # Find function f: h -> f(h) such that # CL = sum_l prod_v f(h_v) x # # EAMPLE: Expansion for the power of the Euler product # # > P:=product( (1-x^m)^(b-1), m=1..7); # > series(P,x,8): convert(%, polynom): # > `HanTab/HookDev`(%,x); # # [-b+1, -1/4*b+1, -1/9*b+1, -1/16*b+1, -1/25*b+1, -1/36*b+1, -1/49*b+1] # local k, R, fhook; fhook:=proc(CL, n,x) option remember; # {{{ local i, c, PL,hn,f, hklist,Eq, R, r; c:=coeff(CL, x, n); if n=1 then RETURN (c); fi; f:=k-> if k map(v-> `HanTab/hook`(pa, v[1], v[2]), `HanTab/validbox`(pa)); PL:=`HanFill/part`(n); map( z-> hklist(z), PL); map( z-> convert(map(u->f(u), z), `*`), %); Eq:=convert(%,`+`); # print(n, Eq= c); if subs(hn=0, Eq)=Eq and c=Eq then R:=r[n]; else R:=solve(Eq=c, hn); if R=NULL then printf("Denominator is zero, no solution for n=%a.", n); R:=0; fi; fi; #print(n, R); R; end; # }}} R:=[]; for k from 1 to degree(CL,x) do R:=[op(R), fhook(CL,k,x)]; od; R; end; # HAN 2008/03/04 08:13 # }}} `HanTab/HookDev/inverse`:=proc(fh) option remember; # {{{ # Inverse of Hook Development # # Given hook function f: h -> f(h), # output: CL = sum_l prod_v f(h_v) x # # EAMPLE: Expansion for the power of the Euler product # # > product( (1-x^m)^(b-1), m=1..7); # > series(%,x,8): P:=convert(%, polynom): # > `HanTab/HookDev`(%,x); # # [-b+1, -1/4*b+1, -1/9*b+1, -1/16*b+1, -1/25*b+1, -1/36*b+1, -1/49*b+1] # # > `HanTab/HookDev`(%); # ... # > simplify(P-%); # 0 local i, pa, PL, ev, n; n:=nops(fh); PL:=map(k->op(`HanFill/part`(k)) , [seq(i,i=1..n)]); ev:=proc(pa) local LB; LB:=`HanTab/validbox`(pa); map(v-> x*fh[`HanTab/hook`(pa, v[1], v[2])], LB); convert(%, `*`); end; map(pa->ev(pa), PL); 1+convert(%,`+`); end; # HAN 2008/03/04 08:30 # }}} # Shift Hook `HanTab/ShiftHookList`:=proc(p) # {{{ # p = partition with distinct parts # p = 7 5 4 1 = p1 p2 p3 p4 # draw as # |* # *|* * * # * *|* * * # * * *|* * * * # get b= p -(3 2 1 0) = 4 3 3 1 = b1 b2 b3 b4 # ShiftHook of p = hook of b UNION: # # b3+b4+1 # b2+b3+3 b2+b4+2 # b1+b2+5 b1+b3+4 b1+b4+3 # # EXAMPLE (KnuthBookIII, p. 67) pa= 7541 # > `HanTab/ShiftHookList`([7,5,4,1]); # [7, 5, 4, 1, 5, 3, 2, 4, 2, 1, 1, 12, 11, 8, 9, 6, 5] # local b,n,i,B, H,j; n:=nops(p); b:=p; for i from 1 to n do b[i]:=b[i]- (n-i); od; b; B:=`HanTab/validbox`(b); H:=map(v-> `HanTab/hook`(b, v[1], v[2]), B); for i from 1 to n-1 do for j from i+1 to n do H:=[op(H), b[i]+b[j] +(n-i)+(n-j) ]; od; od; H; end; # HAN, 2008/03/06 09:14 # }}} `HanTab/ShiftHookDev`:=proc(CL,x) # {{{ # Hook Development # # CL=1+c1*x +c2*x^2 + c3*x^3 + ... + xn x^n polynom # # Find function f: h -> f(h) such that # CL = sum_l 2^(n-len(l)) prod_v f(h_v) x # distinct parts # # (old, bad)EAMPLE: Expansion for the power of the Euler product # # > P:=product( (1-x^m)^(b-1), m=1..7); # > series(P,x,8): convert(%, polynom): # > `HanTab/HookDev`(%,x); # # [-b+1, -1/4*b+1, -1/9*b+1, -1/16*b+1, -1/25*b+1, -1/36*b+1, -1/49*b+1] # local k, R, fhook; fhook:=proc(CL, n,x) option remember; # {{{ local i, c, PL,hn,f, Eq, sl, R; c:=coeff(CL, x, n); if n=1 then RETURN (c); fi; f:=k-> if k convert(pa, `+`) - nops(pa); PL:=`HanFill/part`(n); PL:=map(p-> if nops(p)=nops({op(p)}) then p else fi, PL); #sel distinct parts map( z-> 2^(sl(z))*convert(map(u->f(u), `HanTab/ShiftHookList`(z)), `*`), PL); Eq:=convert(%,`+`); R:=solve(Eq=c, hn); if R=NULL then print("No solution R=NULL at position n=", n); fi; # print(n, R); R; end; # }}} R:=[]; for k from 1 to degree(CL,x) do R:=[op(R), fhook(CL,k,x)]; od; R; end; # HAN 2008/03/04 08:13 # }}} `HanTab/ShiftHookDev/inverse`:=proc(fh) option remember; # {{{ # Inverse of Hook Development # # Given hook function f: h -> f(h), # output: CL = sum_l prod_v f(h_v) x # # EAMPLE: Expansion for the power of the Euler product # # > product( (1-x^m)^(b-1), m=1..7); # > series(%,x,8): P:=convert(%, polynom): # > `HanTab/HookDev`(%,x); # # [-b+1, -1/4*b+1, -1/9*b+1, -1/16*b+1, -1/25*b+1, -1/36*b+1, -1/49*b+1] # # > `HanTab/HookDev`(%); # ... # > simplify(P-%); # 0 local i, pa, PL, ev, n, sl; n:=nops(fh); PL:=map(k->op(`HanFill/part`(k)) , [seq(i,i=1..n)]); PL:=map(p-> if nops(p)=nops({op(p)}) then p else fi, PL); #sel distinct parts sl := pa -> convert(pa, `+`) - nops(pa); ev:=proc(pa) local LB; LB:=`HanTab/ShiftHookList`(pa); map(v-> x*fh[v], LB); convert(%, `*`); %*2^(sl(pa)); end; map(pa->ev(pa), PL); 1+convert(%,`+`); end; # HAN 2008/03/04 08:30 # }}} HanLibname:=`HanTab/Name`, HanLibname: # }}} # HanTree {{{ # List of all Tree `HanTree/Bin`:=proc(n) # {{{ # List of all binary tree with more informations (here hook lengths) # output = [[Tree1, Info1], [Tree2, Info2], ....] # a tree is coded by Tree1=[T1, T2] # empty leave is represented by "e" # # Here Info1=[h1, h2, ...,hn] list of hook lengths # # EXAMPLE # > R:=`HanTree/Bin`(3): # # R:=[ # [[e, [e, [e, e]]], [0, 0, 0, 0, 1, 2, 3]], # [[e, [[e, e], e]], [0, 0, 0, 1, 0, 2, 3]], # [[[e, e], [e, e]], [0, 0, 1, 0, 0, 1, 3]], # [[[e, [e, e]], e], [0, 0, 0, 1, 2, 0, 3]], # [[[[e, e], e], e], [0, 0, 1, 0, 2, 0, 3]] # ] # # R[1]= \ R[2]= \ R[3] = /\ R[4] = / R[5]= / # \ / \ / # local R, k, B1, B2, b,c; R:=[]; if n=0 then RETURN([[e, 0]]); fi; for k from 0 to n-1 do B1:=procname(k); B2:=procname(n-1-k); for b in B1 do for c in B2 do R:=[op(R), [[b[1],c[1]], [op(b[2]), op(c[2]), n] ]]; od; od; od; R; end; # Han 2008/03/04 11:43 # }}} `HanTree/BinCompl`:=proc(n) # {{{ # List of all binary complete tree with more informations (here hook lengths) # output = [[Tree1, Info1], [Tree2, Info2], ....] # a tree is coded by Tree1=[T1, T2] # empty leave is represented by "e" # leave is represented y "v" # # Here Info1=[h1, h2, ...,hn] list of hook lengths # # EXAMPLE # > R:=`HanTree/Bin`(3): # # R:=[ # [[v, [v, [v, v]]], [0, 0, 0, 0, 1, 2, 3]], # [[v, [[v, v], v]], [0, 0, 0, 1, 0, 2, 3]], # [[[v, v], [v, v]], [0, 0, 1, 0, 0, 1, 3]], # [[[v, [v, v]], v], [0, 0, 0, 1, 2, 0, 3]], # [[[[v, v], v], v], [0, 0, 1, 0, 2, 0, 3]] # ] # # R[1]= /\ R[2]= /\ R[3] = /\ R[4] = /\ R[5]= /\ # /\ /\ /\/\ /\ /\ # /\ /\ /\ /\ # local R, k, B1, B2, b,c; R:=[]; if n=0 then RETURN([[e, 0]]); fi; if n=1 then RETURN([[v, 1]]); fi; for k from 0 to floor(n/2)-1 do B1:=procname(2*k+1); B2:=procname(n-1-(2*k+1)); for b in B1 do for c in B2 do R:=[op(R), [[b[1],c[1]], [op(b[2]), op(c[2]), n] ]]; od; od; od; R; end; # Han 2008/03/05 15:44 # }}} `HanTree/BinFibo`:=proc(n) # {{{ # List of all binary complete tree with more informations (here hook lengths) # output = [[Tree1, Info1], [Tree2, Info2], ....] # a tree is coded by Tree1=[T1, T2] # empty leave is represented by "e" # leave is represented y "v" # # Here Info1=[h1, h2, ...,hn] list of hook lengths # # EXAMPLE # > R:=`HanTree/Bin`(3): # # R:=[ # [[v, [v, [v, v]]], [0, 0, 0, 0, 1, 2, 3]], # [[v, [[v, v], v]], [0, 0, 0, 1, 0, 2, 3]], # [[[v, v], [v, v]], [0, 0, 1, 0, 0, 1, 3]], # [[[v, [v, v]], v], [0, 0, 0, 1, 2, 0, 3]], # [[[[v, v], v], v], [0, 0, 1, 0, 2, 0, 3]] # ] # # R[1]= /\ R[2]= /\ R[3] = /\ R[4] = /\ R[5]= /\ # /\ /\ /\/\ /\ /\ # /\ /\ /\ /\ # local R, k, B1, B2, b,c; R:=[]; if n=0 then RETURN([[e, 0]]); fi; if n=1 then RETURN([[v, 1]]); fi; B1:=procname(n-1); B2:=procname(0); for b in B1 do for c in B2 do R:=[op(R), [[b[1],c[1]], [op(b[2]), op(c[2]), n] ]]; od; od; B1:=procname(n-2); B2:=procname(1); for b in B1 do for c in B2 do R:=[op(R), [[b[1],c[1]], [op(b[2]), op(c[2]), n] ]]; od; od; R; end; # Han 2008/03/05 15:44 # }}} `HanTree/HookDev`:=proc(CL,x, treeType) # {{{ # Hook Development # treeType= `HanTree/Bin`; `HanTree/BinCompl`; `HanTree/Fibo`; # # CL=1+c1*x +c2*x^2 + c3*x^3 + ... + xn x^n polynom # # Find function f: h -> f(h) such that # CL = sum_l prod_v f(h_v) x # # EAMPLE: # # local k, R, fhook; if coeff(CL, x, 0) <>1 then print( "CL(0) not= 1" ); RETURN(false); fi; fhook:=proc(CL, n,x) option remember; # {{{ local i, c, PL,hn,f, Eq,R; c:=coeff(CL, x, n); if n=1 then RETURN (c); fi; if n=0 then RETURN (1); fi; f:=k-> if k z[2], PL); map( z-> convert(map(u->f(u), z), `*`), %); Eq:=convert(%,`+`); R:=solve(Eq=c, hn); if R=NULL then print("No solution R=NULL at position n=", n); fi; #print(n, R); R; end; # }}} R:=[]; for k from 1 to degree(CL,x) do R:=[op(R), fhook(CL,k,x)]; od; R; end; # HAN 2008/03/04 08:13 # }}} `HanTree/HookDev/inverse`:=proc(fh, treeType) option remember; # {{{ # Inverse of Hook Development # # Given hook function f: h -> f(h), # output: CL = sum_l prod_v f(h_v) x # # EAMPLE: Postnikov Identity (not checked) # # > f:= m -> (1+b/m); # > fh:=[seq(f(k), k=1..NN)]; # > R:=`HanTree/HookDev/inverse`(fh, `HanTree/Bin`); # ... # > for k from 1 to degree(R,x) do print(k, factor(coeff(R,x,k))); od; # ... local i, pa, PL, ev, n; n:=nops(fh); PL:=map(k->op(treeType(k)) , [seq(i,i=1..n)]); PL:=map(z->z[2], PL); # select only hook list ev:=proc(pa) map(v-> if v=0 then 1 else x*fh[v] fi, pa); convert(%, `*`); end; map(pa->ev(pa), PL); 1+convert(%,`+`); end; # HAN 2008/03/04 08:30 # }}} HanLibname:=`HanTree/Name`, HanLibname: # }}} hookhelp:=proc() printf(" > hooktype:=\"PA\": \# Partition\n"); printf(" > hooktype:=\"PAD\": \# Partition with distinct parts\n"); printf(" > hooktype:=\"BT\": \# Binary tree\n"); printf(" > hooktype:=\"CBT\": \# Complete binary tree\n"); printf(" > hooktype:=\"FT\": \# Fibonacci tree\n"); end; hooktype:="please set hook type.": hookexp:=proc(f,n) local r, ff; global hooktype; r:="empty": series(f,x,n+1): ff:=convert(%, polynom): if hooktype="PA" then r:=`HanTab/HookDev`(ff,x); fi; if hooktype="BT" then r:=`HanTree/HookDev`(ff,x, `HanTree/Bin`); fi; if hooktype="CBT" then r:=`HanTree/HookDev`(ff,x, `HanTree/BinCompl`); fi; if hooktype="FT" then r:=`HanTree/HookDev`(ff,x, `HanTree/BinFibo`); fi; if r="empty" then hookhelp(); fi; r; end; hookgen:= proc(rho) local r; global hooktype; r:="empty": if hooktype="PA" then r:=`HanTab/HookDev/inverse`(rho): fi; if hooktype="BT" then r:=`HanTree/HookDev/inverse`(rho, `HanTree/Bin`): fi; if hooktype="CBT" then r:=`HanTree/HookDev/inverse`(rho, `HanTree/BinCompl`): fi; if hooktype="FT" then r:=`HanTree/HookDev/inverse`(rho, `HanTree/BinFibo`): fi; if r="empty" then hookhelp(); fi; r; #sort(r, x, ascending); end; #============================================================================= # EOF #============================================================================= # vim: fmr={{{,}}} foldmethod=marker # vim: set sw=2: set ts=2: set cindent