program turing;
{ Turing-Maschine in FreePascal
  (C) Stephan Beyer, 2003, GPL

  Aenderung: 20060724 Bugfix, nun geht es auch mal mit aktuellem FreePascal.
  Anmerkung: In der Schule habe ich die Turingmaschine ein bisschen
             anders beigebracht bekommen als in der Uni.

Programm liest turing.dat zeilenweise ein.
turing.dat-Programmzeilen werden als Ringliste gespeichert.

Format der ersten Zeile:
"LeerZeichen1Zeichen2Zeichen3..." 
	Leer ist das Zeichen mit dem das leere Band gefuellt wird (Leerzeichen)
	Danach kommt die Zeichenfolge fuer das Startband
	(Keine Kommentare erlaubt -> gelten als Zeichen auf dem Band)
Anfangszustand ist der der ersten Zeile der restlichen.
Format der restlichen Zeilen:
"Zustand  gelesenesZeichen  zuSchreibendesZeichen  neuePosition  neuerZustand"
	neuePosition = 'L' (links) / 'R' (rechts) / 'S' (stehenbleiben)
	keine Tabs verwenden!
	Zustaende sind case-insensitive (Gross/Kleinschreibung wird ignoriert)
Kommentare: Semikolon (';') und alles dahinter ist ein Kommentar
}

const	groesse = 1024;

type
	PProg = ^TProg;
	TProg =	record
			nr : word;
			azustand : string[20];
			lesen : char;
			schreiben : char;
			position : char;
			nzustand : string[20];
			next : PProg;
		end;
	Band =	record
			leer : char;
			pos : word;
			zelle : array[1..groesse] of char;
		end;

var	b : Band;

{ band vorbereiten, leeren, startband eingeben, anfangsposition (mitte) setzen }
procedure band_init (start : string);
var	i : word;
begin
	for i := 1 to groesse do
		b.zelle[i] := b.leer;
	b.pos := (groesse div 2) - (length(start) div 2);
	for i := 1 to length(start) do
		b.zelle[i+b.pos-1] := start[i];
end;



{ an die Ringliste ein neues Element (eingelesene Zeile) "hinten" anfuegen }
procedure zeile_hinzufuegen (var liste : PProg; zeile : string; i : word);
    procedure nextToken (s : string; var token : word);
    begin
    	if s[token] <> ' ' then
    		inc(token);
    	while s[token] = ' ' do
    		inc(token);
    end;
    function toEOL (s : string; token : word) : word;
    begin
    	toEOL := token;
    	while s[toEOL] <> ' ' do
    		inc(toEOL);
    	toEOL := toEOL - token;
    end;
var	token : word;
	neu : PProg;
begin
	new(neu);
	{ Einlesen }
	neu^.nr := i;
	token := pos(' ', zeile)-1;
	neu^.azustand := upcase(copy(zeile, 1, token));
	nextToken(zeile, token);
	neu^.lesen := zeile[token];
	nextToken(zeile, token);
	neu^.schreiben := zeile[token];
	nextToken(zeile, token);
	neu^.position := upcase(zeile[token]);
	nextToken(zeile, token);
	neu^.nzustand := upcase(copy(zeile, token, toEOL(zeile, token)));
	token := 1;
	repeat 
		if (neu^.nzustand[token] = ' ') or 
		   (neu^.nzustand[token] = ';') then
			delete(neu^.nzustand, token, 
				length(neu^.nzustand)-token+1);
		inc(token);
	until token > length(neu^.nzustand);

	{ in Ringliste setzen }
	if liste = nil then { leer? }
	begin
		neu^.next := neu;
		liste := neu;
	end else begin
		neu^.next := liste^.next;
		liste^.next := neu;
		liste := liste^.next; { Startzustand erhalten }
	end;
end;

{ die datei einlesen und dabei eine ringliste (siehe TProg) aufbauen und 
  das Band initialisieren.
  Das Listenelement worauf als erstes gezeigt wird, ist die erste Zeile
  des Turing-Programms und die Reihenfolge ist in die gleiche wie im
  Programm festgelegt... }
procedure einlesen(var liste : PProg; dateiname : string);
var	datei : text;
	zeile : string[50];
	i : word;
