# FICHIER : turingmalpleter.txt

# ALAIN COLMERAUER,
# 4 MAI 2002

# EXEMPLES DE MACHINES DE TURING

# La syntaxe générale est
# [instruction, ... , instruction]
# ou
# [état-initial, [instruction, ... , instruction]]
# ou
# [état-initial, [instruction, ... , instruction],[état,...,état]]
# Lorsque l'état initial n'est pas spécifié, c'est le premier
# état de la première instruction

# Chaque instruction est de la forme
# [état,symbole,symbole,état,direction]
# où direction est égal à -1 ou +1, suivant qu'on déplace la tête
# à gauche ou à droite

# Somme de deux entiers codés par des batons.
# L'alphabet est {i,u}.

somme := [
[q0,i,i,q0,+1], [q0,u,i,q1,-1],
[q1,i,i,q1,-1], [q1,u,u,q2,+1],
[q2,i,u,q3,+1]
]:

# Machine vide.
# L'alphabet est un sous-ensemble de {o,i,u}.

machinevide := [q0,[]]:

# Echange des o avec les i dans dans un mot sur {o,i}.
# L'alphabet est {o,i,u}.

complement := [
[q0,o,i,q0,+1],[q0,i,o,q0,+1],[q0,u,u,q1,-1],
[q1,o,o,q1,-1],[q1,i,i,q1,-1],[q1,u,u,q2,+1]
]:


# Dupliquation d'un mot.
# L'alphabet est {o,i,u}.

copie := [
[q0,u,u,q7,+1],   [q0,o,o,q1,+1],   [q0,i,i,q1,+1],
[q1,u,u,q6,-1],   [q1,o,u,q2o,+1],  [q1,i,u,q2i,+1],
[q2o,u,u,q3o,+1], [q2o,o,o,q2o,+1], [q2o,i,i,q2o,+1],
[q2i,u,u,q3i,+1], [q2i,o,o,q2i,+1], [q2i,i,i,q2i,+1],
[q3o,u,o,q4o,-1], [q3o,o,o,q3o,+1], [q3o,i,i,q3o,+1],
[q3i,u,i,q4i,-1], [q3i,o,o,q3i,+1], [q3i,i,i,q3i,+1],
[q4o,u,u,q5o,-1], [q4o,o,o,q4o,-1], [q4o,i,i,q4o,-1],
[q4i,u,u,q5i,-1], [q4i,o,o,q4i,-1], [q4i,i,i,q4i,-1],
[q5o,u,o,q1,+1],  [q5o,o,o,q5o,-1], [q5o,i,i,q5o,-1],
[q5i,u,i,q1,+1],  [q5i,o,o,q5i,-1], [q5i,i,i,q5i,-1],
[q6,u,u,q7,+1],   [q6,o,o,q6,-1],   [q6,i,i,q6,-1],
[q7,u,u,q10,-1],  [q7,o,o,q8o,+1],  [q7,i,i,q8i,+1],
[q8o,u,o,q9,-1],  [q8o,o,o,q8o,+1], [q8o,i,i,q8o,+1],
[q8i,u,i,q9,-1],  [q8i,o,o,q8i,+1], [q8i,i,i,q8i,+1],
[q9,u,u,q10,+1],  [q9,o,o,q9,-1],   [q9,i,i,q9,-1]
]:

# Exemples d'exécutions

# sur(somme,iiiuiiii); 
#     - calcule le mot  iiiiiii

# sur(copie,ioiioi);
#     - calcule le mot  ioiioiioiioi

# sur(sommebinaire,ioiziiiiii);
#     - calcule le mot  ooioooi

# sur(somme,[q0,i,iiiuii]);
#     - execute "somme" a partir de la configuration
#       [q0,i,iiiuii].

# sur(somme,iiiuii,3..12]);
#     - execute "somme" a partir de la configuration
#       [q0, ,iiiuii],
#     - numerote toutes les configurations et imprime
#       celles qui ont
#       - des numeros égaux compris entre 3 et 12,
#     - imprime toujours la configuration initiale
#       et la derniere.

# sur(somme,[q0,i,iiiuii],3..12,[q1,i],[q2,u]);
#     - execute "somme" a partir de la configuration
#       [q0,i,iiiuii],
#     - numerote toutes les configurations et imprime
#       celles qui ont
#       - des numeros compris entre 3 et 12,
#       - des couples (etat, symbole lu) dans {(q1,i),(q2,u)},
#     - imprime toujours la configuration intiale
#       et la derniere.

