MODULE Genetic;

FROM SYSTEM    	IMPORT 	ADR, ADDRESS, INLINE;
FROM Arts      	IMPORT 	TermProcedure, CurrentLevel;
FROM Terminal	IMPORT 	waitCloseGadget;
FROM Graphics  	IMPORT  RastPortPtr, ViewPortPtr, Move, Draw, Text, SetAPen,
			LoadRGB4, ViewModes, ViewModeSet, ClipBlit, RectFill;
FROM Intuition	IMPORT	IDCMPFlags, IDCMPFlagSet, WindowFlags, WindowFlagSet,
			WindowPtr, CloseWindow,	customScreen, ScreenFlags,
			ScreenFlagSet, CloseScreen, ScreenPtr, CurrentTime,
			IntuiMessagePtr;
FROM Exec	IMPORT 	GetMsg, WaitPort, ReplyMsg;
FROM RandomNumber IMPORT RND, PutSeed;
FROM Conversions  IMPORT ValToStr;
FROM Strings	IMPORT	Length;
FROM InOut	IMPORT	WriteString, ReadInt;
FROM IntuiSup	IMPORT	CreateWindow, CreateScreen;


CONST 	WIDTH  		= 640;		HEIGHT 		= 256;
	WIDTH2		= 300;		HEIGHT2		= 120;
	DEPTH		= 2;

	MaxElek		= 24;
	MaxPeriod	= 24;		MaxLauf		= 100;
	MaxZustand	= 16;		MaxOut		= 16;

	MaxAS		= MaxZustand * 2 * MaxOut;
	MaxChar		= 5;

	BOTTOM		= HEIGHT2 - 15;

	StpX		= WIDTH2       DIV MaxLauf;
	StpY		= (HEIGHT2-10) DIV MaxLauf;

	rot		= 1;		grun		= 2;
	blau		= 3;		black		= 0;

	ESC		= 045H;		CHROM		= 033H;


TYPE	ChromTyp	= ARRAY [0..MaxElek-1], [0..MaxAS-1] 	OF INTEGER;
	ElekArr		= ARRAY [0..MaxElek-1] 			OF INTEGER;
	UmweltTyp	= ARRAY [0..MaxPeriod-1] 		OF INTEGER;
	StrTyp		= ARRAY [0..MaxChar-1]			OF CHAR;


VAR	scr			: ScreenPtr;
	win, win2		: WindowPtr;
	vp			: ViewPortPtr;
 	rp, rp2			: RastPortPtr;
 	Level			: INTEGER;
	x, y,
	xTop, yTop, xBot, yBot	: INTEGER;

	AnzElek, AnzPeriod,
	AnzZustand, AnzOut,
	AnzAS, AnzMut,
	Intervall, OberGrenze	: INTEGER;

	Chrom			: ChromTyp;
	Zustand, Treffer	: ElekArr;
	Umwelt			: UmweltTyp;

	MaxCol, MaxLine		: INTEGER;



PROCEDURE WriteS (rp : RastPortPtr; Str : ARRAY OF CHAR);
VAR len, xx : INTEGER;
BEGIN
 	len := Length (Str);
 	Text (rp, ADR(Str), len);
 	xx := len*9;
 	INC (x, xx);
 	Move (rp, x, y);
END WriteS;

PROCEDURE WriteC (rp : RastPortPtr; Chr : CHAR);
BEGIN
 	Text (rp, ADR(Chr), 1);
 	INC (x, 9);
 	Move (rp, x, y);
END WriteC;

PROCEDURE SetPos (rp : RastPortPtr; col, line : INTEGER);
BEGIN
	x := col * 9;	y := 10 + (line * 9);
	Move (rp, x, y)
END SetPos;

PROCEDURE GetSize (win : WindowPtr; VAR col, line : INTEGER);
BEGIN
	col  := (win^.width  - 10) DIV 9;
	line := (win^.height - 10) DIV 9
END GetSize;

PROCEDURE ClearEOL (win : WindowPtr; col, line : INTEGER);
VAR xx, yy : INTEGER;
BEGIN
	xx := col * 9;	yy := 12 + (line * 9);
	SetAPen (win^.rPort, 0);
	RectFill (win^.rPort, xx, yy, win^.width, yy+9)
