Code
Clear[canonsIrreg, irregulQ];

irregulQ[poly_] :=     Not[Module[
    {l=Length[poly]},
    Or[l==2,
    Length[Expand[(poly[[2]]-1)*poly]]==2 ]
                ] ]
                
tousLesCoeff[poly_, var_:X] :=
        Union[CoefficientList[poly, var]]

canonsIrreg[n_Integer] :=

    If[Not[PrimeQ[n]],
    
    (* rien à dire, rien à faire si n est premier *)
    
    Module[{facteurs, nbreFacteurs,fact1, fact2,
            soluces, chiffresBinaires, chiffres},
    
    (* variables locales *)
    
    soluces = {};
    facteurs = First[Transpose[
                    Drop[FactorList[X^n-1],2]]];
                    
    (* liste des facteurs irréduc., sauf 1 et X-1 *)
            
    nbreFacteurs = Length[facteurs];
    Do[
    chiffresBinaires = IntegerDigits[k, 2, nbreFacteurs];
    chiffres = First /@ Position[chiffresBinaires, 1];
    fact1 = Expand[Apply[Times,
                Map[facteurs[[#]]&, chiffres]
                    ] ];
    If[tousLesCoeff[fact1]=={0,1},
        (* si le premier facteur est un polynôme 0-1 *)
        If[And[irregulQ[fact1],
                tousLesCoeff[
                fact2 = Cancel[(X^n-1)/(X-1)/fact1]
                                        ]=={0,1},
                irregulQ[fact2]
                ], (* fin du And *)
            AppendTo[soluces, {fact1,fact2}]
            ]
            
        ], (* fin du If *)
    
    {k,2^(nbreFacteurs-1)} ]; (* fin du Do *)
    
        soluces ]   (* fin du Module *)
        
        ]            (* fin du premier If *)
canonsIrreg[81]
Map[canonPlot, %];
Clear[ca54];
ca54=canonsIrreg[54]
canonPlot /@ ca54; canonPlot /@ (Reverse /@ ca54);
[Graphics:../Images/expose_gr_86.gif]

[Graphics:../Images/expose_gr_87.gif]

[Graphics:../Images/expose_gr_88.gif]

[Graphics:../Images/expose_gr_89.gif]

[Graphics:../Images/expose_gr_90.gif]

[Graphics:../Images/expose_gr_91.gif]

[Graphics:../Images/expose_gr_92.gif]

[Graphics:../Images/expose_gr_93.gif]

[Graphics:../Images/expose_gr_94.gif]


Converted by Mathematica      February 8, 2002