# beau(copie); imprime le programme copie avec une belle présentation.


# SOUS-PROGRAMMES MAPLE POUR
# TESTER LES MACHINES DE TURING

# VARIABLES GLOBALES

# o, symbole possible
# i, symbole possible
# z, symbole possible
# u, symbole possible
# cout, option pour calculer le nb d'opérations différentes exécurtées
# nbinstructions, nb d'instructions exécutées
# tronquer, si éggal à true, les configuration imprimées sont tronquées à 2 fois moitie.

# moitie, 

initialiser :=
proc()
   global o,i,z,u,infini,cout,tronquer,moitie;
   unprotect('o','i','u','z','infini','cout','moite');
   o := evaln(o);
   i := evaln(i);
   z := evaln(z);
   u := evaln(u);
   cout := evaln(cout);
   infini := 100000000;
   tronquer := false;
   moitie := 20; 
   protect('o','i','u','z','infini','cout','moite');
   `L'alphabet doit être un sous-ensemble de {i,o,u,z}.`
end:

initialiser();

# alphabet     ensemble de symboles utilisés
# blanc,       le symbole choisi comme blanc 
# nbsymboles,  nombre de symboles,
# noblanc,     son numero compris entre 0 et nbsymboles-1
# nosymbole[s] le numéro du symbole s
# symbole[i]   le symbole numéro i

fixeralphabet :=
proc(a,b)
  global alphabet,blanc,nbsymboles,noblanc,nosymbole,symbole;
  local j;
  unprotect(blanc);
  alphabet := NULL; blanc := b; nbsymboles := length(a);
  nosymbole := evaln(nosymbole); symbole := evaln(symbole);
  for j from 0 to nbsymboles-1 do
     symbole[j] := substring(a,j+1);
     nosymbole[substring(a,j+1)] := j;
     alphabet:=alphabet,symbole[j]
  od;
  noblanc := nosymbole[blanc];
  alphabet := {alphabet};
  protect(blanc);
  `Du fait qu'on a exécuté`, `fixeralphabet`.`(`.a.`,`.b.`)`, 
  `l'alphabet est`, alphabet,  avec,
  blanc, `jouant le rôle du blanc.`
end:

# Initialisations par défaut à un alphabet de 3 symboles

fixeralphabet(oiu,u);

# Pour passer à quatre symboles avec u comme blanc faire
# fixeralphabet(oizu,u);

# Pour passer à deux symboles i,u avec u comme blanc faire
# fixeralphabet(iu,u);

# LA MACHINE

# Variables globales
# pp,       position de la tete de lecture ecriture
# pp1,      min entre pp et position de la case non vide la plus à guauche
# pp2,      max entre pp et position de la case non vide la plus à droite
# zq,       etat codé de la machine, un entier compris entre 0 et m-1
# case[i], contenu de la case en position i
# nbinstructions, nombre d'instructions exécutées
miruban := 3000:
case := array(-miruban...miruban):

# LE PROGRAMME CODE

# Mm, matrice de transition de dimension mx3

# LE PROGRAMME SOURCE

# etat[n],   numero de l'etat nommé n, vaut nbetats+1 pour l'etat final
# noetat[i], nom de l'état numero i

configurer :=
proc(c)
   global pp1,pp,pp2,case,zq,nosymbole,noetat,nbsymboles,blanc;
   local b,x,y,j;
   zq := (noetat[c[1]]-1)*nbsymboles;
   x := c[2];
   y := c[3];
   pp1 := 1-length(x);
   pp := 1;
   pp2 := length(y);
   for j from 1 to length(x) do
      case[j-length(x)] := nosymbole[substring(x,j)]
   od;
   for j from length(y) by -1 to 1 do
      case[j] := nosymbole[substring(y,j)]
   od;
   while case[pp1]=nosymbole[blanc] and  pp1<>pp do pp1:=pp1+1 od;
   while case[pp2]=nosymbole[blanc] and  pp2<>pp do pp2:=pp2-1 od
end:

configuration :=
proc()
   global pp1,pp,pp2,case,zq,nbsymboles,symbole;
   local Q,x,y,j;
   Q := etat[zq/nbsymboles+1];
   x:= [seq(symbole[case[j]],j=pp1..pp-1)];
   y := [seq(symbole[case[j]],j=pp..pp2)];
   [Q,tronc(fusion(x)),tronc(fusion(y))]
end:

resultat :=
proc()
   global symbole,case,pp,pp2;
   fusion([seq(symbole[case[j]],j=pp..pp2)])