begin
	writeln ('Oeffne ', dateiname);
	assign(datei, dateiname);
	{$I-} reset(datei); {$I+}
	if( IOResult <> 0) then
	begin
		writeln ('Konnte ', dateiname, ' nicht oeffnen! Ende.');
		halt;
	end;

	write ('Lese: ');
	i := 0;
	while not eof(datei) do
	begin
		{ Einlesen }
		repeat
			readln(datei, zeile);
			while zeile[1] = ' ' do
				delete(zeile, 1, 1);
		until (zeile[1] <> ';') and (length(zeile) > 0) or eof(datei);
		inc(i);
		if i = 1 then { erste Zeile = Festlegung des Leer-Zeichens }
		begin
			b.leer := zeile[1];
			band_init (copy(zeile, 2, length(zeile)-1));
		end else
			zeile_hinzufuegen(liste, zeile, i-1);
	end;
	liste := liste^.next;
	close(datei);
	writeln(i, ' Zeilen gelesen.');
end;


{ ringliste loeschen }
procedure cleanup (var list : PProg);
var	first : PProg;
begin
	first := list;
	if first <> nil then
	begin
		list := list^.next; { Kette abreissen }
		first^.next := nil;
		while list <> nil do
		begin
			first := list;
			list := list^.next;
			dispose(first);
		end;
	end;
end;

{ simple ausgabe des bandes }
procedure band_ausgebenALT;
var	i : word;
begin
	write (':: ');
	for i := 1 to groesse do
	begin
		write (b.zelle[i]);
	end;
	writeln;
	write ('"" ');
	for i := 1 to b.pos-1 do
		write (' ');
	write ('^');
	for i := b.pos+1 to groesse do
		write (' ');
	writeln;
end;


{ bessere ausgabe des bandes }
procedure band_ausgeben;
var	i, anfang, ende : word;
begin
	write (':: ');

	{ finde anfangs und endpunkt }
	anfang := 1;
	ende := groesse;
	while (anfang < ende)
	  and (anfang < b.pos)
	  and (b.zelle[anfang] = b.leer) do
		inc(anfang);
	while (ende > anfang)
	  and (ende > b.pos)
	  and (b.zelle[ende] = b.leer) do
		dec(ende);
	{ 2 Zellen "Rand": }
	anfang := anfang - 2;
	ende := ende + 2;
	{ ausserhalb bereich? }
	if anfang < 1 then
		anfang := 1;
	if ende > groesse then
		ende := groesse;

	{ band-teil ausgeben }
	if anfang > 1 then
		write ('...');
	for i := anfang to ende do
		write (b.zelle[i]);
	if ende < groesse then
		write ('...');
	writeln;

	{ kopfposition ausgeben }
	write ('"" ');
	if anfang > 1 then
		write ('   ');
	for i := anfang to b.pos-1 do
		write (' ');
	write ('^');
	for i := b.pos+1 to ende do
		write (' ');
	if ende < groesse then
		write ('   ');
	writeln;
end;


{ hauptprogramm eigentlich }
procedure loop (turp : PProg);
var	zustand : string[20];
	i : integer;
begin
	writeln ('Starte Turing-Maschine...');
	writeln;

	zustand := turp^.azustand; { beginne mit erstem Zustand/erster Zeile }
	writeln ('Vorgabe:');
	band_ausgeben;

	i := 0;
	repeat
		inc(i);
		writeln;
		writeln ('## Takt ', i);
		{ suche gesuchten zustand und vergleiche lesendes zeichen }
		write ('-> ');
		while (turp^.azustand <> zustand) or
		      (turp^.lesen <> b.zelle[b.pos]) do
		begin
			turp := turp^.next;
		end;
		writeln ('(', turp^.nr, ') ', turp^.azustand, ' ',
			 turp^.lesen, ' ', turp^.schreiben, ' ',
			 turp^.position, ' ', turp^.nzustand);
		b.zelle[b.pos] := turp^.schreiben; { zeichen schreiben }
		
		if turp^.position = 'R' then { verruecken }
			inc(b.pos) { -> }
		else
			if turp^.position = 'L' then
				dec(b.pos); { <- }
		{ und zustand wechseln }
		zustand := turp^.nzustand;
		
		band_ausgeben;
		readln;
	until (turp^.azustand = turp^.nzustand)
	  and (turp^.position = 'S')
	  and (turp^.lesen = turp^.schreiben);
end;


var	turp : PProg;
	dateiname : string;
begin
	writeln ('Implementation einer Turing-Maschine, von Stephan Beyer, 2003');
	writeln ('-------------------------------------------------------------');
	writeln;

	repeat
		write ('Dateiname: ');
		readln(dateiname);
	until dateiname <> '';

	turp := nil; 
	einlesen (turp, dateiname);

	loop (turp); { endlos eigentlich }
	
	cleanup (turp);
end.