(*Windows Free Pascal is developed by dr J.Szymanda under the GPL License*)
(*************************************************************************)
PROGRAM genetischer_algorithmus (output);
(******************************************************************)
(* Paul Koop M.A. genetischer Algorithmus                         *)
(* Der Algorithmus optimiert die weider (froesche)                *)
(* Die Simulation wurde ursprunglich entwickelt,                  *)
(* um die Verwendbarkeit von genetischen Algorithmen              *)
(* fuer die Algorithmisch Rekursive Sequanzanalyse                *)
(* zu ueberpruefen								*)
(* Modellcharakter hat allein der Quelltext. Eine Compilierung    *)
(* dient nur als Falsifikationsversuch                            *)
(******************************************************************)

USES dos,crt;
(*----------------------- Const Definitionen ----------*)
 CONST
      Fn = 1; (* gen nahrung      *)
      Fg = 2; (* gen gefahr       *)
      Rn = 3; (* gen fressen      *)
      Rg = 4; (* gen verteidigung *)
      
      Fk = 5; (* gen andere weider erkennen          *)
      Rk = 6; (* gen mit anderen weidern kooperieren *)
      maxfit = 80;
      stoffwechsel = -1;
(*----------------------- Type-Definitionen------------*)

TYPE
     Tzahl    = ^inhalt;
     inhalt  = RECORD
                i:integer;
                v,
                n:Tzahl;
               END;

    Tfeld    = array(.1..6.) of CHAR;

    TPgen     = ^gen;

    gen      = RECORD
                vor,nach:TPgen;
                g:Tfeld;
               END;

    TPzelle = ^zelle;
    Ttorus  = array(.1..80,1..24.) of TPzelle;                                      
    zelle   = OBJECT
               constructor init;
               destructor done;virtual;
               function nnahrung(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual;
               function nrauber(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual;
               function nweider(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual;
               
              END;

    TPweider= ^weider; (* Froesche nur duie Froesche werden optimiert *)
    weider  = OBJECT(zelle)
               vor,nach                      :TPweider;
               gen                           :TPgen;
               fit                           :integer;
               Fg,
               Fn,
               Rg,
               Rn,
               Fk,
               Rk,
               verteidigen,
               gefahr,
               futter,
               weidererkennen,
               kooperieren                       :boolean;
               constructor init;
               destructor  done;              virtual;
               Procedure   leer;              virtual;
               procedure   Bgefahr
                           (VAR x,y:Tzahl;VAR t:Ttorus);
                                              virtual;
               procedure   Bfutter
                           (VAR x,y:Tzahl;VAR t:Ttorus);
                                              virtual;
               procedure   Rfressen
                           (VAR x,y:Tzahl;VAR t:Ttorus);          
                                              virtual;
               procedure   Rverteidigung;     virtual;
               procedure   Rkooperieren;      virtual;
               procedure   Rfit
                           (zahl:integer);    virtual;
               function    getfit            :integer;
                                              virtual;
               function    getgefahr         :boolean;
                                              virtual;
               function    getverteidigen    :boolean;
                                              virtual;
               function    getfressen        :boolean;
                                              virtual;
               procedure Rweidererkennen
                         (VAR x,y:Tzahl;VAR t:Ttorus); 
                                              virtual;
               function    getkooperatoren
                           (VAR x,y:Tzahl;
                           VAR t:Ttorus)     :integer;
                                              virtual;                                              
                                                                            
               function     nloeschen
                            (VAR x,y:Tzahl;
                             VAR t:Ttorus)   :boolean;
                                              virtual;
              END;

    TPrauber= ^rauber; (* Voegel Feinde der Froesche *)
    rauber  = OBJECT(zelle)
               constructor init;
               destructor done;virtual;
               function rloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual;
              END;

    TPnahrung=^nahrung;(* INSEKTEN Nahrung der Froesche *)
    nahrung = OBJECT(zelle)
               constructor init;
               destructor done;virtual;
               function nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual;
              END;


(*----------------------- Var-Definitionen -----------*)
 VAR
  n,x,y,xa,ya:Tzahl;
  Wzelle     :TPzelle;
  Wweider,
  Aweider,
  Nweider    :TPweider;
  Wnahrung   :TPnahrung;
  Wrauber    :TPrauber;
  Wgen,
  Agen,
  Ngen       :TPgen;

  bilda,
  bildb      :Ttorus;
(*----------------------- Methoden -------------------*)
  CONSTRUCTOR zelle.init;
   BEGIN
   END;

  DESTRUCTOR zelle.done;
   BEGIN
   END;

  FUNCTION zelle.nnahrung(VAR x,y:Tzahl;VAR t:Ttorus):boolean;
   VAR z:integer;
   BEGIN
    Z := 0;
    IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;

     If z > 0
     THEN nnahrung:=true ELSE nnahrung:=false;
   END;

   FUNCTION zelle.nrauber(VAR x,y:Tzahl;VAR t:Ttorus):boolean;
   VAR Z:integer;
   BEGIN
    z := 0;
    IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(rauber)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(rauber)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z + 1;

     IF z > 0
     THEN nrauber :=true ELSE nrauber :=false;
   END;

  FUNCTION zelle.nweider(VAR x,y:Tzahl;VAR t:Ttorus):boolean;
   VAR Z:integer;
   BEGIN
    z := 0;
    IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z + 1;

     IF z > 0
     THEN nweider :=true ELSE nweider :=false;
   END;

  CONSTRUCTOR weider.init;
   BEGIN
   END;
  PROCEDURE weider.leer;
   BEGIN
    Fg              := false;
    Fn              := false;
    Rg              := false;
    Rn              := false;
    Fk              := false;
    Rk              := false;
    verteidigen     := false;
    gefahr          := false;
    futter          := false;
    weidererkennen  := false;
    kooperieren     := false;
    fit             := maxfit;
   END;

  DESTRUCTOR weider.done;
   BEGIN
   END;

  PROCEDURE weider.Bgefahr(VAR x,y:Tzahl;VAR t:Ttorus);
   VAR z : integer;
   BEGIN
    Z := 0;
    IF Fg
    THEN
    BEGIN
    IF TypeOF(t(.x^.v^.v^.i,y^.v^.v^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.v^.v^.i,y^.v^.i   .)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.v^.v^.i,y^.i      .)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.v^.v^.i,y^.n^.i   .)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.v^.v^.i,y^.n^.n^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.v^.i   ,y^.v^.v^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.v^.i   ,y^.n^.n^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.i      ,y^.v^.v^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.i      ,y^.n^.n^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.n^.i   ,y^.v^.v^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.n^.i   ,y^.n^.n^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.n^.n^.i,y^.v^.v^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.n^.n^.i,y^.v^.i   .)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.n^.n^.i,y^.i      .)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.n^.n^.i,y^.n^.i   .)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF TypeOF(t(.x^.n^.n^.i,y^.n^.n^.i.)^)=TypeOf(rauber)
    THEN z := z + 1;
    IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z+1;

    END;

    IF Z > 0
    THEN gefahr := true ELSE gefahr := false;

   END;

   PROCEDURE weider.Bfutter(VAR x,y:Tzahl;VAR t:Ttorus);
    VAR z :integer;
    BEGIN

     z := 0;
     IF Fn
     THEN
     BEGIN
     IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(nahrung)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z + 1;
     END;

     IF Z > 0
     THEN futter  := true ELSE futter  := false;


    END;