END ClearEOL;

PROCEDURE ClearTo (win : WindowPtr; Bcol, Bline, Ecol, Eline : INTEGER);
VAR i, xx, yy : INTEGER;
BEGIN
	ClearEOL (win, Bcol, Bline);
	FOR i:=Bline+1 TO Eline-1 DO
		ClearEOL (win, 0, i)
	END;
	yy := 12 + (Eline * 9);	xx := Ecol * 9;
	RectFill (win^.rPort, 0, yy, xx, yy+9)
END ClearTo;

PROCEDURE MaxMin (Top, Bot : INTEGER);
VAR y : INTEGER;
BEGIN
(* --------- Bot ---------------- *)
	y := Treffer [Bot];
	SetAPen (rp2, blau);
	Move (rp2, xBot,      BOTTOM - (yBot * StpY));
	Draw (rp2, xBot+StpX, BOTTOM - (y    * StpY));
	yBot := y;
(* --------- Top ---------------- *)
	y := Treffer [Top];
	SetAPen (rp2, rot);
	Move (rp2, xTop,      BOTTOM - (yTop * StpY));
	Draw (rp2, xTop+StpX, BOTTOM - (y    * StpY));
	yTop := y;
	IF ((xTop+StpX*5) >= WIDTH2) THEN
		ClipBlit (rp2, 0,0, rp2, -StpX,0, WIDTH2, HEIGHT2, 0C0H);
	ELSE
		INC (xTop, StpX);	INC (xBot, StpX)
	END
END MaxMin;

PROCEDURE ShowElek (Elek, y, farb : INTEGER; off : BOOLEAN);
VAR i, Gen	: INTEGER;
    chr		: CHAR;
    Tref	: StrTyp;
    err		: BOOLEAN;
BEGIN
	SetAPen (rp, grun);
	SetPos (rp, 0, y);
	IF NOT off THEN
		FOR i:=0 TO AnzAS-1 DO
			Gen := Chrom [Elek] [i];
			IF ODD (i) THEN
				INC (Gen, 65);
				chr := CHR (Gen)
			ELSE
				INC (Gen, 48);
				chr := CHR (Gen)
			END;
			WriteC (rp, chr);	WriteC (rp, " ");
	END	END;
	ValToStr (Treffer [Elek], TRUE, Tref, 10, MaxChar, " ", err);
	WriteS (rp, "  :");  SetAPen (rp, farb); WriteS (rp, Tref)
END ShowElek;

PROCEDURE TrefferQuote (DurchLauf, Top, Bot : INTEGER; off : BOOLEAN);
VAR i, Farbe 	: INTEGER;
    str		: StrTyp;
    err		: BOOLEAN;
BEGIN
	ValToStr (DurchLauf, TRUE, str, 10, MaxChar, " ", err);
	SetPos (rp, 25, 0);	SetAPen (rp, rot);	WriteS (rp, str);
	FOR i:=0 TO AnzElek-1 DO
		IF (i=Top) THEN Farbe:=rot
		ELSIF (i=Bot) THEN Farbe:=blau
		ELSE Farbe:=grun END;
		ShowElek (i, i+2, Farbe, off)
	END;
	MaxMin (Top, Bot)
END TrefferQuote;

PROCEDURE UmweltFolge;
VAR i, Nox	: INTEGER;
    chr		: CHAR;
BEGIN
	SetAPen (rp, rot);
	SetPos (rp, 15, MaxLine-1);
	FOR i:=0 TO AnzPeriod-1 DO
		Nox := Umwelt [i];
		INC (Nox, 48);
		chr := CHR (Nox);
		WriteC (rp, chr); WriteC (rp, " ")
	END;
	SetAPen (rp2, grun);
	Move (rp2, xTop, 0); Draw (rp2, xTop, HEIGHT2)
END UmweltFolge;

