{*
 * @(#) turing.pas - Program for modeling Turing Machine.
 * (c) 1994 Ivan Maidanski <ivmai@chat.ru> http://ivmai.chat.ru
 * Freeware program source. All rights reserved.
 **
 * Language: Turbo Pascal
 * Tested with: Turbo Pascal v7.0
 * Last modified: 1994-11-22 15:50:00 GMT+03:00
 *}

program TuringTask;

{ Usage comments: The rules are stored in the 'R' constant }

uses Crt;
const R: array[1..3]
           of record
                K: Char;
                P: array[1..8]
                     of record
                          C: Char;
                          M: -1..1;
                          St: Byte
                        end
              end
        = ((K: ' '; P: ((C: ' '; M: 0; St: 0),
                        (C: ' '; M: -1; St: 4),
                        (C: ' '; M: -1; St: 5),
                        (C: ' '; M: 0; St: 0),
                        (C: ' '; M: 0; St: 0),
                        (C: ' '; M: 1; St: 7),
                        (C: ' '; M: 0; St: 0),
                        (C: ' '; M: 0; St: 0))),
           (K: 'p'; P: ((C: 'p'; M: 1; St: 2),
                        (C: 'p'; M: 1; St: 2),
                        (C: 'p'; M: 1; St: 3),
                        (C: 'p'; M: -1; St: 8),
                        (C: 'q'; M: -1; St: 6),
                        (C: 'p'; M: -1; St: 6),
                        (C: 'q'; M: -1; St: 8),
                        (C: 'p'; M: -1; St: 8))),
           (K: 'q'; P: ((C: 'q'; M: 1; St: 3),
                        (C: 'q'; M: 1; St: 2),
                        (C: 'q'; M: 1; St: 3),
                        (C: 'p'; M: -1; St: 6),
                        (C: 'q'; M: -1; St: 8),
                        (C: 'q'; M: -1; St: 6),
                        (C: 'p'; M: -1; St: 8),
                        (C: 'q'; M: -1; St: 8))));
var S: String;
var P,St: Byte;
procedure Init;
 begin
   ClrScr;
   WriteLn;
   Write('Enter String: ');
   ReadLn(S);
   P:=1;
   St:=1
 end;
procedure Error(N: Byte);
 begin
   WriteLn;
   Write(' Error: ');
   case N of
     1: Write('Unknown symbol');
     2: Write('Invalid reference');
     3: Write('Tape overflow')
   end;
   WriteLn('!');
   Halt(1)
 end;
procedure SearchKey(var N: Byte);
 begin
   N:=Low(R);
   while (N<High(R)) and (S[P]<>R[N].K)
     do Inc(N);
   if S[P]<>R[N].K
     then Error(1)
 end;
procedure TestBorder;
 begin
   if (P>High(S)) or ((P=0) and (Length(S)=High(S)))
     then Error(3);
   if P=0
     then begin
            S:=' '+S;
            P:=1
          end;
   if P>Length(S)
     then S:=S+' '
 end;
procedure DoStep;
 var N: Byte;
 begin
   SearchKey(N);
   if St>High(R[N].P)
     then Error(2);
   S[P]:=R[N].P[St].C;
   Inc(P,R[N].P[St].M);
   TestBorder;
   St:=R[N].P[St].St
 end;
procedure Wait;
 var C: Char;
 begin
   Delay(100);
   C:=ReadKey
 end;
procedure ShowWork(N: Word);
 var X,Y: Byte;
 begin
   GotoXY(1,5);
   ClrEol;
   WriteLn('Step: ',N);
   ClrEol;
   WriteLn('State: ',St);
   ClrEol;
   Write('Word: ');
   X:=WhereX;
   Y:=WhereY;
   WriteLn(S);
   GotoXY(X+Pred(P),Y);
   Wait
 end;
procedure Run;
 var N: Word;
 begin
   N:=0;
   repeat
     DoStep;
     Inc(N);
     ShowWork(N)
   until St=0
 end;
procedure Done;
 begin
   Delete(S,1,P);
   P:=Pos(' ',S);
   if P>0
     then Delete(S,P,Succ(Length(S)-P));
   WriteLn;
   WriteLn('Result: ',S);
   WriteLn;
   Wait
 end;
begin
  Init;
  Run;
  Done
end.