function weider.nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;
   VAR z:integer;
   BEGIN
     z := 0;
     IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(weider)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(weider)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z+1;
     IF z> 3 THEN nloeschen := true
             ELSE nloeschen := false;

   END;
   
procedure weider.Rweidererkennen(VAR x,y:Tzahl;VAR t:Ttorus); 
   VAR Z:integer;
   BEGIN
    z := 0;
    IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(weider)
     THEN z := z + 1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN z := z + 1;

     IF ((z > 0) AND Fk)
     THEN weidererkennen :=true ELSE weidererkennen :=false;   
   END;
                                              
function weider.getkooperatoren(VAR x,y:Tzahl;VAR t:Ttorus):integer;
   VAR z:integer;
   BEGIN
     z := 0;
     IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.v^.i,y^.v^.i.)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;

     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.v^.i,y^.i   .)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;


     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.v^.i,y^.n^.i.)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;


     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.i   ,y^.v^.i.)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;


     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.i   ,y^.n^.i.)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;


     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.n^.i,y^.v^.i.)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;


     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.n^.i,y^.i   .)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;


     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider)
     THEN 
      BEGIN
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@t(.x^.n^.i,y^.n^.i.)^;
              IF Aweider^.kooperieren THEN z:=z+1; 
      END;

     (*IF Z>0 THEN z:=1 ELSE z:=-1;*)
     getkooperatoren :=z;
   END;
   
    procedure weider.Rkooperieren;                                                  
     BEGIN
      IF(weidererkennen and Rk)
      THEN kooperieren:=true;
     END;
     
    PROCEDURE weider.Rfressen (VAR x,y:Tzahl;VAR t:Ttorus);
     BEGIN
      IF(futter and Rn)
      THEN 
       BEGIN
        fit := fit + 1+weider.getkooperatoren(x,y,t);
        IF NOT(kooperieren) THEN fit := fit + 1;
       END;
     END;

    PROCEDURE weider.Rverteidigung;
     BEGIN
      IF (gefahr and Rg)
      THEN verteidigen := true
      ELSE verteidigen := false
     END;

    PROCEDURE weider.Rfit (zahl:integer);
     BEGIN
      fit := fit + zahl;
     END;

    FUNCTION weider.getfit:integer;
     BEGIN
      getfit := fit;
     END;

    FUNCTION weider.getgefahr:boolean;
     BEGIN
      getgefahr := gefahr;
     END;


    FUNCTION weider.getverteidigen:boolean;
     BEGIN
      getverteidigen := verteidigen;
     END;

    FUNCTION weider.getfressen:boolean;
     BEGIN
      getfressen := Rn;
     END;

  CONSTRUCTOR rauber.init;
   BEGIN
   END;

  DESTRUCTOR rauber.done;
   BEGIN
   END;

  function rauber.rloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;
   VAR z:integer;
   BEGIN
     z := 0;
     IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(rauber)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber)
     THEN z := z+1;
     IF z > 3 THEN rloeschen := true
              ELSE rloeschen := false;

   END;
  CONSTRUCTOR nahrung.init;
   BEGIN
   END;

  DESTRUCTOR nahrung.done;
   BEGIN
   END;

  function nahrung.nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;
   VAR z:integer;
   BEGIN
     z := 0;
     IF  TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.i   .)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF  TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF  TypeOF(t(.x^.i   ,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.i   .)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF  TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung)
     THEN z := z+1;
     IF z> 3 THEN nloeschen := true
             ELSE nloeschen := false;

   END;