PROCEDURE PrepWindows;
BEGIN
	GetSize (win, MaxCol, MaxLine);
	SetAPen (rp, grun);
	SetPos (rp, 1, 0);
	WriteS (rp, "Anzahl der Generationen : ");
	SetPos (rp, 1, MaxLine-1); WriteS (rp, "Umweltfolge : ");

END PrepWindows;

PROCEDURE NewSeed;
VAR sec, mic : LONGINT;
BEGIN
	CurrentTime (ADR(sec), ADR(mic));
	PutSeed (mic)
END NewSeed;

PROCEDURE Survive;
VAR i, j, Lokus, Folg, Next : INTEGER;
BEGIN
	FOR i:=0 TO MaxLauf-1 DO
		Folg := i MOD AnzPeriod;
		FOR j:=0 TO AnzElek-1 DO
			Lokus := (2*AnzOut * Zustand [j]) + (2 * Umwelt [Folg]);

			Zustand [j] := Chrom [j][Lokus+1];

			Next := (i+1) MOD AnzPeriod;
			IF (Umwelt [Next] = Chrom [j][Lokus]) THEN
				INC (Treffer [j])
	END	END	END
END Survive;

PROCEDURE DasBeste (VAR Top, Bot : INTEGER);
VAR i, TopCase, BotCase : INTEGER;
BEGIN
	TopCase := -1;	BotCase := 10000;
	FOR i:=0 TO AnzElek-1 DO
		IF (Treffer [i] > TopCase) THEN
			TopCase := Treffer [i];
			Top     := i
		END;
		IF (Treffer [i] < BotCase) THEN
			BotCase := Treffer [i];
			Bot     := i
		END
	END
END DasBeste;

PROCEDURE Paarung (Top, Bot : INTEGER);
VAR i, Start, Stop, Part : INTEGER;
BEGIN
	NewSeed;
	Start := RND (AnzAS);
	Stop  := RND (AnzAS);
	Part  := RND (AnzElek);
	i := Start;
	REPEAT
		Chrom [Bot][i] := Chrom [Part][i];
		INC (i);
		IF (i=AnzAS) THEN i:=0 END
	UNTIL i = Stop;
	REPEAT
		Chrom [Bot][i] := Chrom [Top][i];
		INC (i);
		IF (i=AnzAS) THEN i:=0 END
	UNTIL i=Start
END Paarung;

PROCEDURE Mutation (Top : INTEGER);
VAR i, Elek, Lokus, Anzahl : INTEGER;
BEGIN
	Elek:=0;
	Anzahl := RND (AnzMut);
	FOR i:=0 TO Anzahl DO
		REPEAT
			Elek   := RND (AnzElek)
		UNTIL Elek#Top;
		Lokus  := RND (AnzAS);
		IF ODD (Lokus) THEN
			Chrom [Elek] [Lokus] := RND (AnzZustand)
		ELSE
			Chrom [Elek] [Lokus] := RND (AnzOut)
	END	END
END Mutation;

PROCEDURE MutWelt;
VAR i : INTEGER;
BEGIN
	NewSeed;
	i := RND (AnzPeriod);
	Umwelt [i] := RND (AnzOut)
END MutWelt;

PROCEDURE CleanTreffer;
VAR i : INTEGER;
BEGIN
	FOR i:=0 TO AnzElek-1 DO
		Treffer [i] := 0
	END
END CleanTreffer;

PROCEDURE Manage;
VAR i, j, TopElek, BotElek	: INTEGER;
    Msg				: IntuiMessagePtr;
    class			: IDCMPFlagSet;
    code			: CARDINAL;
    quit, off			: BOOLEAN;
BEGIN
	i:=0;	j:=0;	TopElek:=0;	BotElek:=0;	quit:=FALSE;
	off:=TRUE;	Msg := NIL;
	UmweltFolge;
	REPEAT
		CleanTreffer;
		Survive;
		DasBeste (TopElek, BotElek);
		INC (i);	INC (j);
		TrefferQuote (j, TopElek, BotElek, off);
		IF (RND(100) > 80) THEN
			Paarung (TopElek, BotElek)
		END;
		Mutation (TopElek);
		IF (Intervall > 0) THEN
			IF (i>Intervall) THEN
				MutWelt;
				UmweltFolge;
				i:=0
		END	END;
		Msg := GetMsg (win^.userPort);
		WHILE Msg # NIL DO
			class := Msg^.class;	code := Msg^.code;
			ReplyMsg (Msg);
			IF (rawKey IN class) THEN
				CASE code OF
				 ESC   : quit := TRUE		|
				 CHROM : ClearTo (win, 0,1, MaxCol, AnzElek);
				 	 off := NOT off		|
				ELSE END
			END;
			Msg := GetMsg (win^.userPort)
		END
	UNTIL quit OR (Treffer [TopElek] >= OberGrenze)
