(*  Copyright information          (c) 2000 Mark L. Irons  *)

(*  Runs the universal Turing machine defined in Hopcroft
    & Ullman's "Formal Languages and their Relation to
    Automata", 1969 edition.

    There is an associated file, "states.utm", that contains
    the state table of the universal Turing machine.  It
    must be in the same directory as the executable version
    of this program.

    Input is an encoded Turing machine and data.  These
    should be in a file called "emulated.tm".

    For more information, see
    http://www.rdrop.com/~half/General/UTM/

    And yes, I know the code is a mess, but I just wanted
    to get this silly little project done and out the
    door as quickly as possible!
*)

program utm;

type
  transition = record
                 null      : boolean;
                 nextState : integer;
                 output    : char;
                 direction : char;
               end;
  rawTransitionString = string[6];
  state               = array[1..12] of transition;
  rawLine             = string[255];
  transLookupString   = string[6];

var
  states         : array[1..40] of state;
  emulatedTM     : string[255];
  markedCells    : string[255];
  transLookup    : transLookupString;


(* Debugging utilities *)

procedure DumpTransition(trans: transition);
var
   outs : string[12];
   v    : string[6];
begin
  outs := '';
  if trans.null = true then
    outs := '-   '
  else begin
    Str(trans.nextState,v);
    outs := outs + v;
    outs := outs + ',' + trans.direction;
    outs := outs + ',' + trans.output;
  end;
  while length(outs) < 6 do outs := ' ' + outs;
  Write(outs);
end;

procedure DumpStateTable;
var
  i,j: integer;
begin
  for i := 1 to 40 do begin
    for j := 1 to 12 do begin
      DumpTransition(states[i,j]);
    end;
    Writeln;
  repeat until KeyPressed;
  end;
end;



(* Program *)

procedure Initialize;
begin
  transLookup := '01cLR ';
end;



procedure ParseTransition(s: rawTransitionString; var trans: transition);
var
  commaPos   : integer;
  value,code : integer;
begin
  if s[1] = '-' then begin
    trans.null := true;
  end
  else begin
    trans.null := false;
    commaPos := Pos(',',s);
    Val(Copy(s,1,commaPos-1),value,code);
    trans.nextState := value;
    Delete(s,1,commaPos);
    trans.output := s[1];
    Delete(s,1,2);
    trans.direction := s[1];
  end;
end;

procedure ReadStateTable;
var
  stateTableFile   : text;
  filename         : string[12];
  rawState         : rawLine;
  i,j              : integer;
  index            : integer;    { of current state }
  transitionLength : integer;
begin
  filename := 'states.utm';
  Assign(stateTableFile,filename);
  Reset(stateTableFile);
  index := 1;
  while not Eof(stateTableFile) do
  begin
    ReadLn(stateTableFile,rawState);
    for i := 1 to 11 do                { parse transition }
    begin
      transitionLength := Pos(';',rawState);
      parseTransition(Copy(rawState,1,transitionLength-1),states[index,i]);
      delete(rawState,1,transitionLength);
    end;
    parseTransition(rawState,states[index,12]);
    index := index + 1;
  end;
  Close(stateTableFile);
end;



procedure ReadEmulatedMachine;
var
  TMfile   : Text;
  filename : string[12];
begin
  filename := 'emulated.tm';
  Assign(TMfile,filename);
  Reset(TMfile);
  ReadLn(TMfile,emulatedTM);
  Close(TMfile);
  emulatedTM := emulatedTM + '   ';
end;



procedure initializeDisplay;
begin
   ClrScr;
end;

procedure updateDisplay(state, position: integer; trans: transition);
var
  i : integer;
begin
   GotoXY(1,1);
   Write('state=',state,' cell=',position,' ');
   Write('tape[',position,']=',emulatedTM[position],'      ');
   write(trans.null,' ',trans.nextState,',');
   Write(trans.direction,',',trans.output);
   ClrEol;
   GotoXY(1,10);
   i := 1;
   while i <= length(markedCells) do begin
     if i = position then begin
       TextBackground(6);
       Write(markedCells[i]);
       TextBackground(0);
     end
     else Write(markedCells[i]);
     i := i + 1;
   end;
   GotoXY(1,11);
   i := 1;
   while i <= length(emulatedTM) do begin
     if i = position then begin
       TextBackground(6);
       Write(emulatedTM[i]);
       TextBackground(0);
     end
     else Write(emulatedTM[i]);
     i := i + 1;
   end;
   ClrEol;
end;



procedure EmulateMachine;
var
  i           : integer;
  position    : integer;
  curState    : integer;
  done        : Boolean;
  curTrans    : transition;

begin
  curState := 1;
  position := 1;    { of tape head }
  done     := false;
  { set up strings }
  markedCells := '';
  for i := 1 to length(emulatedTM) do markedCells := markedCells + ' ';
  { mark current state }
  markedCells[3] := 'm';
  { mark data area }
  i := Length(emulatedTM);
  while emulatedTM[i] <> 'c' do i := i - 1;
  markedCells[i+1] := 'm';
  initializeDisplay;
  while not done do begin
    repeat Until KeyPressed;
    i := Pos(emulatedTM[position],transLookup);
    if markedCells[position] = 'm' then i := i + 6;
    curTrans := states[curState,i];
    UpdateDisplay(curState,position,curTrans);
    { get current transition }
    if curTrans.null = true
    then done := true
    else begin                           { do transition }
      { print symbol -- this code needs improvement! }
      case curTrans.output of
        '0' : begin
                emulatedTM[position]  := '0';
                markedCells[position] := ' ';
              end;
        '1' : begin
                emulatedTM[position]  := '1';
                markedCells[position] := ' ';
              end;
        'c' : begin
                emulatedTM[position]  := 'c';
                markedCells[position] := ' ';
              end;
        'L' : begin
                emulatedTM[position]  := 'L';
                markedCells[position] := ' ';
              end;
        'R' : begin
                emulatedTM[position]  := 'R';
                markedCells[position] := ' ';
              end;
        'B' : begin
                emulatedTM[position]  := ' ';
                markedCells[position] := ' ';
              end;
        '2' : begin
                emulatedTM[position] := '0';
                markedCells[position] := 'm';
              end;
        '3' : begin
                emulatedTM[position] := '1';
                markedCells[position] := 'm';
              end;
        'C' : begin
                emulatedTM[position] := 'c';
                markedCells[position] := 'm';
              end;
        'l' : begin
                emulatedTM[position] := 'L';
                markedCells[position] := 'm';
              end;
        'r' : begin
                emulatedTM[position] := 'R';
                markedCells[position] := 'm';
              end;
        'b' : begin
                emulatedTM[position] := ' ';
                markedCells[position] := 'm';
              end;
      end;
      { move tape head }
      if curTrans.direction = 'L'
      then position := position - 1
      else position := position + 1;
      { change state }
      curState := curTrans.nextState;
    end;
  end;
  updateDisplay(curState,position,curTrans);
  { and this if statement should be in a separate proc }
  if curState = 40 then begin
    GotoXY(1,3);
    TextColor(10);
    Write('ACCEPT');
    TextColor(0);
    ClrEol;
  end
  else begin
    GotoXY(1,3);
    TextColor(12);
    Write('REJECT');
    TextColor(0);
    ClrEol;
  end;
  repeat until KeyPressed;
end;



begin
  Initialize;
  ReadStateTable;
  ReadEmulatedMachine;
  EmulateMachine;
end.