end:

tronc :=
proc(x)
   global moitie,tronquer;
   local n,y;
   if not tronquer then y:=x else
      n := length(x);
      if length(x) > 2*moitie then
         y := cat(substring(x,1..moitie),cat(`-`,substring(x,n+1-moitie..n)))
      else
         y := x
     fi;
  fi;
  y
end:

fusion :=
proc(s)
   local j;
   convert([seq(convert(s[j],bytes)[1],j=1..nops(s))],bytes) 
end:

machinecomplete :=
proc(X)
   local q,M,qs;
   if X=[] then
      print(`Votre machine est une liste vide.`);
      explications(); RETURN(ERREUR)
   fi;
   if not type(X,list) then
      print(`Votre machine n'est pas une liste.`);
      explications(); RETURN(ERREUR)
   fi;
   if type(X[1],list) then
      q:=X[1][1]; M:=X; qs:=[]
   else
      q:=X[1]; 
      if nops(X)=2 then
         M:=X[2]; qs:=[]
      elif nops(X)=3 then
         M:=X[2]; qs:=X[3]
      else
         print(`Votre machine comporte trop ou pas assez d'éléments.`);
         explications(); RETURN(ERREUR)
      fi
   fi;
   [q,M,qs]
end:

explications :=
proc()
   print(`La syntaxe de votre machine doit être de l'une des trois forme :`);
   print(`[instruction, ... , instruction],`);
   print(`[état-initial, [instruction, ... , instruction]],`);
   print(`[état-initial, [instruction, ... , instruction],[état,...,état].`)
end:

code1 :=
proc(X)
   global noetat,nbsymboles,etat,etatfinal,nosymbole;
   local qzero,M,Y,qs,qq,R,j,jp,k,m,n,c,erreur;
   erreur := false;
   noetat := evaln(noetat);
   qs := NULL;
   etat := evaln(etat);
   n := 0;
   Y := machinecomplete(X);
   if Y=ERREUR then RETURN(ERREUR) fi;
   qzero:=Y[1]; M:=Y[2]; etat:=Y[3];
   if not type(etat,list) then
      print(etat, `devrait être une liste d'états.`); RETURN(ERREUR)
   fi;
   for j from 1 to nops(etat) do
      qq := etat[j];
      if not (type(qq,'string') or type (qq,'name')) then
         print(`L'état`,qq,`figurant dans la liste d'états`,
         `n'est pas un identificateur.`); erreur:=true
      else protect(qq) fi;
      if(not assigned(noetat[qq])) then qs:=qs,qq; n:=n+1; noetat[qq] := n fi;
   od;
   if not type(M,list) then
      print(M, `devrait être une liste d'instructions.`); RETURN(ERREUR)
   fi;
   for j from 1 to nops(M) do
      if not nops(M[j])=5 then
         print(M[j], `devrait être une liste de 5 éléments.`); erreur:=true;
         next
      fi;
      qq := M[j][1];
      if not (type(qq,'string') or type (qq,'name')) then
         print(`Dans l'instruction`, M[j], `le premier état`, qq,
         `n'est pas un identificateur.`); erreur:=true
      else protect(qq) fi;
      if(not assigned(noetat[qq])) then qs := qs,qq; n:=n+1; noetat[qq]:=n fi;     
      if not member(M[j,2],alphabet) then
         print(`Dans l'instruction`, M[j], `le premier symbole`, M[j,2],
         `devrait appartenir à`, alphabet); erreur:=true
      fi;
      if not member(M[j,3],alphabet) then
         print(`Dans l'instruction`, M[j], `le deuxième symbole`, M[j,3],
         `devrait appartenir à`, alphabet); erreur:=true
      fi;
      if not member(M[j,5],{-1,1}) then
         print(`Dans l'instruction`, M[j], `la direction`, M[j,5],
         `devrait être -1 ou +1.`); erreur:=true
      fi;       
   od;
   m := nbsymboles*n; 
   for j from 0 to nops(M) do
      if j = 0 then
         qq := qzero
      elif nops(M[j])=5 then
         qq := M[j][4]
      else next fi;
      if not (type(qq,'string') or type (qq,'name')) then
          if j=0 then
             print(`L'état initial`,qq,`n'est pas un identificateur.`);
             erreur:=true
          else
             print(`Dans l'instruction`, M[j],`le deuxième état`,qq,
             `n'est pas un identificateur.`); erreur:=true
          fi;
      else protect(qq) fi;
      if not assigned(noetat[qq]) then qs := qs,qq; n:=n+1; noetat[qq]:=n fi
   od;
   if erreur then RETURN(ERREUR) else fi;
   etat := [qs];
   R := array(1..m,1..3);
   for j from 1 to m do
      R[j,1]:=0; R[j,2] := -1; R[j,3] := 0
   od;
   for j from 1 to nops(M) do   
      jp:= nbsymboles*(noetat[M[j,1]]-1)+1+nosymbole[M[j,2]];
      R[jp,1] := nosymbole[M[j,3]];
      R[jp,2]:= M[j,5];
      if assigned(noetat[M[j,4]]) then
         R[jp,3] := nbsymboles*(noetat[M[j,4]]-1)
      else
         R[jp,3] := m
      fi;
   od;
   [eval(noetat[qzero]-1)*nbsymboles,eval(R)]
