{Programm kann weiterverwendet werden. Jede Veroeffentlichung einer
 veraenderten Version muss per Mail gemeldet werden mit Angabe, wo
 es veroeffentlicht wird. Ich moechte die Verbreitung mitverfolgen.
 Ich will, dass keiner Patente auf dieses Programm oder daraus enstandende,
 anmeldet.}
{program can be reused. For every publishing of a changed version 
 you need to send me a e-mail with the notice, where you published
 it. I want to see, where the program is in use. 
 I don't want that anyone have patents on this program or on something,
 wrote with this}
{Author: Stefan Ziegler, Mail: stefan.ziegler_zst@gmx.de}
{Homepage: http://www.stefanziegler-online.de/ }

program feldliste;
{version: 0.84, 16th July 2001}

type errortype  = byte;
     indextype  = byte; (*byte/char/word/longint/0..1000/ (Mo, Tu) *)
     datatype   = pointer;
     pfeldliste = ^feldlistentyp;
     feldlistentyp = RECORD
                       last, next, top, sub : pfeldliste;
                       index : indextype;
                       data  : datatype;
                     END;

const lowestindex : indextype = 1;
      highestindex : indextype = 3;

{--- Allgemeine Funktionen -----------------------------------------}

function geterrorstring(errornum: errortype): string;
{Gegenstueck zu errornum / Opposite of errornum}

var back: string;

begin
  back := 'Errorstring not found.';
  if errornum = 0 then
    back := 'No errors.';
  if errornum = 1 then
    back := 'Too big index, list full.';
  if errornum = 2 then
    back := 'Sublist existed before command.';
  if errornum = 3 then
    back := 'Toplist existed before command.';
  if errornum = 4 then
    back := 'Index not found.';
  if errornum = 5 then
    back := 'Wrong index format.';
  geterrorstring:= back;
end;

function errornum(errorstring: string): errortype;
{Gibt Fehlernummer zum Fehlerstring zurueck, Ausgabe, falls Fehler}

var back : errortype;

begin
  back := 255; { Errorstring not found }  
  if errorstring = 'No errors.'
    then back := 0;
  if errorstring = 'Too big index, list full.'
    then back := 1;
  if errorstring = 'Sublist existed before command.'
    then back := 2;
  if errorstring = 'Toplist existed before command.'
    then back := 3;
  if errorstring = 'Index not found.'
    then back := 4;
  if errorstring = 'Wrong index format.'
    then back := 5;
  if back > 0 then
     begin
	writeln;
	writeln('Error ', back, ': ', geterrorstring(back));
     end;
  errornum := back;
end;

function getvalueint(data: pointer): longint;
{gibt den Wert hinter dem Pointer zurueck}

var zahl : ^longint;

begin
  if (data <> NIL)
    then zahl := data
    else zahl^ := 0;
  getvalueint := zahl^;
end;

function comparedata(dataone: datatype; operat: char; datatwo: datatype): boolean;
{ Vergleicht die Daten miteinander, gut geeignet fuer komplexe Datenstrukturen,
  Operator: '<'/ '>' / '=' alles andere mit NOT erreichbar.
  Prinzipiell auch fuer Indexe denkbar.}

begin
  if operat = '<'
    then comparedata := getvalueint(dataone) < getvalueint(datatwo);
  if operat = '='
    then comparedata := getvalueint(dataone) = getvalueint(datatwo);
  if operat = '>'
    then comparedata := getvalueint(dataone) > getvalueint(datatwo);
end;

function addindex(add: longint; list: pfeldliste): errortype;
{addiert zu jedem Indexwert der an list dranhaengenden Feldliste den Wert add,
  Fehler wenn index zu gross wird }

var errorfound : boolean;
    i          : longint;

begin
  errorfound := false;
  while ( (list <> nil) AND NOT(errorfound) ) do
    begin
      if (ord(list^.index) + ord(add)) <= ord(highestindex)
        then begin
               if add > 0
                 then for i:=1 to add do
                        list^.index := succ( list^.index )
                 else for i:=1 to abs(add) do
                        list^.index := pred( list^.index );
             end
        else errorfound := true;
      list := list^.next;
    end;
  if errorfound
    then begin
	   write('Addindex: ', ord(list^.index), ' ');
	   addindex := errornum('Too big index, list full.');
	 end
    else addindex := errornum('No errors.');
end;

{--- Insert --------------------------------------------------------}

procedure insfirst(data: datatype; var list: pfeldliste; var error: errortype);
{Fuegt am Anfang(oder in der Mitte) der Liste ein Element ein}

var hilflist : pfeldliste;
    dummyerror : errortype;

begin
  New(hilflist);
  if list <> NIL
    then begin
           hilflist^.last := list^.last;
           hilflist^.top := list^.top;
         end
    else begin
           hilflist^.last := NIL;
           hilflist^.top := NIL;
         end;
  hilflist^.sub  := NIL;
  hilflist^.next := list;
  hilflist^.data := data;
  hilflist^.index := lowestindex;
  error := addindex(1, list);
  if (error > 0)
    then begin
           dispose(hilflist);
           hilflist := list;             {addindex -1, without last element}
           dummyerror := addindex(-1, hilflist);
           if hilflist <> NIL then
             while hilflist^.next <> NIL do
               hilflist := hilflist^.next;
           dummyerror := addindex(1, hilflist);
         end
    else begin
           if (list <> NIL)
             then begin
                    if list^.last <> NIL then list^.last^.next := hilflist;
                    list^.last := hilflist;
                  end;
           list := hilflist;
         end;
end;

procedure inslast(data: datatype; var list: pfeldliste; var error: errortype); 
{Fuegt am Ende der Liste ein Element ein}
 
var hilflist, ende : pfeldliste; 
 
begin 
  ende := list;
  if ende <> nil then
    while ende^.next <> nil do ende:= ende^.next;
  New(hilflist); 
  hilflist^.last := ende;
  hilflist^.sub  := NIL; 
  if list <> NIL then hilflist^.top := list^.top
		 else hilflist^.top := NIL;
  hilflist^.next := NIL; 
  hilflist^.data := data; 
  if list = NIL 
    then hilflist^.index := lowestindex
    else begin 
	   hilflist^.index := ende^.index;
	   error := addindex(1, hilflist);
           if error = 0
             then begin
                    if ende <> NIL then ende^.next := hilflist;
                  end
             else dispose(hilflist);
	 end;
  if list = NIL then list := hilflist;
end; 

procedure inssub(data: datatype; list: pfeldliste; var error: errortype);
{Faengt eine Subliste an unter dem ersten Element der uebergebenen Liste}

var hilflist : pfeldliste;

begin
  hilflist:= NIL;
  if (list <> NIL) then
    begin
      if list^.sub = NIL
        then begin
	       insfirst(data, hilflist, error);
	       hilflist^.top := list;
	       list^.sub := hilflist;
	     end
	else error:=errornum('Sublist existed before command.');
    end
  else insfirst(data, list, error);    
end;

procedure ins_top(data: datatype; var list: pfeldliste; var error: errortype);
{Faengt neue Liste an, alte als Subliste dieser}

var hilflist : pfeldliste;

begin
  hilflist:= NIL;
  if (list<> NIL) 
    then begin
	   if list^.top = NIL
	     then begin
		    insfirst(data, hilflist, error);
		    hilflist^.sub := list;
                    list := hilflist;
                    hilflist := list^.sub;
                    while hilflist^.last <> NIL do {findfirst}
                      hilflist := hilflist^.last;
		    while hilflist <> NIL do
                      begin
                        hilflist^.top := list;  {set top for all}
                        hilflist := hilflist^.next;
                      end;
		  end
	     else error := errornum('Toplist existed before command.');
	 end
    else insfirst(data, list, error);
end;

{--- Delete --------------------------------------------------------}

procedure delfirst(var list: pfeldliste);
{loescht den ersten Eintrag einer Liste, loescht auch alle Sublisten}

var hilflist, kopf : pfeldliste;

begin
  hilflist := list;
  if (hilflist <> NIL) then
    begin
      if (hilflist^.sub <> NIL) then
        begin
	  kopf := hilflist;
          hilflist := hilflist^.sub;
	  while (hilflist <> NIL) do delfirst(hilflist);
	  hilflist := kopf;
	  hilflist^.sub := NIL;
        end;
      if hilflist <> NIL then
        if hilflist^.last <> NIL then hilflist^.last^.next := hilflist^.next;
      if hilflist <> NIL then
	if hilflist^.next <> NIL then hilflist^.next^.last := hilflist^.last;
      list := hilflist^.next;
      dispose(hilflist);	
    end;
end;

procedure dellast(var list: pfeldliste);
{loescht den letzten Eintrag der Liste, loescht auch alle Sublisten}

var hilflist : pfeldliste;

begin
  hilflist := list;
  if (hilflist <> nil) then
     begin
	while (hilflist^.next <> nil) do hilflist := hilflist^.next;
	if hilflist <> list
	  then hilflist^.last^.next := NIL
	  else list:= nil;
	delfirst(hilflist);
     end;	    
end;

procedure delsub(list: pfeldliste);
{loescht alle Sublisten des Listenelementes}

var hilflist : pfeldliste;

begin
  if (list <> NIL) then
    if (list^.sub <> NIL) then
        begin
          hilflist := list^.sub;
	  while (hilflist <> NIL) do delfirst(hilflist);
	  list^.sub := NIL;
        end;
end;

procedure deltop(VAR list: pfeldliste);
{loescht alle Listenteile und deren Sublisten, die ueber der uebergebenen
 Liste haengen, ubergebene Liste wird oberste Liste}

var hilflist : pfeldliste;

begin
  if list <> NIL then
    if list^.top <> NIL then
      begin
	hilflist := list;
	hilflist^.top^.sub := NIL;	{Liste abtrennen zum aufheben}
	while hilflist^.top <> NIL DO hilflist:=hilflist^.top;
	while hilflist <> NIL DO delfirst(hilflist);

	hilflist := list;
        while hilflist^.last <> NIL do {findfirst} 
          hilflist := hilflist^.last; 
	while hilflist <> NIL do 
          begin 
            hilflist^.top := NIL;  {delete top for all} 
            hilflist := hilflist^.next; 
          end;
      end;  
end;

{--- Output --------------------------------------------------------}

function getdataint(list: pfeldliste): longint;
{gibt die Daten als Integerwert zurueck}

var zahl : ^longint;

begin
  if (list <> nil) then
    begin
	zahl := list^.data;
	getdataint := ord( zahl^);
    end
    else getdataint := 0;
end;

function getindexint(list: pfeldliste): longint;
{gibt den Index als Integerwert zurueck}

var zahl : longint;

begin
  if list <> NIL then
    begin
      zahl := ord(list^.index);
      getindexint := zahl;
    end;
end;

procedure showlistsub(list: pfeldliste; depth: longint);
{gibt alle Elemente des Listenfeldes aus}

var hilflist : pfeldliste;

begin
  writeln;
  hilflist := list; {forward}
  while (list <> nil) do
    begin
      write(depth, ':D:', getdataint(list), ',I:', getindexint(list), ' ');
      if (list^.sub <> nil) and (depth < 100)      {No Stack overflow}
        then showlistsub(list^.sub, depth+1);
      list := list^.next
   end;
  list := hilflist;            {backward}
  if list <> NIL then
    while list^.next <> NIL do list := list^.next;
  while (list <> nil) do
    begin
      write(depth, ':D:', getdataint(list), ',I:', getindexint(list), ' ');
      if (list^.sub <> nil) and (depth < 100)      {No Stack overflow}
        then showlistsub(list^.sub, depth+1);
      list := list^.last
    end;
  writeln;
end;

procedure showlist(list: pfeldliste);
begin
  showlistsub(list, 0);
  readln;
end;

{--- Find/Search ---------------------------------------------------}

procedure findlistofdata(list: pfeldliste; data: datatype;
 			var indexway: string; var found: pfeldliste);
{durchsucht alle Elemente des Feldes und gibt erstes gefundenes zurueck
mit allen Indexen dazu. indexway z.B. '9 11', d.h. Index 9, Subliste Index 11
'' nur bei leerer Liste/ '' only in empty list}
{wie showlistsub, statt write data vergleichen}
{like showlistsub, compare data instead of write}

var iwaypart : string[10];

begin
  found := NIL;
  while (list <> nil) and (found = NIL) do 
    begin 
      if comparedata(data, '=', list^.data) then found := list;
      if (list^.sub <> nil) and (found = NIL)
	then findlistofdata(list^.sub, data, indexway, found);
      if found <> NIL then 
	begin
	  str( ord(list^.index), iwaypart);
	  indexway := iwaypart + ' ' + indexway;
	  {write(iwaypart, ' ');}
	end;
      list := list^.next; 
    end; 
end;

procedure findlistofindex(list: pfeldliste; indexway: string;
			var found: pfeldliste; var error: errortype);
{durchsucht Liste nach ersten aufgezaehlten Index, macht dann weiter mit
 naechstem in der zugehoerigen Subliste bis Element gefunden mit diesen
 Indexen}
{ first indexnumber from string, val(string, index, error)
  if list <> nil, strlen(indexway) > 0
  while index < list^.index do next;
  if index = then if strlen(restindexway) > 0  go to sublist with restiway
		else found :=
  if index > then index not found }

var iwaypart : string[10];
    restiway : string;
    i, count : integer;
    ende     : boolean;
    code     : integer;
    pos      : longint;

begin
  if indexway[1] = ' ' then count := 2
                       else count := 1;
  iwaypart := '';
  while (indexway[count] <> ' ') AND (count <= length(indexway)) do
    begin
      iwaypart := iwaypart + indexway[count];       {cut first index}
      inc(count);
    end;
  restiway := '';
  for i:=1 to (length(indexway) - count) do     {rest index}
    restiway := restiway + indexway[i+count];
  {writeln('"', iwaypart, '"  "', restiway, '"  ', count);}
  val(iwaypart, pos, code);
  if code > 0 then ende := true
              else ende := false;
  found := NIL;
  while (list <> NIL) AND NOT(ende) do          {goto index}
    begin
      if pos > ord(list^.index) then list := list^.next
        else if pos < ord(list^.index) then list := list^.last
	else if pos = ord(list^.index) then
        	begin ende := true; found := list; end;
      if (list <> NIL) then
        if list^.next <> NIL then            { 3 not in (2, 4, 5)}
          if (pos > ord(list^.index)) and (pos < ord(list^.next^.index))
            then ende := true;
    end;
  if (found <> NIL) then ende := false;
  if list = NIL then ende := true
    else if ord(list^.index) <> pos then ende := true; { 3 not in (2, 4, 5)}
  if ende then error := errornum('Index not found.');
  if code > 0 then error := errornum('Wrong index format.');
  if NOT(ende) then
    if length(restiway) > 0
      then findlistofindex(list^.sub, restiway, found, error)
      else found := list; {finished}
end;

function buildindexway(list: pfeldliste): string;
{Baut den String indexway auf fuer aktuelles Listenelement}
{if list <> NIL then
  repeat str(index, string); list := list^.top; until list = nil
 else buildindexway = '';
}

var iwaypart : string[10];
    indexway : string;

begin
  iwaypart := '';
  indexway := '';
  while list <> NIL do
    begin
      str( ord(list^.index), iwaypart);
      indexway := iwaypart + ' ' + indexway;
      list := list^.top;
    end;
  buildindexway := indexway;
end;

{*** Main **********************************************************}

var x, y : indextype;
    error : errortype;
    e, i : longint;
    koordfeld, found : pfeldliste;
    indexway : string;
    zahl      : ^indextype;

begin
  randomize;
  writeln;
  writeln('--- Feldlist -------------------------------------');
  koordfeld := NIL;
  for y:=highestindex downto lowestindex do
    begin
      New(zahl);
      zahl^:= y;
      insfirst(zahl, koordfeld, error);

      New(zahl);
      zahl^ := lowestindex;
      inssub(zahl, koordfeld, error);
      koordfeld := koordfeld^.sub;

      for x:=succ(lowestindex) to highestindex do
	begin
	  New(zahl);
          zahl^ := lowestindex;
          i := ord(highestindex) - ord(lowestindex);
          e := random( i );
          for i:=0 to e do
	    zahl^:= succ( zahl^ );
	  write(ord(x), ' ');
	  inslast(zahl, koordfeld, error);
	  koordfeld:= koordfeld^.next;
	end;
      koordfeld := koordfeld^.top;
    end;
  showlist(koordfeld);

  New(zahl);
  zahl^:= highestindex;
  writeln('Findlistofdata ', getvalueint(zahl) );
  indexway := '';
  findlistofdata(koordfeld, zahl, indexway, found);
  writeln;
  writeln('Buildindexway: "', buildindexway(found), '"');
  showlist(found);
  writeln('Findlistofindex');
  findlistofindex(koordfeld, buildindexway(found), found, error);
  showlist(found);
  showlist(koordfeld); 

  writeln('Delfirst'); 
  delfirst(koordfeld^.next); 
  showlist(koordfeld);
  writeln('Findlistofindex Nr. 1');
  findlistofindex(koordfeld, ' 1 1', found, error);     {Error: 4}
  writeln('Findlistofindex Nr. 2');
  findlistofindex(koordfeld, ' 12 1', found, error);    {Error: 4}
  writeln('Findlistofindex Nr. 3');
  findlistofindex(koordfeld, ' 1a 1', found, error);    {Error: 4,5}

  writeln;
  writeln('Dellast');
  dellast(koordfeld);
  showlist(koordfeld); 

  writeln('Delsub');
  delsub(koordfeld);
  showlist(koordfeld);

  writeln('Ins_top.');
  zahl^ := lowestindex;
  ins_top(zahl, koordfeld, error);
  showlist(koordfeld);

  writeln('Deltop.');
  if koordfeld <> NIL then koordfeld:= koordfeld^.sub;
  if (koordfeld <> NIL) then 
    if koordfeld^.next <> NIL then koordfeld:= koordfeld^.next^.sub;
  showlist(koordfeld);
  deltop(koordfeld);
  writeln('End Deltop.');
  showlist(koordfeld);

  writeln('Dellist. Leer ?');
  while (koordfeld <> NIL) do delfirst(koordfeld);
  showlist(koordfeld);

  dellast(koordfeld);			(*Del Fehlerfest ?*)
  delfirst(koordfeld);
  delsub(koordfeld);
  deltop(koordfeld);
  insfirst(NIL, koordfeld, error);
  delsub(koordfeld);
  writeln('Deltop.');
  deltop(koordfeld);
  writeln('Dellast');
  dellast(koordfeld);
  writeln('showlist');
  showlist(koordfeld);

  writeln('Ins_top.');			(*Fehler provozieren*)
  insfirst(NIL, koordfeld, error);
  ins_top(NIL, koordfeld, error);
  ins_top(NIL, koordfeld^.sub, error);

  writeln('Inssub.');
  inssub(NIL, koordfeld, error);

  readln;
end.