END Manage;

PROCEDURE InitElek;
VAR i, j : INTEGER;
BEGIN
	NewSeed;
	FOR i:=0 TO AnzElek-1 DO
		Zustand [i] := RND (AnzZustand)
	END;
	FOR i:=0 TO AnzElek-1 DO
		FOR j:=0 TO AnzAS-2 BY 2 DO
			Chrom [i] [j]   := RND (AnzOut);
			Chrom [i] [j+1] := RND (AnzZustand)
	END	END
END InitElek;

PROCEDURE InitWelt;
VAR i : INTEGER;
BEGIN
	NewSeed;
	FOR i:=0 TO AnzPeriod-1 DO
		Umwelt [i] := RND (AnzOut)
	END
END InitWelt;

PROCEDURE InitVars;
BEGIN
	xTop	:= 0;	xBot	:= 0;
	yTop	:= 0;	yBot	:= 0;
	WriteString ("Anzahl Eleks    (24) : "); ReadInt (AnzElek);
	WriteString ("Anzahl Perioden (24) : "); ReadInt (AnzPeriod);
	WriteString ("Anzahl Zustände (16) : "); ReadInt (AnzZustand);
	WriteString ("Anzahl Ausgaben (16) : "); ReadInt (AnzOut);
	WriteString ("OberGrenze           : "); ReadInt (OberGrenze);
	WriteString ("Umwelt-Intervall     : "); ReadInt (Intervall);
	AnzAS  := AnzZustand * 2 * AnzOut;
	AnzMut := (AnzAS  * AnzElek) DIV 50
END InitVars;

PROCEDURE Colors;	(* $E- *)
BEGIN
	INLINE (0000H, 0F70H, 09D0H, 00AFH)
END Colors;

PROCEDURE Cleanup;
BEGIN
 IF Level >= CurrentLevel () THEN
  IF win#NIL THEN CloseWindow (win) END;
  IF win2#NIL THEN CloseWindow (win2) END;
  IF scr#NIL THEN CloseScreen (scr) END
 END
END Cleanup;

PROCEDURE Growup;
BEGIN
 win:=NIL;	win2:=NIL; 	rp2:=NIL;	scr:=NIL;	vp:=NIL;
 rp:=NIL;
 waitCloseGadget:=FALSE;	x:=0;		y:=0;
 Level:=CurrentLevel();  TermProcedure (Cleanup);

 scr := CreateScreen (WIDTH, HEIGHT, DEPTH,0,1, ViewModeSet{hires},NIL,NIL,NIL);
 vp := ADR (scr^.viewPort);
 LoadRGB4 (vp, ADR(Colors), 4);

 win := CreateWindow (0,0,WIDTH,HEIGHT, black,rot,
 	IDCMPFlagSet {mouseButtons, rawKey, activeWindow},
 	WindowFlagSet {gimmeZeroZero, windowActive, activate}, NIL, scr,
 	NIL,NIL, customScreen);
 rp := win^.rPort;

 win2 := CreateWindow (WIDTH-WIDTH2,HEIGHT-HEIGHT2,WIDTH2, HEIGHT2, black, rot,
 	IDCMPFlagSet {mouseButtons}, WindowFlagSet {gimmeZeroZero, windowDrag},
 	NIL,scr,NIL,NIL, customScreen);
 rp2 := win2^.rPort;

 PrepWindows
END Growup;


BEGIN
 InitVars;
 InitWelt;
 InitElek;

 Growup;

 Manage;

 WaitPort (win2^.userPort)

END Genetic.