(*----------------------- Prozeduren -----------------*)
FUNCTION test:CHAR;
 VAR Z:integer;
 BEGIN
  z := random(2);
  IF z = 0
   THEN test := '0'
   ELSE test := '1'
 END;
PROCEDURE aufbaugene;
 VAR z,z1 :integer;
 BEGIN
  NEW(Wgen);
  NEW(Agen);
  Wgen := Agen;
  FOR z1 := 1 TO 6 DO Agen^.g(.z1.) := test;
  NEW(Ngen);
  Ngen^.vor := Agen;
  Agen^.nach := Ngen;
  Agen := Ngen;
  FOR z := 1 TO 15
   DO
    BEGIN
     FOR z1 := 1 TO 6 DO Agen^.g(.z1.) := test;
     NEW(Ngen);
     Ngen^.vor := Agen;
     Agen^.nach := Ngen;
     Agen := Ngen;
    END;
  Agen^.nach := Wgen;
  Wgen^.vor := Agen;
 END;
PROCEDURE abbaugene(z:TPgen);
 BEGIN
  IF z <> Wgen THEN abbaugene(z^.nach);
  dispose(z)
 END;

PROCEDURE crossing_over;
 VAR
  max1,max2,
  fit,
  co1,co2  :TPweider;
  g1,g2    :TPgen;
  ch       :CHAR;
  z1,z2,z3,z4:Integer;
 BEGIN
 sound(440);delay(100);nosound;
 NEW(max1,init);
 NEW(max2,init);
 NEW(fit,init);
 NEW(co1,init);
 NEW(co2,init);
 NEW(g1);
 NEW(g2);
 max1 := Wweider;
 max2 := Wweider^.nach;
 fit^.fit := 0;
 fit^.gen := max1^.gen;
 REPEAT
  IF fit^.getfit < max1^.getfit
   THEN BEGIN
         fit^.fit := max1^.getfit;
         fit^.gen   := max1^.gen;
        END;
  Max1 := max1^.nach;
  UNTIL max1 = Wweider;
  Wweider^.gen := fit^.gen;
  max1 := Wweider;
  fit^.fit  := 0;
  fit^.gen  := max2^.gen;
  REPEAT
  IF fit^.getfit < max2^.getfit
   THEN BEGIN
         fit^.fit := max2^.getfit;
         fit^.gen   := max2^.gen;
        END;
  max2 := max2^.nach;
  UNTIL max2 = Wweider;
  Wweider^.nach^.gen := fit^.gen;
  max2 := Wweider^.nach;
  co1 := max2^.nach;
  co2 := co1^.nach;
  g1^.g := max1^.gen^.g;
  g2^.g := max2^.gen^.g;
  max1^.fit := maxfit;
  max2^.fit := maxfit;
  REPEAT
  z1 := random(6)+1;
  z2 := random(6)+1;
  Co1^.gen^.g := g1^.g;
  co1^.fit := maxfit;
  Co2^.gen^.g := g2^.g;
  co2^.fit := maxfit;
  ch:=co1^.gen^.g(.z1.);
  co1^.gen^.g(.z1.):=co2^.gen^.g(.z2.);
  co2^.gen^.g(.z2.):= ch;
  z1 := random(100);
  IF z1 = 0
   THEN
    BEGIN
     sound(1000);delay(100);nosound;
     z1 := random(6)+1;
     z2 := random(6)+1;
     z3 :=random(2);
     z4 := random(2);
     IF z3 = 1
      THEN co1^.gen^.g(.z1.):='1'
      ELSE co1^.gen^.g(.z1.):='0';
     IF z4 = 1
      THEN co2^.gen^.g(.z2.):='1'
      ELSE co2^.gen^.g(.z2.):='0';
    END;
  co1 := co2^.nach;
  co2 := co2^.nach^.nach;
  UNTIL co1 = Wweider;
  Aweider := Wweider;
  REPEAT
    IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true
                                   ELSE Aweider^.Fn := false;
    IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg  := true
                                   ELSE Aweider^.Fg  := false;
    IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true
                                   ELSE Aweider^.Rn := false;
    IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true
                                   ELSE Aweider^.Rg := false;
    IF Aweider^.gen^.g(.Fk.) = '1' THEN Aweider^.Fk := true
                                   ELSE Aweider^.Fk := false;                               
    IF Aweider^.gen^.g(.Rk.) = '1' THEN Aweider^.Rk := true
                                   ELSE Aweider^.Rk := false;
    Aweider := Aweider^.nach;
  UNTIL Aweider = Wweider;
 END;