end:

beaudecode1 :=
proc(X)
   global noetat,nbsymboles,etatfinal,symbole,etat;
   local l,R,T,j,k,m,qzero,q1,q2,s1,s2,d;
   if X=ERREUR then RETURN(ERREUR) fi;
   qzero := etat[eval(X[1]/nbsymboles)+1]; 
   R := X[2]:
   m := op(2,op(2,eval(R))[1]);
   m := m/nbsymboles;
   T := array(1..m,1..nbsymboles);
   for j from 1 to m do
   for k from 1 to nbsymboles do
      l := (j-1)*nbsymboles+k;
      q1 := etat[j];
      s1 := symbole[k-1];
      s2 := symbole[R[l,1]];
      q2 := etat[R[l,3]/nbsymboles+1];
      d := R[l,2];
      T[j,k] := [q1,s1,s2,q2,d]
   od od;
   qzero,eval(T)
end:

decode1 :=
proc(X)
   global nbsymboles;
   local Y,Z,j,M,m,k;
   if X=ERREUR then RETURN(ERREUR) fi;
   Z := [beaudecode1(X)];   
   Y := Z[2];
   m := op(2,op(2,eval(Y))[1]);
   M := NULL; 
   for j from 1 to m do
   for k from 1 to nbsymboles do
      M := M,Y[j,k];
   od od;
   [Z[1],[M]]
end:

sur :=
proc()
   global etat,nbsymboles;
   local C,X,x,j,P,r,E;
   X := args[1]; x:= args[2];
   C := code1(X);
   if C=ERREUR or x=ERREUR then RETURN(ERREUR) fi;
   if type(x,`string`) or type(x,`name`) then 
      configurer([etat[C[1]/nbsymboles+1],``,x])
   else
      configurer(x)
   fi;
   E := lesoptions([seq(args[j],j=3..nargs)]); 
   r := iterationmachine(C[2],E);
   if r = ERREUR then RETURN(ERREUR) fi;
   resultat()
end:

lesoptions :=
proc(x)
  global nbsymboles,noetat,infini,cout;
  local enplus,compter,imprimer,arreter,pasencore,
  j,n1,n2,Q,u;
  enplus := false;
  imprimer := []; n1 := 0; n2 := infini; Q := NULL;
  compter := false;
  arreter := [];
  pasencore := true;
  for j from 1 to nops(x) do
     u := x[j];
     if u=cout then
        enplus := true;
        compter := true 
     elif type(u,list) and nops(u)=1 then
        enplus := true; 
        arreter := (noetat[u[1]]-1)*nbsymboles    
     elif type(u,list) and nops(u)=2 then
        enplus := true;
        Q:=Q,(noetat[u[1]]-1)*nbsymboles+nosymbole[u[2]];
        imprimer := [n1,n2,{Q}];
     elif type(u,range) then
        enplus := true;
        n1:=op(1,u); n2:=op(2,u);
        imprimer := [n1,n2,{Q}]
     fi;         
   od;
   [enplus,compter,imprimer,arreter,pasencore]
end:


