Ze Official CanonCrawler

Philosophie générale : on travaille sur des LISTES D'INTERVALLES, réduites à une BASICFORM façon Forte (i.e. qui prend le moins de place possible sur le diagramme en horloge).

Au fait, si on veut des 0 et des 1 au lieu de la liste intervallique, ou l'inverse :

Off[General::spell1, General::spell];
\(\(\(to01[tile_]\  := 
      Module[{onsets\  = \ fromBasicForm[tile], \ resu, \ n}, 
	
        resu\  = \ 
          Table[MemberQ[onsets, \ k], {k, 
              Last[onsets]}]; 
		resu /. {True -> 1, \ 
            False -> 0}]\)\(
\)
    \)\)
\(from01[maListe_]\  := 
      basicForm[\ 
		Position[maListe, 1] // 
          Flatten

		\ , \ 
        Length[maListe]]\)

from01[{0,1,0,0,1,0,1,0,0,1,0,1,0,0,1,0}]

Quand on donne la liste des intervalles il est facile de les trier alla Forte :

basicForm[maListe_, modulo_] := Module[{n, maxi, foo, grosTas},

		(* mise en forme propre: range, commence a 0 *)
		
	foo = Sort[Mod[maListe - Min[maListe], modulo] ];
	n=Length[foo];
			
		(* faire liste intervalles *)

	foo = Mod[Drop[
			Append[ foo,  First[foo]] - 
			Prepend[foo,  Last[foo]],
			  1],
		  modulo];
	  
	maxi = Max[foo];
	
		(* faire tourner, et trier *)
	grosTas = Table[RotateLeft[foo, k],{k,n}];
	Select[grosTas, (Last[#]==maxi)&]//Sort//First
	]


fromBasicForm[listeInt_] := Module[{toto},
	toto = Drop[FoldList[Plus, 0, listeInt], 1];
	toto - First[toto] ]

basicForm[{0, 2, 10, 18, 56, 64},72]

fromBasicForm[{8, 8, 2, 8, 8, 38}]

basicForm[%, 72]

NB: on ne lit pas la période avec fromBasicForm. Il faut pour cela appliquer 'Plus'.

fromBasicForm[r72[[2]]]
Plus @@ s72[[2]]

Reconnaître les facteurs cyclotomiques

Outils polynomiaux

\(\(\(rU01[A_, \ 
        var_:\ \ x]\)\(:=\)\(
\)\(\ \ \ \ \)\((Union@
            CoefficientList[A, \ var]\  == \ {0, 1})\)\(\ \)\)\)

polyFromList[li_,   var_:  x]   :=  
      Plus  @@  (var^fromBasicForm[li])

polyFromList[{1, 3, 1, 3}]

\(polyToCanon[A_, \ 
            var_:  x]\ \ \  := 
\ \ \ \ \ \ \ Flatten[
              Position[CoefficientList[A, \ var], \ 1]]\  - \ 1;\)

Cyclotomiques etc

cyclo[n_]  /;  PrimeQ[n]   :=  
          Sum[x^k,  {k,  0,  n  -  1}]

    cyclo[0]   =   1; 
    cyclo[1]   =   x  -  1;
    
   \(\(cyclo[
          n_]\ \  := \ \ \ \(cyclo[
            n]\ \  = 
\ \ \ \ \ \ \ Module[
{lDiv\ \  = \ 
                Divisors[
                  n]}, \ 
Cancel[\ \((x^
                      n\ \  - \ \ 1)\)\ /
\ \ \ \ \ \ \ \ \ \ \ \ \ Apply[
                  Times, \ \ Map[
                    cyclo, \ \ \ \ Drop[
                      lDiv, \ \ \(-1\)\ ]\ ]\ ]\ ]\ ]\)\)\(
\)
      \)
Do[cyclo[n],  {n,  300}];

  arrondi  =   (u_  /;  
                Abs[u  -  1]  <  0.000001  ->  1) ;
  
   \(moduleRacines[poly_]\  := 
\ \ \ \ \ Union[
          Abs[x\  /. \ 
                NSolve[poly\  == \ 0, \ x, \ 
                  If[Coefficient[poly, x] > 30, \ 
                    AccuracyGoal -> 
                      MachinePrecision - 
                        5]]]\  /. 
\ \ \ \ \ \ \ \ \ arrondi]\)

(* D' 
            après un théorème de ? 
              Frobenius ?,  si un polynôme

          
          a des coefficients entiers et toutes ses racines complexes sont de module 1 alors c' est un produit de polys cyclotomiques *)
     
   \(recog[
          poly_]\  := 
\ \ \ \ \ Module[{deg\  = \ Exponent[poly, \ x], \ 
            n\  = \ 1}, 
\ \ \ \ \ \ \ If[
            moduleRacines[poly]\  == \ {1}\  && \ 
              deg\  >= \ 1, 
\ \ \ \ \ \ \ \ \ While[
              Or[\ \((EulerPhi[n]\  != \ 
                    deg)\)\ , \ \ \((cyclo[
                      n]\  =!= 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ poly)\)\ ], \ \ \(n++\)\ ]; \ 
n, 
\ \ \ \ \ \ \ \ \ 0]]\)

    recog[1]  :=  0;
     
recogListe[li_]  :=  
      Map[recog, Drop[ FactorList[polyFromList[li]],  1] // Transpose // 
            First] // Sort

recog[1 + (x^4)]

recogListe[r72[[2]] ]

Pour dilater un pavé donné sous forme d'une liste d'intervalles, c'est on ne peut plus simple !

enlarge[tile_,  ratio_]  :=  ratio*tile

Pour lui faire subir la construction du genre
(1 1 0 1 0 1) -> (11 11 00 11 00 11), ça l'est encore assez.
Puis on remet en basicForm.

\(zoomIn[tile_, \ ratio_]\  := 

      Module[{poly}, 
	
        poly\  = \ polyFromList[ratio\ *\ tile]; 
	
        poly\  = \ 
          Expand[poly\ *\ Sum[x\^k, {k, 0, ratio - 1}]]; 
	
        basicForm[
          polyToCanon[
            poly], 
			\ \ ratio*\((Plus\  @@ \ 
                tile)\)]
]\)

\(zoomInBis[tile_, \ ratio_]\  := 
Flatten[
        tile /. \((u_Integer -> {Array[1 &, 
                  ratio - 1], 
			ratio*u - 
                  2})\)\ ]\)

{zoomInBis[{2, 2, 5}, 3],  zoomIn[{2, 2, 5}, 3] }

a = {2, 2, 5}; b = {3, 3, 3};
GraphicsArray[{ppBasic[a, b], ppBasic[b, a]}] // Show;

zoomIn[a, 5]

zoomOut[{1, 3, 1, 3, 1, 9}]

GraphicsArray[{ppBasic[zoomIn[a, 2],  
              enlarge[b, 2]], 
ppBasic[zoomIn[b, 2],  
              enlarge[a, 2]]}] // Show;
Clear[a, b];

Pour la réciproque, moins.
Notons que la basicForm d'un tel canon se présente sous la forme
(1 1 … 1 x 1 1 … 1 y …)
où les x, y… se présentent tous les p et SONT EUX MÊMES DES MULTIPLES DE p, +1:
{1,1,4,1,1,7,1,1,4,1,1,7}
La procédure suivante simplifie à mort une liste d'intervalles (sous basicForm) , si cela est possible, et la rend telle quelle sinon.

Clear[zoomOut];

zoomOut[tile_] := Module[{p, sousListe, n = Length[tile],
		    fact, yeah, nonOnes},
	
	fact = Reverse[Drop[Divisors[n], 1]];
	nonOnes = Cases[tile,x_?(#≠1&)]; 
		
    While[fact ≠ {}, 
			p = First[fact]; 
			sousListe = (Table[tile[[p*k]], 
					{k, n/p}] - 1)/p + 1;
			
	(*	Print[p, sousListe, nonOnes] ;  débuggage *)
	
      	yeah = (
      	And @@ (IntegerQ /@ sousListe)
      	 (* vérifie que tous les éléments
      	  de sous-liste sont bien entiers *)
		             && 
		zoomIn[sousListe,p] == tile)
					  ;
		(* on vérifie que ça redonne la bonne *)	 
		   
			If[yeah, fact = {}, 
			(* sinon on itère *)
					 fact = Drop[fact, 1];
				]
		]; 
		
		If[yeah, sousListe, tile]
		]

zoomIn[{2,2,5}, 3]

zoomOut[zoomIn[{2,2,5}, 3]   ]

ppBasic[{2, 2, 5}, {3, 3, 3}];
ppBasic[{1, 1, 4, 1, 1, 4, 1, 1, 13},  {9, 9, 9}];

zoomOut[{1, 1, 6, 1, 12, 2}]

Est-ce un canon ? Est-ce un Vuza ? …

\(canonQ[A_, \ 
            B_]\  := \((
\((Plus\  @@ \ A\ \  == \ 
                  Plus\  @@ \ B)\)\  && 
\ \ \ \ \ Length[A]\ Length[
                    B]\  == 
\ \ \ \ \ \ \ Length[
                  Mod[Flatten[
	
                        Outer[Plus, \ 
                          fromBasicForm@A, \ \ fromBasicForm@
                            B]
		]\ , \ 
                      Plus\  @@ \ A] // \ Union])\)\)

  

tileQ[a_,  
            b_]  :=  (Outer[Plus,  a,  b] // Flatten  // 
                  Union  //  Length)  ==  
            Length[a] × Length[b]

  

\(loopQ[a_, \ b_]\  := \ 
          Module[{n\  = \ 
                Length[a]×
                  Length[b]}, 
	\((Mod[
                    Outer[Plus, \ a, \ b] // Flatten\ \ , \ n] // 
                  Union)\) == Range[0, n - 1]]\)

  

\(aperQ[li_]\  := \ 
        Module[{subliste, \ n, \ 
            rep\  = \ True}, 
		n\  = \ 
            Length[li]; 
		p = 
            1; 
		Do[
	
            If[
	
              li\  == \ \ Flatten[
                  Table[Part[li, \ 
                      Range[p]], \ {n/
                        p}]\ ], 
			rep\  = \ 
                False
		], \ {p, n/2}]; \ 
          rep
		]\)

\(vuzaQ[a_, \ b_]\  := 
\ \ \ \ \ And[canonQ[a, \ b], \ 
        aperQ[a], \ aperQ[b]]\)

loopQ[{0,1,5},{0,3}]

aperQ[{1, 4, 1, 1, 4, 1, 1, 4, 1}]

{aperQ[{8, 8, 2, 8, 8, 38}],  aperQ[{1, 4, 1, 4, 1, 4}]}

{canonQ[{1, 3, 1, 3}, {8}], 
vuzaQ[
        r72[[3]],  
        s72[[2]] ], 
vuzaQ[{1, 3, 1, 3}, {8,  
          16}] }

Transformations affines

affTransform[a_, ratio_] := Module[{modulo, foo},
		modulo = Plus @@ a;
		(* a est une liste d'intervalles *)
		foo = Sort[Mod[ratio*fromBasicForm[a], modulo]];
		basicForm[foo, modulo] ]

affTransform[r72[[3]], 5] == r72[[1]]

affTransform[r72[[1]], 19]
r72[[3]]//Reverse

vuzaQ[{4, 3, 6, 6, 5, 4, 15, 5, 1, 3, 3, 17},  
      s72[[2]] ]

\(orbite[tile_]\  := \ 
      Module[{inversibles, \ 
          n\  = \ Plus\  @@ \ tile}\ , 
inversibles\  = \ 
          Select[Range[1, 
              n - 1], 
					GCD[#, n] == 
                1 &]; 
\((\(affTransform[
                  tile, #] &\)\  /@ \ inversibles)\) // Union]\)

Graphiques linéaires

makeVoices[a_, b_, period_:0] :=
	If[period==0,Map[a + # &, b], Mod[Map[a + # &, b], period]]
	
(* pour fabriquer toutes les voix du canon *)
	
	noirEtBlanc[li_, nMin_, nMax_] :=
	Table[MemberQ[li, n],{n,nMin, nMax}]/.{True->1, False->0}
	(* pour changer une liste d'entiers en une
liste de 0 et de 1 aux endroits adéquats *)

plotCanon[canon_List, opti___?OptionQ] := Module[
			{nMin, nMax,foo = Flatten[canon]},
 ({nMin, nMax} = {Min[foo], Max[foo]});
 
	ListDensityPlot[1-Map[noirEtBlanc[#, nMin, nMax]&,canon], opti,
  MeshStyle->{GrayLevel[1]},AspectRatio->Length[canon]/(nMax-nMin)]
  		]

plotCanon[{{0, 2, 5}, {1, 3, 6}, {4, 7, 9}, {8, 11, 13}, {10, 12, 
            15}, {14, 16, 19}, {17, 20, 22}, {18, 21, 23}}];

Options[prettyPlot] = {période -> 0};


prettyPlot[a_, b_, opti___?OptionQ] := 
	Module[{canon,spot={}, width, height, all ,
					nMin, nMax, n=0},
			({n}= {période}/.{opti}/.Options[prettyPlot]);
			canon = makeVoices[a,b,n];
			all = Flatten[canon];
			
			nMin = Min[all]; nMax = Max[all ⋃ {n}];
			width = nMax - nMin;
			height = Length[b] ; (* nb of voices *)
			spot = 1-
				Map[noirEtBlanc[#,nMin, nMax]&,canon];
				ListDensityPlot[spot,
				MeshStyle->{GrayLevel[1]},
				AspectRatio-> height/width,
				FrameTicks->None
						]
			]	
			
pp = prettyPlot	;

ppBasic[a_, b_, opti___?OptionQ] :=	pp[fromBasicForm @ a,fromBasicForm @ b, opti]

Clear[plotAnimé,  
        plotAniméBasic];

    
Options[
          plotAniméBasic] = {période -> 
            0};

    
plotAnimé[a_, b_, opti___?OptionQ] := 
      plotAniméBasic[a // fromBasicForm, b // fromBasicForm,  
        opti]

    
\(\(\(plotAniméBasic[a_, b_, 
        opti___?OptionQ] := 
Module[{n = 0, 
          toto}, 
\(({n} = \({période} /. {opti}\) /. 
              Options[plotAniméBasic])\); 
If[
          n == 0, \ n = Length[a]*Length[b]]; 
 (*\ 
          réglage\ de\ la\ période\ *) 

Map[
          Show[Graphics[
                Raster[{toto = 1 - noirEtBlanc[Mod[a + #, n], 0, n - 1], 
                    toto}], 
\ AspectRatio -> 1.3/n, 
                FrameTicks -> None, 
                Frame -> 
                  True
	]
\ ] &, \ 
          b]
\ ]\)\(
\)
    \)\)
ppp  =  plotAniméBasic;

plotAniméBasic[{0, 3, 6, 9}, {0, 1, 2}, 
        période ->  6];

Graphiques en horloge :

clock[listeInt_] := Module[
		{n,  onsets},
		onsets  =  1 + fromBasicForm[listeInt];
		n  =  Plus  @@  listeInt;
		  
	\(Graphics[{
				Hue[0.2], 
                Disk[{0, 0}, 1], 
				PointSize[0.02], 
                Hue[0.78], 
			Map[
                  Point[{Sin[2  #\ π/n], Cos[2  #\ π/n]}] &, \ 
                  onsets]}, 
		AspectRatio -> Automatic]\)
			 ]

Graphiques en pneu :

torusPp[a_,  b_,  ratio_:  GoldenRatio] :=
 Module[{n, voix,  torus,  jMax = Length[b],  ptDuTore},
		n = Length[a] Length[b];
		voix  =  1 + Mod[Outer[Plus,  b,  a], n];

\(ptDuTore\ [{i_, 
                  j_}]\  := \ 
	
              Module[{v\  = \ 2  π\ i/n, \ 
                  u\  = \ 2  π\ j/
                        jMax}, 
{\((ratio\  + \ \ Cos[
                          u])\)\ Cos[v]\ , \((ratio\  + \ \ Cos[u])\) 
                    Sin[v], \ Sin[u]}\ ]\);

		torus = Table[
		  
\({If[MemberQ[voix[\([j]\)], \ i], \ 
                    GrayLevel[0.2], \ GrayLevel[1]\ ], \ 
	
                  Polygon[
		ptDuTore\  /@ \ {{i, 
                          j}, {i - 1, j}, {i - 1, j - 1}, {i, 
                          j - 1}}]
					}, 
				{i, \ n}, {j, jMax}\)];
	Show[Graphics3D[torus],   Boxed -> False, 
              Lighting -> 
                False, 
ViewPoint -> {0.995,  -3.040,  1.104}]
			 ]

torusPp[{0, 1, 4, 7, 13, 24, 28, 37, 43, 48, 49, 52}, {0, 8, 16, 18, 
          26, 34}];

torusPpColor[a_,  b_,  ratio_:  GoldenRatio] :=
 Module[{n, voix,  torus,  jMax = Length[b],  ptDuTore},
		n = Length[a] Length[b];
		voix  =  1 + Mod[Outer[Plus,  b,  a], n];

\(ptDuTore\ [{i_, 
                  j_}]\  := \ 
	
              Module[{v\  = \ 2  π\ i/n, \ 
                  u\  = \ 2  π\ j/
                        jMax}, 
{\((ratio\  + \ \ Sin[
                          u/2])\)\ Cos[v]\ , \((ratio\  + \ \ Sin[u/2])\) 
                    Sin[v], \ Cos[u/2]}\ ]\);

		torus = Table[
		  
\({If[MemberQ[voix[\([j]\)], \ i], 
                    Hue[j/Length[voix]], \ 
                    GrayLevel[1]\ ], \ 
	
                  Polygon[
		ptDuTore\  /@ \ {{i, 
                          j}, {i - 1, j}, {i - 1, j - 1}, {i, 
                          j - 1}}]
					}, 
				{i, \ n}, {j, jMax}\)];
	Show[Graphics3D[torus],   Boxed -> False, 
              Lighting -> 
                False, 
ViewPoint -> {2.222,  -1.776,  1.833}]
			 ]

Un pavé et ses zooms :

Show[GraphicsArray[{
		clock[{2,3,2,3}],
		clock[zoom[{2,3, 2,3}, 2]],
		clock[espante[{2,3, 2,3}, 2]]}]];

Reconnaître si les conditions (T1) et (T2) sont satisfaites.
Rend la période présumée si oui.
La fonction t2Q teste la condition (T2) seule.

Cas n premier :

tileQ[A_] /; PrimeQ[Length[A]] :=
     Module[{p = Length[A]},
       If[(Mod[fromBasicForm[A], p]//Sort) == Range[0, p - 1],
         p, 0]]
tileQ[{1}]=1;

         (* c' était le cas premier, équiréparti *)

tileQ[{2,2,2,2,2}]

Cas d'une puissance de nombre premier (la condition (T1) est une CNS)

primePowerQ[n_Integer]/;n>0 := (Length[FactorInteger[n]] == 1)

tileQ[A_] /;primePowerQ[Length[A]]:=
		Module[{indCyclo, listeDiv, sA={},
           		Apol = Plus@@(x^fromBasicForm[A])},
           		
           		listeDiv = FactorList[Apol]//Transpose;
           		
           		(* vérification : et si il y avait 
           		des facteurs multiples ? *)
           		      		
           		If[Union[listeDiv[[2]] ] ≠ {1},
           			(* alors ça se gâte *)
           			listeDiv = 
           			Module[{n=Length[First[listeDiv]]},
           			{
           			Table[Table[listeDiv[[1,k]], 
           							{listeDiv[[2,k]]}],          	
           						{k,n}]//Flatten,
           			Table[1,  {Plus @@ listeDiv[[2]]}]
           			}
           			]
           				
           		];	(* fin de l'interlude ! *)
           		
           		indCyclo = Select[recog /@ First[listeDiv], #>0&];
           		
           		sA = Select[indCyclo, primePowerQ];
           		If[sA=={}, Return[0]];
           		
           		If[(Times @@ 
           		Map[First, FactorInteger/@ sA ,{2}]//First
           			)==Length[A], 
           				Max[sA], 0]
           	]

tileQ[{3,3,3,3}]
tileQ[{1,3,1,3}]

pouah = randomCanonFromList[{3,3,3,3}]
pp[fromBasicForm@{3,3,3,3},fromBasicForm@ pouah];
recogListe[pouah]//Union

Cas restants: au moins deux facteurs premiers.

primePowerQ[n_Integer]/;n>0 := (Length[FactorInteger[n]] == 1)

tileQ[A_]:=
		Module[{indCyclo, listeDiv, sA={},prodDesA,
           		Apol = Plus@@(x^fromBasicForm[A])},
           		
           		listeDiv = FactorList[Apol]//Transpose;
           		
           		(* vérification : et si il y avait 
           		des facteurs multiples ? *)
           		      		
           		If[Union[listeDiv[[2]] ] ≠ {1},
           			(* alors ça se gâte *)
           			listeDiv = 
           			Module[{n=Length[First[listeDiv]]},
           			{
           			Table[Table[listeDiv[[1,k]], 
           							{listeDiv[[2,k]]}],          	
           						{k,n}]//Flatten,
           			Table[1,  {Plus @@ listeDiv[[2]]}]
           			}
           			]
           				
           		];	(* fin de l'interlude ! *)
           		
           		indCyclo = Select[recog /@ First[listeDiv], #>0&];
           		
           		sA = Select[indCyclo, primePowerQ];
           		If[sA=={}, Return[0]];
           		
           		(* on peut maintenant tester (T1): *)
           		
           		If[(
           		(Times @@ 
           		Map[First, FactorInteger/@ sA ,{2}]//First
           			)==Length[A] && 
           				
           		(* dans ce cas on va tester (T2) *)	
          			
        (
        prodDesA = Outer[Times, sA, sA];
        Do[prodDesA[[k,k]]=0,{k, Length[sA]}];                  
        prodDesA = Drop[ Union[Flatten[prodDesA]], 1];           
        prodDesA = Select[prodDesA, !primePowerQ[#]&];
        
        (* tous les produits de facteurs de la forme p^α,
			 sauf leurs carrés et les facteurs p^α eux-mêmes *)
                      
                  prodDesA ⋂ indCyclo == prodDesA
                  	) 
                  ),
                  
                  (* fin de (T1) && (T2) *)

           			LCM @@ sA	
           		(* sinon c'est que ça veut pas *)
           				, 0]
		]

tileQ[A]

une vieille version.

(* vieille implémentation *)

tileQ[A_] :=
       Module[{listeDiv, indCyclo, sA,
           		Apol = Plus@@(x^fromBasicForm[A]) ,
           		
      (* ceci fait un polynôme à partir de la 'basicForm' A *)
           		
           		foo, prodDesA},
           		
           listeDiv = FactorList[Apol];
           
    listeDiv =
            Map[Table[First@#, {Last@#}]&, listeDiv] // Flatten;
            
			(* cela donne la liste des facteurs 
    		  comptés avec leur multiplicité *)
           
    If[MemberQ[listeDiv, 1],
               listeDiv = Drop[listeDiv, 1]];
               
               (* on vire le "facteur" 1 éventuel *)
             
    indCyclo =  recog /@ listeDiv // Sort;
    
    (* liste des indices des polynômes cyclotomiques présents *)
             
    sA = Select[indCyclo, primePowerQ];
    
     (* liste des p^m dans les indices précédents *)
             
    If[	And[
        			(* condition  (T1)  *)
                 
        foo = FactorInteger[#] [[1, 1]]& /@ sA;       
        
       	 (* liste des nombres PREMIERS dont 
       	    les puissances sont dans sA *)
         
         (Length[A] ==  (Times @@ foo) ),
                
                  (* Condition  (T2)  *)
                  
        prodDesA = Outer[Times, sA, sA];
        Do[prodDesA[[k,k]]=0,{k, Length[sA]}];                  
        prodDesA = Drop[ Union[Flatten[prodDesA]], 1];
                  
        prodDesA = Select[prodDesA, !primePowerQ[#]&];
        (* tous les produits de facteurs de la forme p^m,
			 sauf leurs carrés et les facteurs p^z  *)
                      
                  prodDesA ⋂ indCyclo == prodDesA

         	(* est-ce que tout élément de prodDesA 
         		est bien dans indCyclo ? *)
                     ],
           LCM @@ sA, 
           0]	
     ]

La procédure pour tester (T2) seule.

t2Q[basicform_] := Module[
	{prodDesA,  sA,  indCyclo},
indCyclo  =  Select[recogListe[basicform],  # > 0 &];
sA  =  
              Select[indCyclo,  primePowerQ];
prodDesA = Outer[Times, sA, sA];
prodDesA = Select[prodDesA, ! primePowerQ[#] &];

  
subsetQ[prodDesA, 
              indCyclo]
]

t2Q[{0, 1, 4, 5, 8, 9, 12, 13}]

t2Q[{1, 4, 1, 6, 13, 4, 7, 6, 6, 1, 4, 19}]

t2Q /@ complete[{1, 4, 1, 6, 13, 4, 7, 6, 6, 1, 4, 19}]

Compléter une tuile en canon : méthode Montecarlo.

code

\(\(\(randomCanonFromList[li_, \ 
        persévère_:  
          50]\ \  := 

Module[
{mod, 
          A, \ 
		 (*\ 
            mise\ à\ zéro\ *) 		
n\  = \ 
            0, \ B, \ \ try, \ 
          aPlusB, \ \ tooLong\ \  = \ \ 0}, \ 
mod\  = \ 
          Plus\  @@ \ li; 
A\ \  = \ 
          fromBasicForm[
            li]; 
B\  = \ {0}; 
\ \ \ \ \ \ \ aPlusB\  = \ 
          A; \ \ \ \ 
diffSetA\ \  = \ \(Table[
                A[\([i]\)]\  - \ 
                  A[\([j]\)], 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {i, \ \ Length[
                    A]}, \ \ {j, 
                  Length[A]}
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ ]\  // \ 
              Flatten\)\ \  // Union; \ \ \ \ \ \ \ \ \ 

        While[
\ \ \ \ \ \ \ \ \ Length[aPlusB]\  < \ 
            mod, \ \ \ \ \ \ \ \ \ 
While[
\ \ \ \ \ \ \ \ \ \ \ try\  = \ 
              Mod[n\  + \ A, \ \ mod]; \ 
\ \ \ \ \ \ \ \ \ \ \ Intersection[
                try, aPlusB]\  != \ {}, \ 
n\  = \ 
              Random[Integer, \ \ {1, 
                  mod - 1}]; \ 
\ \ \ \ \ \ \ \ \ \ \(tooLong++\)\ ; \ 
\ \ \ \ \ \ \ \ \ \ \ If[
              tooLong\  > \ 
                persévère×\ 
                  mod\ , 
\ \ \ \ \ \ \ \ \ \ \ Return[
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ throwInTheTowel]]\ \ 
\ \ \ \ \ \ \ \ \  (*\ 
              random\ increment\ of\ \ n\ *) \ 
\ \ \ \ \ \ \ \ \ ]; 
\ 		AppendTo[
            B, \ \ n]; \ 
\ \ \ \ \ \ \ \ \ aPlusB\ \  = \ 
            Union[aPlusB, \ 
              try]
\ ]; 
\ \ \ \ \ \ \ basicForm[
          Sort[B], \ mod]
]\)\(
\)
    \)\)

Compléter une tuile en canon : méthode exhaustive.

subsetQ[ partie_,  univers_]  :=  
        And  @@  (MemberQ[univers, #] &  /@  partie)

complete[tile_,  debug_:  0] :=
Module[
  \({n\  = \ Plus\  @@ \ tile, \ 
            motif\  = \ fromBasicForm[tile]\ , lePlein, 
	
            listeDesSoluces\  = \ {}, \ continue, 
            recordmanDuMonde\ , 
	fooRtoo, \ hardiPetit}\),

lePlein = Range[0, n - 1];
recordmanDuMonde  =  
              n  -  Length[tile];
  

(*  définition INTERNE de la procédure continue  

premier cas  :  
                      y reste pu rin à compléter, on a gagné une soluce *)
continue[fait_,  {},  offsets_,  
                plusGdIntervalle_] :=
 If[(! MemberQ[listeDesSoluces,  offsets]),
			AppendTo[listeDesSoluces,  offsets];
	  		
	\(recordmanDuMonde\  = \ 
                      Min[recordmanDuMonde, 
						Max[
							Max[
                            Drop[offsets, 1]\  - \ 
                              Drop[offsets, \(-1\)]], 
								n - Last[offsets]\ ]
						]\);
		If[\(debug ≠ 0, 	
                      Print[offsets, " ", \ recordmanDuMonde]\)  ]
				
					];
 
  

continue[fait_,  reste_,  offsets_, 
                plusGdIntervalle_] :=
 	Scan[
	If[subsetQ[fooRtoo = Mod[# + motif, n], 
                            reste] && 
  
		(# - offsets[[-1]] ≤ 
                              Min[plusGdIntervalle,  recordmanDuMonde])  ,

			(* débug  Print[
                                offsets,  fait,   reste]; *)
		continue[Union[fait, {#}],
				Complement[reste, fooRtoo ],
				Append[offsets , #],
				If[Length[offsets] == 1,n,
					Min[Max[
                                        Drop[offsets, 1] - 
                                        Drop[offsets, -1]],
					recordmanDuMonde ]
					  
				]
			]    
		]&, 
			Reverse[
                    reste  ⋂  
                      Range[1 + Max[offsets], n] ]]; 

  

		(*  appel récursif initial de la procédure continue  
		pour explorer toutes les branches de l'arbre *)
		continue[motif, Complement[lePlein, motif], {0}, 
              recordmanDuMonde] ;

		(basicForm[#, n] &  /@   listeDesSoluces) // 
              Union
]

Compléter modulo p

\(completeModulo[tile_, \ 
        p_]\  := 
Module[
{A, \ 
          facteurs, \ degrés, \ 
          n}, 
A\  = \ \((x - 1)\)*
            Plus\  @@ \ \(x\^tile\); 
facteurs\  = \ 
          FactorList[A, \ 
            Modulus -> p]; 
degrés\  = \ 
          Drop[Map[{p\^Exponent[First[#], x] - 1, \ 
                  Last[#]} &\ , 
	\ facteurs], \ 
            1]; 
n = 
          LCM[Sequence\  @@ 
                First[Transpose[degrés]]]×
\ 
            p\^Max[Sequence\  @@ Last[Transpose[degrés]]]; 
facteurs = 
          Drop[Divisors[n], 1]; 

 (*\ 
          cherchons\ à\ minimiser\ n\ *) 

n = 
          Min[Select[facteurs, \ 
              PolynomialQ[
Cancel[\(x\^# - 1\)\/A, \ 
                    Modulus -> p], \ 
                  x] &]]; 
{\((Expand[
                  Cancel[\(x\^n - 1\)\/A, \ Modulus -> p], \ 
                  Modulus -> p] //. 
                u_Integer*x\^k_ -> \((u - 1)\) x\^k + x\^\(k + n\))\) // 
            polyToCanon, \ n}
]\)

Palindromicité

palindromeQ [
        tile_]  :=  (Join[{Last[tile]}, 
            Drop[tile, -1]])  ==  Reverse[tile]