PROCEDURE aufbauweider;
 VAR z :integer;
 BEGIN
 NEW(Wweider,init);
 NEW(Aweider,init);
 NEW(Nweider,init);
 NWEIDER^.leer;
 Nweider := Wweider;
 Aweider := Nweider;
 Agen := Wgen;
 Aweider^.fit := maxfit;
 Aweider^.gen := Agen;
 IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true
                                ELSE Aweider^.Fn := false;
 IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg  := true
                                ELSE Aweider^.Fg  := false;
 IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true
                                ELSE Aweider^.Rn := false;
 IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true
                                ELSE Aweider^.Rg := false;
 IF Aweider^.gen^.g(.Fk.) = '1' THEN Aweider^.Fk := true
                                ELSE Aweider^.Fk := false;                               
 IF Aweider^.gen^.g(.Rk.) = '1' THEN Aweider^.Rk := true
                                ELSE Aweider^.Rk := false;                                
 FOR z := 1 TO 15
  DO
   BEGIN
    NEW(Nweider,init);
    Nweider^.leer;
    Aweider^.nach := Nweider;
    Nweider^.vor  := Aweider;
    Aweider := Nweider;
    Agen := Agen^.nach;
    Aweider^.gen  := Agen;
    IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true
                                   ELSE Aweider^.Fn := false;
    IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg  := true
                                   ELSE Aweider^.Fg  := false;
    IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true
                                   ELSE Aweider^.Rn := false;
    IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true
                                   ELSE Aweider^.Rg := false;
    IF Aweider^.gen^.g(.Fk.) = '1' THEN Aweider^.Fk := true
                                   ELSE Aweider^.Fk := false;                               
    IF Aweider^.gen^.g(.Rk.) = '1' THEN Aweider^.Rk := true
                                   ELSE Aweider^.Rk := false;                                   

   END;
    Aweider^.nach := Wweider;
    Wweider^.vor  := Aweider;
 END;