iterationmachine :=
proc(M,E)
   global miruban,nbinstructions,zq,case,pp1,pp,pp2,noblanc,Xx,nbsymboles;
   local enplus,compter,imprimer,arreter,pasencore,
   d,m,oldq,j;
   enplus:=E[1]; compter:=E[2]; imprimer:=E[3]; arreter:=E[4]; pasencore:=E[5];  
   m := op(2,op(2,eval(M))[1]);
   nbinstructions := 0;
   if compter then
      Xx := array(1..nbsymboles*m);
      for j from nbsymboles*m by -1 to 1 do Xx[j] := 0 od
   fi;
   do 
      if enplus then
         if imprimer <> [] then impression(m,imprimer) fi;
         if compter then if nbinstructions <> 0 then
               Xx[nbsymboles*(oldq-1)+case[pp]+1] := Xx[nbsymboles*(oldq-1)+case[pp]+1]+1
         fi fi;
         if arreter <> [] then if zq=arreter then
            if pasencore then pasencore:=false else break fi
         fi fi
      fi;
      if zq >= m then break fi;
      zq := zq+case[pp]+1;
      case[pp] := M[zq,1];
      d := M[zq,2];
      if pp = pp1 then
         if d=-1 then
            if pp1=-miruban then
               print(`Vous allez trop à gauche du ruban.`);
               RETURN(ERREUR)
            else pp1:=pp1-1 fi;
            case[pp1]:=noblanc
         elif case[pp]=noblanc then pp1:=pp1+1 fi
      fi;
      if pp = pp2 then
         if d=+1 then
            if pp2=miruban then
               print(`Vous allez trop à droite du ruban.`);
               RETURN(ERREUR)
            else pp2:=pp2+1 fi;
            case[pp2]:=noblanc
         elif case[pp]=noblanc then pp2:=pp2-1 fi
      fi;
      pp := pp+d;
      oldq := zq;
      zq := M[zq,3];
      nbinstructions := nbinstructions+1
   od;
   bon
end:

impression :=
proc(m,b)
   global case,nbinstructions,zq,pp;
   local n,n1,n2,Q;
   n := nbinstructions;
   n1 := b[1]; n2 := b[2]; Q := b[3];
   if n=0 or n=n2 or zq>=m
   or (n >= n1 and (Q={} or member(zq+case[pp],Q))) then
      print(n,configuration())
   fi;
   if n=n2 then zq:=m fi;
end:

code2 := 
proc(X)
   local R,k,j,l,x,m,lgm;
   R:=eval(X[2]);
   m := op(2,op(2,eval(R))[1]);
   lgm := ceil(evalf(log[2](m+1)));
   x := u,u;
   for j from m by -1 to 1 do
      if R[j,2]=-1 then x := x,o else x := x,i fi;
      if R[j,1]=0 then x := x,o,o else
         if R[j,1]=1 then x := x,i,o else x := x,o,i fi
      fi;
      if R[j,3] >= m then
         x := x,seq(i,l=1..lgm)
      else
         k := R[j,3];
         while k <> 0 do
            if type(k,even) then x := x,o else k:=k-1; x:=x,i fi;
            k := k/2
         od
      fi;
      x := x,u 
   od;
   x := x,u,o,o,o;
   k:=X[1];
   for j from 1 to lgm do
      if type(k,even) then x := x,o else k:=k-1; x:=x,i fi;
      k := k/2
   od;
   x := x,i,u;
   fusion([x])
end:

decode2 :=
proc(x)
   local noqzero,R,j,k,l,m,mbis;
   m := 0;
   l := 3;                                               
   while substring(x,l)<>u do
      while substring(x,l)<>u do l:=l+1 od;
      m:=m+1; l:=l+1; 
   od;
   l:=l+4;
   noqzero:=0;
   k:=1;
   while substring(x,l+1) <> u do
      if substring(x,l) = i then noqzero:=noqzero+k fi;
      k := 2*k; l := l+1
   od;
   mbis := 2^(ceil(evalf(log[2](m+1))))-1;
   R := array(1..m,1..3);
   l := 3;   
   for j from m by -1 to 1 do
      if substring(x,l) = o then R[j,2] := -1 else R[j,2] := 1 fi;
      l := l+1;
      if substring(x,l) = i then R[j,1] := 1 else
         if substring(x,l+1) = o then R[j,1] := 0 else R[j,1] := 2 fi
      fi;
      l := l+2;
      R[j,3] := 0;
      k := 1;
      while substring(x,l) <> u do
         if substring(x,l) = i then R[j,3]:=R[j,3]+k fi;
         k := 2*k; l := l+1
      od;
      l := l+1;
      if R[j,3] = mbis then R[j,3]:=m fi
   od;
   [noqzero,eval(R)]
end:

code :=
proc(M)
   code2(code1(M))
end:

decode :=
proc(x)
   decode1(decode2(x))
end:

beaudecode :=
proc(x)
   beaudecode1(decode2(x))
end:

beau := proc(X) beaudecode1(code1(X)) end: