PROGRAM beute;
(******************************************************************)
(* Paul Koop M.A. MATURANA Autopoiese                             *)
(* Die Simulation wurde ursprunglich entwickelt,                  *)
(* um die Verwendbarkeit von Zellularautomaten                     *)
(* fuer die Algorithmisch Rekursive Sequanzanalyse                *)
(* zu ueberpruefen								*)
(* Modellcharakter hat allein der Quelltext. Eine Compilierung    *)
(* dient nur als Falsifikationsversuch                            *)
(******************************************************************)

USES dos,crt;
(*---------------------------- Datenstruktur ---------------------*)
CONST
 zl = 1;    l = char(32);
 zu = 10;   u = char(111);
 ze = 100;  e = char(1);
 zge= 1000; ge= char(2);
 zk = 10000;k = char(42);

TYPE
 raum = array(.1..80,1..24.) of INTEGER;
 zahl = ^inhalt;
 inhalt = RECORD
           i:integer;
           v:zahl;
           n:zahl;
          END;
VAR
 a,b:raum;
 n,x,y,xa,ya:zahl;

(*---------------------------- Prozeduren -----------------------*)
PROCEDURE aufbau;
 VAR z:integer;
 BEGIN
  randomize;
  z := 1;
  new(n);
  xa := n;
  x := n;
  x^.i := z;
  REPEAT
   z := z +1;
   new(n);
   x^.n := n;
   n^.v := x;
   x := n;
   x^.i := z;
  UNTIL z = 80;
  x^.n := xa;
  xa^.v := x;

  z := 1;
  new(n);
  ya := n;
  y := n;
  y^.i := z;
  REPEAT
   z := z +1;
   new(n);
   y^.n := n;
   n^.v := y;
   y := n;
   y^.i := z;
  UNTIL z = 24;
  y^.n := ya;
  ya^.v := y;
 END;

PROCEDURE abbaux(x:zahl);
 BEGIN
  IF x^.n <> xa THEN abbaux(x^.n);
  dispose(x);
 END;

PROCEDURE abbauy(y:zahl);
 BEGIN
  IF y^.n <> ya THEN abbauy(y^.n);
  dispose(y);
 END;

PROCEDURE farbe (z:integer);
 BEGIN
  CASE z OF
   1:textcolor(green);
   10:textcolor(green);
   ELSE textcolor(red);
  END;
 END;

PROCEDURE schreibe (z:integer);
 BEGIN
  CASE z OF
   1    :write(l);
   10   :write(u);
   100  :write(e);
   1000 :write(ge);
   10000:write(k);
  END;
 END;

PROCEDURE zufall(VAR von:raum);
 VAR x,y,zufaellig
 :integer;
 BEGIN
  randomize;gotoxy(1,1);
  FOR y := 1 TO 24
   DO
   FOR x := 1 TO 80
    DO
     BEGIN
      zufaellig := random(50)+1;
      CASE zufaellig OF
       0:von(.x,y.):=zl;
       1:von(.x,y.):=zu;
       2:von(.x,y.):=zk;
       ELSE von(.x,y.):=zu;
      END;
      farbe(von(.x,y.));
      schreibe(von(.x,y.))
     END;
 END;


FUNCTION neu (VAR r:raum; VAR x,y:zahl):integer;
 VAR lz,uz,ez,gez,kz,z:integer;
 BEGIN
  z:=(
   r(.x^.v^.i,y^.v^.i.)+
   r(.x^.i   ,y^.v^.i.)+
   r(.x^.n^.i,y^.v^.i.)+
   r(.x^.v^.i,y^.i   .)+
   r(.x^.n^.i,y^.i   .)+
   r(.x^.v^.i,y^.n^.i.)+
   r(.x^.i   ,y^.n^.i.)+
   r(.x^.n^.i,y^.n^.i.));

   lz := z mod 10;
   uz := (z div 10) mod 10 ;
   ez := (z div 100) mod 10 ;
   gez:= (z div 1000) mod 10 ;
   kz := (z div 10000) mod 10;


  IF r(.x^.i,y^.i.) = zu
   THEN
    BEGIN
     IF kz > 0
     THEN neu := ze
     ELSE neu := zu
    END
   ELSE
    BEGIN
     IF r(.x^.i,y^.i.) = ze
      THEN
       BEGIN
        IF (ez > 0) and (kz > 0)
        THEN neu := zge
        ELSE neu := ze
       END
      ELSE
       BEGIN
        IF r(.x^.i,y^.i.) = zge
         THEN
          BEGIN
           neu := zu
          END
         ELSE
          BEGIN
           NEU := r(.x^.i,y^.i.)
          END
       END
    END

 END;

PROCEDURE textzeile;
 BEGIN
  window(1,25,80,25);
  textbackground(red);
  textcolor(white);
  clrscr;
  write('Koop Autopoiese Maturana');
  gotoxy(1,1);
  textcolor(2);
  textbackground(black);
  window(1,1,80,24);clrscr;window(1,1,80,25);
 END;



PROCEDURE spiel(VAR von,nach :raum);
 BEGIN
  y :=ya;
  x :=xa;
  REPEAT
   REPEAT
    nach(.x^.i,y^.i.) :=neu(von,x,y);
    farbe(nach(.x^.i,y^.i.));
    schreibe(nach(.x^.i,y^.i.));
    x := x^.n
   UNTIL x =xa;
   y := y^.n
  UNTIL y =ya;
 END;



(*------------------------------ Hauptprogramm -----------------*)
BEGIN
 checkbreak := false;
 aufbau;
 textzeile;
 gotoxy(1,1);
 zufall(a);
 REPEAT
 gotoxy(1,1);
 spiel(a,b);
 gotoxy(1,1);
 spiel(b,a)
 UNTIL keypressed;
 x := xa;
 abbaux(x);
 y := ya;
 abbauy(y);
 textbackground(black);
 textcolor(white);
 clrscr;
 checkbreak := true;
END.
(************************************** ENDE ************)