PROCEDURE abbauweider(z:TPweider);
 BEGIN
  IF z <> Wweider THEN abbauweider(z^.nach);
  DISPOSE(z,done);
 END;
PROCEDURE aufbaurauber;
 BEGIN
  NEW(Wrauber,init)
 END;
PROCEDURE abbaurauber;
 BEGIN
  DISPOSE(Wrauber,done);
 END;
PROCEDURE aufbaunahrung;
 BEGIN
  new(Wnahrung,init);
 END;
PROCEDURE abbaunahrung;
 BEGIN
  DISPOSE(Wnahrung,done);
 END;
PROCEDURE aufbauzelle;
 BEGIN
  NEW(Wzelle,init)
 END;
PROCEDURE abbauzelle;
 BEGIN
  DISPOSE(Wzelle,done)
 END;
PROCEDURE aufbau;
 VAR z:integer;
 BEGIN
  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 = 69;
  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:Tzahl);
 BEGIN
  IF x^.n <> xa THEN abbaux(x^.n);
  dispose(x);
 END;

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

FUNCTION neu (VAR r:Ttorus; VAR x,y:Tzahl):TPzelle;
 VAR z:TPzelle;
 BEGIN
     z := r(.x^.i,y^.i.);
     IF TypeOF(z^) = TypeOf(rauber)
      THEN
       BEGIN
        IF Wrauber^.rloeschen(x,y,r) THEN neu := Wzelle
                                     ELSE neu := z;
       END
      ELSE
       BEGIN
        IF TypeOF(z^) = TypeOf(nahrung)
         THEN
          BEGIN
           IF Wnahrung^.nloeschen(x,y,r) THEN neu := Wzelle
                                         ELSE neu := z;
          END
         ELSE
          BEGIN
           IF TypeOF(z^) = TypeOf(weider)
            THEN
             BEGIN
               (*neu := z;*)
              Aweider := Wweider;
              REPEAT
              Aweider := Aweider^.nach
              UNTIL @Aweider^ =@z^; 
              (*Aweider^.init; schon beim Aufbau Konsturktor aufgerufen*)
              IF Aweider^.nloeschen(x,y,r)
              THEN neu := Wzelle
              ELSE
              IF Aweider^.getfit = 0
               THEN
                 neu:= Wzelle
               ELSE
                BEGIN
                 Aweider^.Rfit(stoffwechsel);
                 Aweider^.Bgefahr(x,y,r);
                 Aweider^.Rverteidigung;
                 Aweider^.Rweidererkennen(x,y,r);
                 Aweider^.Rkooperieren;
                 IF ((Aweider^.getgefahr)AND NOT(Aweider^.getverteidigen))
                  THEN
                   BEGIN
                   Aweider^.Rfit(-1*(Aweider^.getfit));
                   neu := Wzelle;
                   END
                  ELSE
                  BEGIN 
                   Aweider^.Bfutter(x,y,r);
                   Aweider^.Rfressen(x,y,r);
                   neu := @Aweider^;
                  END 
                END;
             END
            ELSE
             BEGIN
              IF TypeOF(z^) = TypeOf(zelle)
               THEN
                BEGIN
                 IF z^.nnahrung(x,y,r)
                  THEN neu:= Wnahrung
                  ELSE
                   BEGIN
                    IF z^.nrauber(x,y,r)
                     THEN neu:= Wrauber
                     ELSE
                      BEGIN
                       IF z^.nweider(x,y,r)
                       THEN neu:= Aweider
                       ELSE neu := z
                      END;
                   END
                END
             END
          END
       END
 END;

PROCEDURE status;
 BEGIN
 textbackground(red);
 textcolor(white);
 window(1,1,11,24);
 CLRSCR;gotoxy(1,1);
 WRITELN('ngfvwk fit');
 Aweider := Wweider;
 REPEAT
 writeln(Aweider^.gen^.g,' ',Aweider^.fit);
 Aweider := Aweider^.nach;
 UNTIL Aweider^.nach = Wweider;
 END;

PROCEDURE schreibe (z:TPzelle);
 BEGIN
  IF TYPEOF(z^) = TypeOf(rauber)
   THEN BEGIN textcolor(red); WRITE(char(4)) END
   ELSE
    BEGIN
     IF TypeOf(z^) = TypeOF(weider)
     THEN BEGIN textcolor(lightgreen); WRITE(char(2)) END
     ELSE
      BEGIN
       IF TypeOf(z^) = TYPEOF(nahrung)
       THEN BEGIN textcolor (yellow );Write(char(26)) END
       ELSE BEGIN textcolor(blue);WRITE(' ') END
      END;
    END

 END;
PROCEDURE spiel(VAR von,nach :Ttorus);
 BEGIN
  x:=xa;
  y:=ya;
  textbackground(blue);
  window(12,1,80,25);
  GOTOxy(1,1);
  REPEAT
   REPEAT
    nach(.x^.i,y^.i.):= (* von(.x^.i,y^.i.) ;*)neu(von,x,y); 
    schreibe(nach(.x^.i,y^.i.));
    x := x^.n
   UNTIL x =xa;
   y := y^.n
  UNTIL y =ya;
 END;

PROCEDURE zufall(VAR a:Ttorus);
 VAR z :integer;
 BEGIN
  Textbackground(blue);
  window(11,1,80,24);
  clrscr;
  GOTOxy(1,1);
  window(11,1,80,25);
  Aweider := Wweider;
  y :=ya;
  x :=xa;
  REPEAT
   REPEAT
    (*Zufallsbelegung*)
    z := random(100);
    CASE z OF
     0: a(.x^.i,y^.i.) := Wnahrung;
     1: a(.x^.i,y^.i.) := Wrauber;
     2: a(.x^.i,y^.i.) := Wzelle;
     3: BEGIN
         a(.x^.i,y^.i.):= Aweider;
         Aweider := Aweider^.nach;
        END
     ELSE  a(.x^.i,y^.i.) := Wzelle;
    END;
    schreibe(a(.x^.i,y^.i.));
    x := x^.n
   UNTIL x =xa;
   y := y^.n
  UNTIL y =ya;
  status;
  Aweider:= Wweider;
 END;


PROCEDURE hauptprogramm;
 VAR z:integer;
 BEGIN
  Window(1,25,80,25);
  textcolor(white);
  textbackground(red);
  clrscr;
  write('n Nahrung g gefahr f fressen v verteidigen w Weider erkennen k kooperieren  ');
  randomize;
  REPEAT
  zufall(bilda);
  Z := 0;
  REPEAT
     spiel(bilda,bildb);
     Status;
     spiel(bildb,bilda);
     Status;
     z := z + 1;
  Until keypressed or (z = 5);
  crossing_over;
  UNTIL KEYPRESSED
 END;
(*----------------------- Hauptprogramm --------------*)

BEGIN
checkbreak := false;
clrscr;
aufbau;
aufbaugene;
aufbauweider;
aufbaunahrung;
aufbaurauber;
aufbauzelle;
hauptprogramm;
x := xa;
abbaux(x);
Agen := Wgen;
abbaugene(Agen);
Aweider := Wweider;
abbauweider(Aweider);
abbaunahrung;
abbaurauber;
abbauzelle;
y:=ya;
abbauy(y);
window(1,1,80,25);
textbackground(black);
textcolor(white);
clrscr;
checkbreak := true;
END.