├── beute.jpg ├── chess.jpg ├── genalg.jpg ├── macht.jpg ├── CHESSTEG.PAS ├── primaten.jpg ├── primaten.pas ├── LEXIKON.ASC ├── README.md ├── status.pas ├── beute.pas ├── PARSER.PAS ├── genalg.pas └── genalgESS.pas /beute.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pkoopongithub/pascal/main/beute.jpg -------------------------------------------------------------------------------- /chess.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pkoopongithub/pascal/main/chess.jpg -------------------------------------------------------------------------------- /genalg.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pkoopongithub/pascal/main/genalg.jpg -------------------------------------------------------------------------------- /macht.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pkoopongithub/pascal/main/macht.jpg -------------------------------------------------------------------------------- /CHESSTEG.PAS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pkoopongithub/pascal/main/CHESSTEG.PAS -------------------------------------------------------------------------------- /primaten.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pkoopongithub/pascal/main/primaten.jpg -------------------------------------------------------------------------------- /primaten.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pkoopongithub/pascal/main/primaten.pas -------------------------------------------------------------------------------- /LEXIKON.ASC: -------------------------------------------------------------------------------- 1 | 12345------ 2 | PN***TOBIAS 3 | V****BETRACHTET 4 | V****SIEHT 5 | ART**DEN 6 | N****TURM 7 | N****HUND 8 | PRAEPMIT 9 | ART**DEM 10 | N****FERNROHR -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pascal 2 | Console applications: 3 | Cellular automata, mini-max, alpha-beta, genetic algorithms 4 | 5 | ![screenshot](./beute.jpg) 6 | ![screenshot](./genalg.jpg) 7 | -------------------------------------------------------------------------------- /status.pas: -------------------------------------------------------------------------------- 1 | PROGRAM status; 2 | (****************************************************************) 3 | (* Paul Koop M.A. Netzhautsimulation *) 4 | (* (vgl. MAHOWALD, M.A. MEAD, C. SdW7/91S.64ff) *) 5 | (* Die Simulation wurde ursprunglich entwickelt, *) 6 | (* um die Verwendbarkeit *) 7 | (* von neuronalen Netzen (Achtung: nicht neuralen Netzen) *) 8 | (* fuer die Algorithmisch Rekursive Sequanzanalyse *) 9 | (* zu ueberpruefen *) 10 | (* Modellcharakter hat allein der Quelltext. Eine Compilierung *) 11 | (* dient nur als Falsifikationsversuch *) 12 | (****************************************************************) 13 | USES dos,crt; 14 | (*-------------------------------------- Datenstruktur ---------*) 15 | CONST 16 | l = char(2); 17 | 18 | lebendig = true; 19 | cursor = white; 20 | TYPE 21 | s = 0..15; 22 | raum = array(.1..80,1..24.) of s; 23 | zahl = ^inhalt; 24 | inhalt = RECORD 25 | i:integer; 26 | v:zahl; 27 | n:zahl; 28 | END; 29 | VAR 30 | a,b:raum; 31 | n,x,y,xa,ya:zahl; 32 | 33 | (*----------------------------------- Prozeduren ----------------*) 34 | PROCEDURE aufbau; 35 | VAR z:integer; 36 | BEGIN 37 | randomize; 38 | z := 1; 39 | new(n); 40 | xa := n; 41 | x := n; 42 | x^.i := z; 43 | REPEAT 44 | z := z +1; 45 | new(n); 46 | x^.n := n; 47 | n^.v := x; 48 | x := n; 49 | x^.i := z; 50 | UNTIL z = 80; 51 | x^.n := xa; 52 | xa^.v := x; 53 | 54 | z := 1; 55 | new(n); 56 | ya := n; 57 | y := n; 58 | y^.i := z; 59 | REPEAT 60 | z := z +1; 61 | new(n); 62 | y^.n := n; 63 | n^.v := y; 64 | y := n; 65 | y^.i := z; 66 | UNTIL z = 24; 67 | y^.n := ya; 68 | ya^.v := y; 69 | END; 70 | 71 | PROCEDURE abbaux(x:zahl); 72 | BEGIN 73 | IF x^.n <> xa THEN abbaux(x^.n); 74 | dispose(x); 75 | END; 76 | 77 | PROCEDURE abbauy(y:zahl); 78 | BEGIN 79 | IF y^.n <> ya THEN abbauy(y^.n); 80 | dispose(y); 81 | END; 82 | 83 | FUNCTION neu (VAR r:raum; VAR x,y:zahl):s; 84 | VAR z:integer; 85 | BEGIN 86 | (* z := 0; 87 | z:=z + r(.x^.v^.i,y^.v^.i.); 88 | z:=z + r(.x^.i ,y^.v^.i.); 89 | z:=z + r(.x^.n^.i,y^.v^.i.); 90 | z:=z + r(.x^.v^.i,y^.i .); 91 | z:=z + r(.x^.n^.i,y^.i .); 92 | z:=z + r(.x^.v^.i,y^.n^.i.); 93 | z:=z + r(.x^.i ,y^.n^.i.); 94 | z:=z + r(.x^.n^.i,y^.n^.i.); 95 | Z:= z div 8; 96 | *) 97 | z := 0; 98 | z := z + 99 | ( 100 | r(.x^.v^.v^.i,y^.v^.v^.i.)+r(.x^.v^.i,y^.v^.v^.i.)+r(.x^.i,y^.v^.v^.i.)+r(.x^.n^.i,y^.v^.v^.i.)+r(.x^.n^.n^.i,y^.v^.v^.i.) 101 | +r(.x^.v^.v^.i,y^.v^.i.)+r(.x^.v^.i,y^.v^.i.)*2+r(.x^.i,y^.v^.i.)*2+r(.x^.n^.i,y^.v^.i.)*2+r(.x^.n^.n^.i,y^.v^.i.) 102 | +r(.x^.v^.v^.i,y^.i.)+r(.x^.v^.i,y^.i.)*2+r(.x^.n^.i,y^.i.)*2+r(.x^.n^.n^.i,y^.i.) 103 | +r(.x^.v^.v^.i,y^.n^.i.)+r(.x^.v^.i,y^.n^.i.)*2+r(.x^.i,y^.n^.i.)*2+r(.x^.n^.i,y^.n^.i.)*2+r(.x^.n^.n^.i,y^.n^.i.) 104 | +r(.x^.v^.v^.i,y^.n^.n^.i.)+r(.x^.v^.i,y^.n^.n^.i.)+r(.x^.i,y^.n^.n^.i.)+r(.x^.n^.i,y^.n^.n^.i.)+r(.x^.n^.n^.i,y^.n^.n^.i.) 105 | ); 106 | z := z div 32; 107 | IF (r(.x^.i,y^.i.) = z) 108 | THEN 109 | neu := 0 110 | ELSE 111 | neu := abs(z-r(.x^.i,y^.i.)) 112 | END; 113 | 114 | PROCEDURE text_anfang; 115 | BEGIN 116 | window(1,25,80,25); 117 | textbackground(red); 118 | textcolor(white); 119 | clrscr; 120 | write('Koop Editor Zufall Cursor Reiz+ Reiz- Start'); 121 | gotoxy(1,1); 122 | textcolor(2); 123 | textbackground(black); 124 | window(1,1,80,24);clrscr;window(1,1,80,25); 125 | END; 126 | 127 | PROCEDURE text_ende; 128 | BEGIN 129 | gotoxy(1,25); 130 | textbackground(red); 131 | textcolor(white); 132 | write('Koop Status neu Editieren Ende'); 133 | gotoxy(1,1); 134 | textcolor(2); 135 | textbackground(black); 136 | END; 137 | 138 | PROCEDURE zufall(VAR von:raum); 139 | VAR x,y:integer; 140 | BEGIN 141 | gotoxy(1,1); 142 | FOR y := 1 TO 24 143 | DO 144 | FOR x := 1 TO 80 145 | DO 146 | BEGIN 147 | von(.x,y.):=random(16); 148 | textcolor(von(.x,y.)); 149 | write(l) 150 | END; 151 | END; 152 | 153 | PROCEDURE editor (VAR von:raum); 154 | var 155 | ch1,ch2 : char; 156 | xz,yz,z:integer; 157 | begin 158 | z :=0; 159 | x := xa; 160 | y:=ya; 161 | randomize; 162 | text_anfang; 163 | gotoxy(1,1); 164 | textcolor(0); 165 | FOR yz := 1 TO 24 166 | DO 167 | FOR xz := 1 TO 80 168 | DO 169 | BEGIN 170 | von(.xz,yz.) := 0; 171 | write(l); 172 | END; 173 | repeat 174 | textcolor(cursor); 175 | ch1 := readkey; 176 | IF ch1 =#0 177 | THEN 178 | BEGIN 179 | ch2 := readkey; 180 | CASE ch2 OF 181 | #68 : BEGIN 182 | zufall(von); 183 | END; 184 | #72 : y :=y^.v; 185 | #80 : y :=y^.n; 186 | #75 : x :=x^.v; 187 | #77 : x :=x^.n; 188 | #71 : BEGIN 189 | y := y^.v; 190 | x := x^.v; 191 | END; 192 | #73 : BEGIN 193 | y := y^.v; 194 | x := x^.n; 195 | END; 196 | #81 : BEGIN 197 | y := y^.n; 198 | x := x^.n; 199 | END; 200 | #79 : BEGIN 201 | y := y^.n; 202 | x := x^.v; 203 | END; 204 | 205 | #82 : IF z < 15 THEN z :=z +1 ELSE write(char(7)); 206 | #83 : IF z > 0 THEN z :=z -1 ELSE write(char(7)); 207 | ELSE 208 | write(char(7)) 209 | END; 210 | gotoxy(x^.i,y^.i); 211 | von(.x^.i,y^.i.) := z; 212 | textcolor(z); 213 | write(l); 214 | textcolor(cursor); 215 | gotoxy(x^.i,y^.i); 216 | END 217 | ELSE write(char(7)); 218 | until ch1 = #13; 219 | text_ende; 220 | END; 221 | 222 | 223 | PROCEDURE korrektor (VAR von:raum); 224 | var 225 | ch1,ch2 : char; 226 | xz,yz,z:integer; 227 | begin; 228 | randomize; 229 | x:=xa;y:=ya; 230 | text_anfang; 231 | gotoxy(1,1); 232 | z := 0; 233 | FOR yz := 1 TO 24 234 | DO 235 | FOR xz := 1 TO 80 236 | DO 237 | BEGIN 238 | textcolor(von(.xz,yz.)); 239 | write(l); 240 | END; 241 | repeat 242 | textcolor(cursor); 243 | ch1 := readkey; 244 | IF ch1 =#0 245 | THEN 246 | BEGIN 247 | ch2 := readkey; 248 | CASE ch2 OF 249 | #68 : BEGIN 250 | zufall(von); 251 | END; 252 | #72 : y :=y^.v; 253 | #80 : y :=y^.n; 254 | #75 : x :=x^.v; 255 | #77 : x :=x^.n; 256 | #71 : BEGIN 257 | y := y^.v; 258 | x := x^.v; 259 | END; 260 | #73 : BEGIN 261 | y := y^.v; 262 | x := x^.n; 263 | END; 264 | #81 : BEGIN 265 | y := y^.n; 266 | x := x^.n; 267 | END; 268 | #79 : BEGIN 269 | y := y^.n; 270 | x := x^.v; 271 | END; 272 | 273 | #82 : IF z < 15 THEN z :=z +1 ELSE write(char(7)); 274 | #83 : IF z > 0 THEN z :=z -1 ELSE write(char(7)); 275 | ELSE 276 | write(char(7)) 277 | END; 278 | gotoxy(x^.i,y^.i); 279 | von(.x^.i,y^.i.) := z; 280 | textcolor(z); 281 | write(l); 282 | textcolor(cursor); 283 | gotoxy(x^.i,y^.i); 284 | END 285 | ELSE write(char(7)); 286 | until ch1 = #13; 287 | text_ende; 288 | END; 289 | 290 | 291 | 292 | PROCEDURE spiel(VAR von,nach :raum); 293 | BEGIN 294 | y :=ya; 295 | x :=xa; 296 | REPEAT 297 | REPEAT 298 | nach(.x^.i,y^.i.):=neu(von,x,y); 299 | textcolor(nach(.x^.i,y^.i.)); 300 | write(l); 301 | x := x^.n 302 | UNTIL x =xa; 303 | y := y^.n 304 | UNTIL y =ya; 305 | END; 306 | 307 | PROCEDURE hauptprogramm; 308 | var 309 | ch1,ch2 : char; 310 | xz,yz:integer; 311 | begin 312 | IF keypressed THEN REPEAT ch1 := readkey UNTIL not(keypressed); 313 | repeat 314 | IF keypressed 315 | THEN 316 | BEGIN 317 | ch1 := readkey; 318 | IF ch1 =#0 319 | THEN 320 | BEGIN 321 | ch2 := readkey; 322 | CASE ch2 OF 323 | #59: BEGIN 324 | x := xa; 325 | abbaux(x); 326 | y := ya; 327 | abbauy(y); 328 | aufbau; 329 | editor(a); 330 | END; 331 | #60: korrektor(a); 332 | ELSE 333 | END; 334 | END 335 | ELSE; 336 | END 337 | ELSE 338 | BEGIN 339 | gotoxy(1,1); 340 | spiel(a,b); 341 | gotoxy(1,1); 342 | spiel(b,a); 343 | END 344 | until ch1 = #13; 345 | END; 346 | 347 | (*------------------------------- Hauptprogramm -------------------*) 348 | BEGIN 349 | checkbreak := false; 350 | aufbau; 351 | editor(a); 352 | hauptprogramm; 353 | x := xa; 354 | abbaux(x); 355 | y := ya; 356 | abbauy(y); 357 | textbackground(black); 358 | textcolor(white); 359 | clrscr; 360 | checkbreak := true; 361 | END. 362 | (**************************************** ENDE *******************) 363 | 364 | -------------------------------------------------------------------------------- /beute.pas: -------------------------------------------------------------------------------- 1 | 2 | PROGRAM beute; 3 | (******************************************************************) 4 | (* Paul Koop M.A. Raeuber Beute System *) 5 | (* Die Simulation wurde ursprunglich entwickelt, *) 6 | (* um die Verwendbarkeit von Zellularautomaten *) 7 | (* fuer die Algorithmisch Rekursive Sequanzanalyse *) 8 | (* zu ueberpruefen *) 9 | (* Modellcharakter hat allein der Quelltext. Eine Compilierung *) 10 | (* dient nur als Falsifikationsversuch *) 11 | (******************************************************************) 12 | 13 | USES dos,crt; 14 | (*---------------------------- Datenstruktur ---------------------*) 15 | CONST 16 | 17 | l = char(2); 18 | 19 | TYPE 20 | s = 0..10; 21 | raum = array(.1..80,1..24.) of s; 22 | zahl = ^inhalt; 23 | inhalt = RECORD 24 | i:integer; 25 | v:zahl; 26 | n:zahl; 27 | END; 28 | VAR 29 | a,b:raum; 30 | n,x,y,xa,ya:zahl; 31 | 32 | (*---------------------------- Prozeduren -----------------------*) 33 | PROCEDURE aufbau; 34 | VAR z:integer; 35 | BEGIN 36 | randomize; 37 | z := 1; 38 | new(n); 39 | xa := n; 40 | x := n; 41 | x^.i := z; 42 | REPEAT 43 | z := z +1; 44 | new(n); 45 | x^.n := n; 46 | n^.v := x; 47 | x := n; 48 | x^.i := z; 49 | UNTIL z = 80; 50 | x^.n := xa; 51 | xa^.v := x; 52 | 53 | z := 1; 54 | new(n); 55 | ya := n; 56 | y := n; 57 | y^.i := z; 58 | REPEAT 59 | z := z +1; 60 | new(n); 61 | y^.n := n; 62 | n^.v := y; 63 | y := n; 64 | y^.i := z; 65 | UNTIL z = 24; 66 | y^.n := ya; 67 | ya^.v := y; 68 | END; 69 | 70 | PROCEDURE abbaux(x:zahl); 71 | BEGIN 72 | IF x^.n <> xa THEN abbaux(x^.n); 73 | dispose(x); 74 | END; 75 | 76 | PROCEDURE abbauy(y:zahl); 77 | BEGIN 78 | IF y^.n <> ya THEN abbauy(y^.n); 79 | dispose(y); 80 | END; 81 | 82 | PROCEDURE farbe (z:integer); 83 | BEGIN 84 | CASE z OF 85 | 0:textcolor(0); 86 | 1:textcolor(2); 87 | 10:textcolor(12); 88 | END; 89 | END; 90 | 91 | FUNCTION neu (VAR r:raum; VAR x,y:zahl):s; 92 | VAR z1,z2,z:integer; 93 | BEGIN 94 | z:=( 95 | r(.x^.v^.i,y^.v^.i.)+ 96 | r(.x^.i ,y^.v^.i.)+ 97 | r(.x^.n^.i,y^.v^.i.)+ 98 | r(.x^.v^.i,y^.i .)+ 99 | r(.x^.n^.i,y^.i .)+ 100 | r(.x^.v^.i,y^.n^.i.)+ 101 | r(.x^.i ,y^.n^.i.)+ 102 | r(.x^.n^.i,y^.n^.i.)); 103 | 104 | z2 := z div 10; 105 | z1 := z mod 10; 106 | 107 | IF (r(.x^.i,y^.i.) =0) 108 | THEN 109 | BEGIN 110 | IF z1 > 1 111 | THEN neu:= 1 112 | ELSE neu := 0 113 | END 114 | ELSE 115 | BEGIN 116 | IF (r(.x^.i,y^.i.) =1) 117 | THEN 118 | BEGIN 119 | IF z2 > 1 120 | THEN neu := 10 121 | ELSE 122 | BEGIN 123 | IF z1 in (.2,3.) 124 | THEN neu := 1 125 | ELSE neu := 0 126 | END 127 | END 128 | ELSE 129 | IF z1 <1 130 | THEN 131 | neu := 0 132 | ELSE 133 | BEGIN 134 | IF z2 in (.2,3.) 135 | THEN neu := 10 136 | ELSE neu := 0 137 | END 138 | END 139 | END; 140 | 141 | PROCEDURE text_anfang; 142 | BEGIN 143 | window(1,25,80,25); 144 | textbackground(red); 145 | textcolor(white); 146 | clrscr; 147 | write('Koop Editor Zufall Cursor Tier Tier Start'); 148 | gotoxy(1,1); 149 | textcolor(2); 150 | textbackground(black); 151 | window(1,1,80,24);clrscr;window(1,1,80,25); 152 | END; 153 | 154 | PROCEDURE text_ende; 155 | BEGIN 156 | gotoxy(1,25); 157 | textbackground(red); 158 | textcolor(white); 159 | write('Koop Status neu Editieren Ende'); 160 | gotoxy(1,1); 161 | textcolor(2); 162 | textbackground(black); 163 | END; 164 | 165 | PROCEDURE zufall(VAR von:raum); 166 | VAR x,y,z:integer; 167 | BEGIN 168 | randomize;gotoxy(1,1); 169 | FOR y := 1 TO 24 170 | DO 171 | FOR x := 1 TO 80 172 | DO 173 | BEGIN 174 | z := random(3); 175 | IF z = 2 THEN 176 | z := 10; 177 | von(.x,y.):=z; 178 | farbe(von(.x,y.)); 179 | write(l) 180 | END; 181 | END; 182 | 183 | PROCEDURE editor (VAR von:raum); 184 | var 185 | ch1,ch2 : char; 186 | xz,yz,z:integer; 187 | begin 188 | z :=0; 189 | x := xa; 190 | y:=ya; 191 | randomize; 192 | text_anfang; 193 | gotoxy(1,1); 194 | textcolor(0); 195 | FOR yz := 1 TO 24 196 | DO 197 | FOR xz := 1 TO 80 198 | DO 199 | BEGIN 200 | von(.xz,yz.) := 0; 201 | write(l); 202 | END; 203 | gotoxy(1,1); 204 | repeat 205 | ch1 := readkey; 206 | IF ch1 =#0 207 | THEN 208 | BEGIN 209 | ch2 := readkey; 210 | CASE ch2 OF 211 | #68 : BEGIN 212 | zufall(von); 213 | END; 214 | #72 : y :=y^.v; 215 | #80 : y :=y^.n; 216 | #75 : x :=x^.v; 217 | #77 : x :=x^.n; 218 | #71 : BEGIN 219 | y := y^.v; 220 | x := x^.v; 221 | END; 222 | #73 : BEGIN 223 | y := y^.v; 224 | x := x^.n; 225 | END; 226 | #81 : BEGIN 227 | y := y^.n; 228 | x := x^.n; 229 | END; 230 | #79 : BEGIN 231 | y := y^.n; 232 | x := x^.v; 233 | END; 234 | 235 | #82 : IF z = 0 THEN z := 1 ELSE 236 | IF z = 1 THEN z := 10 ELSE write(char(7)); 237 | #83 : IF z = 10 THEN z := 1 ELSE 238 | IF z = 1 Then z := 0 ELSE write(char(7)); 239 | ELSE 240 | write(char(7)) 241 | END; 242 | gotoxy(x^.i,y^.i); 243 | von(.x^.i,y^.i.) := z; 244 | farbe(z); 245 | write(l); 246 | gotoxy(x^.i,y^.i); 247 | END 248 | ELSE write(char(7)); 249 | until ch1 = #13; 250 | text_ende; 251 | END; 252 | 253 | 254 | PROCEDURE korrektor (VAR von:raum); 255 | var 256 | ch1,ch2 : char; 257 | xz,yz,z:integer; 258 | begin; 259 | randomize; 260 | x:=xa;y:=ya; 261 | text_anfang; 262 | gotoxy(1,1); 263 | z := 0; 264 | FOR yz := 1 TO 24 265 | DO 266 | FOR xz := 1 TO 80 267 | DO 268 | BEGIN 269 | farbe(von(.xz,yz.)); 270 | write(l); 271 | END; 272 | gotoxy(1,1); 273 | repeat 274 | ch1 := readkey; 275 | IF ch1 =#0 276 | THEN 277 | BEGIN 278 | ch2 := readkey; 279 | CASE ch2 OF 280 | #68 : BEGIN 281 | zufall(von); 282 | END; 283 | #72 : y :=y^.v; 284 | #80 : y :=y^.n; 285 | #75 : x :=x^.v; 286 | #77 : x :=x^.n; 287 | #71 : BEGIN 288 | y := y^.v; 289 | x := x^.v; 290 | END; 291 | #73 : BEGIN 292 | y := y^.v; 293 | x := x^.n; 294 | END; 295 | #81 : BEGIN 296 | y := y^.n; 297 | x := x^.n; 298 | END; 299 | #79 : BEGIN 300 | y := y^.n; 301 | x := x^.v; 302 | END; 303 | 304 | #82 : IF z = 0 THEN z := 1 ELSE 305 | IF z = 1 THEN z := 10 ELSE write(char(7)); 306 | #83 : IF z = 10 THEN z := 1 ELSE 307 | IF z = 1 Then z := 0 ELSE write(char(7)); 308 | 309 | ELSE 310 | write(char(7)) 311 | END; 312 | gotoxy(x^.i,y^.i); 313 | von(.x^.i,y^.i.) := z; 314 | farbe(z); 315 | write(l); 316 | gotoxy(x^.i,y^.i); 317 | 318 | END 319 | ELSE write(char(7)); 320 | until ch1 = #13; 321 | text_ende; 322 | END; 323 | 324 | 325 | 326 | PROCEDURE spiel(VAR von,nach :raum); 327 | BEGIN 328 | y :=ya; 329 | x :=xa; 330 | REPEAT 331 | REPEAT 332 | nach(.x^.i,y^.i.) :=neu(von,x,y); 333 | farbe(nach(.x^.i,y^.i.)); 334 | write(l); 335 | x := x^.n 336 | UNTIL x =xa; 337 | y := y^.n 338 | UNTIL y =ya; 339 | END; 340 | 341 | PROCEDURE hauptprogramm; 342 | var 343 | ch1,ch2 : char; 344 | xz,yz:integer; 345 | begin 346 | IF keypressed THEN REPEAT ch1 := readkey UNTIL not(keypressed); 347 | repeat 348 | IF keypressed 349 | THEN 350 | BEGIN 351 | ch1 := readkey; 352 | IF ch1 =#0 353 | THEN 354 | BEGIN 355 | ch2 := readkey; 356 | CASE ch2 OF 357 | #59: BEGIN 358 | x := xa; 359 | abbaux(x); 360 | y := ya; 361 | abbauy(y); 362 | aufbau; 363 | editor(a); 364 | END; 365 | #60: korrektor(a); 366 | ELSE 367 | END; 368 | END 369 | ELSE; 370 | END 371 | ELSE 372 | BEGIN 373 | gotoxy(1,1); 374 | spiel(a,b); 375 | gotoxy(1,1); 376 | spiel(b,a); 377 | END 378 | until ch1 = #13; 379 | END; 380 | 381 | (*------------------------------ Hauptprogramm -----------------*) 382 | BEGIN 383 | checkbreak := false; 384 | aufbau; 385 | editor(a); 386 | hauptprogramm; 387 | x := xa; 388 | abbaux(x); 389 | y := ya; 390 | abbauy(y); 391 | textbackground(black); 392 | textcolor(white); 393 | clrscr; 394 | checkbreak := true; 395 | END. 396 | (************************************** ENDE ************) 397 | 398 | -------------------------------------------------------------------------------- /PARSER.PAS: -------------------------------------------------------------------------------- 1 | PROGRAM parser (INPUT,OUTPUT); 2 | USES CRT; 3 | (***************************************************************************) 4 | (* Paul Koop Chart Parser VKG *) 5 | (* *) 6 | (***************************************************************************) 7 | 8 | (*-----------------------------------------------------------------------*) 9 | (* Vereinbarungsteil *) 10 | (*-----------------------------------------------------------------------*) 11 | 12 | CONST 13 | c0 = 0; 14 | c1 = 1; 15 | c2 = 2; 16 | c3 = 3; 17 | c4 = 4; 18 | c5 = 5; 19 | c11 = 11; 20 | cmax = 80; 21 | cwort = 20; 22 | CText : STRING(.cmax.) = ''; 23 | datei = 'LexikonVKG.asc'; 24 | blank = ' '; 25 | 26 | CopyRight 27 | = 'Demo-Parser Chart-Parser Version 1.0(c)1992 by Paul Koop'; 28 | 29 | TYPE 30 | TKategorien = ( VKG, BG, VT, AV, B, A, BBD, BA, AE, AA, 31 | KBG, VBG, KBBD, VBBD, KBA, VBA, KAE, VAE, 32 | KAA, VAA, KAV, VAV); 33 | 34 | 35 | PTKategorienListe = ^TKategorienListe; 36 | TKategorienListe = RECORD 37 | Kategorie :TKategorien; 38 | weiter :PTKategorienListe; 39 | END; 40 | 41 | PTKante = ^TKante; 42 | PTKantenListe = ^TKantenListe; 43 | 44 | TKantenListe = RECORD 45 | kante:PTKante; 46 | next :PTKantenListe; 47 | END; 48 | 49 | TKante = RECORD 50 | Kategorie :TKategorien; 51 | vor, 52 | nach, 53 | zeigt :PTKante; 54 | gefunden :PTKantenListe; 55 | aktiv :BOOLEAN; 56 | nummer :INTEGER; 57 | nachkomme :BOOLEAN; 58 | CASE Wort:BOOLEAN OF 59 | TRUE : 60 | (inhalt:STRING(.cwort.);); 61 | FALSE: 62 | (gesucht :PTKategorienListe;); 63 | END; 64 | 65 | 66 | TWurzel = RECORD 67 | spalte, 68 | zeigt :PTKante; 69 | END; 70 | 71 | TEintrag = RECORD 72 | A,I :PTKante; 73 | END; 74 | 75 | PTAgenda = ^TAgenda; 76 | TAgenda = RECORD 77 | A,I :PTKante; 78 | next, 79 | back : PTAgenda; 80 | END; 81 | 82 | PTLexElem = ^TLexElem; 83 | TLexElem = RECORD 84 | Kategorie: TKategorien; 85 | Terminal : STRING(.cwort.); 86 | naechstes: PTLexElem; 87 | END; 88 | 89 | TGrammatik = ARRAY (.c1..c11.) 90 | OF 91 | ARRAY (.c1..c4.) 92 | OF TKategorien; 93 | CONST 94 | Grammatik : TGrammatik = 95 | ( 96 | (VKG, BG, VT, AV), 97 | (BG, KBG, VBG, Leer), 98 | (VT, B, A, Leer), 99 | (AV, KAV, VAV, Leer), 100 | (B, BBd, BA, Leer), 101 | (A, AE, AA, Leer), 102 | (BBd, KBBd, VBBd, Leer), 103 | (BA, KBA, VBA, Leer), 104 | (AE, KAE, VAE, Leer), 105 | (AA, KAA, VAA, Leer) 106 | ); 107 | 108 | nummer :INTEGER = c0; 109 | 110 | (*-----------------------------------------------------------------------*) 111 | (* Variablen *) 112 | (*-----------------------------------------------------------------------*) 113 | 114 | 115 | VAR 116 | Wurzel, 117 | Pziel : TWurzel; 118 | Pneu : PTKante; 119 | 120 | Agenda, 121 | PAgenda, 122 | Paar : PTAgenda; 123 | 124 | LexWurzel, 125 | LexAktuell, 126 | LexEintrag : PTLexElem; 127 | Lexikon : Text; 128 | 129 | 130 | (***************************************************************************) 131 | (* FUNKTIONEN *) 132 | (***************************************************************************) 133 | 134 | 135 | (*-----------------------------------------------------------------------*) 136 | (* KantenZaehler *) 137 | (*-----------------------------------------------------------------------*) 138 | 139 | FUNCTION NimmNummer:INTEGER; 140 | BEGIN 141 | Nummer := Nummer + c1; 142 | NimmNummer := Nummer 143 | END; 144 | 145 | 146 | 147 | (***************************************************************************) 148 | (* PROZEDUREN *) 149 | (***************************************************************************) 150 | 151 | 152 | 153 | 154 | (*-----------------------------------------------------------------------*) 155 | (* LexikonLesen *) 156 | (*-----------------------------------------------------------------------*) 157 | 158 | PROCEDURE LiesDasLexikon (VAR f:Text; 159 | G:TGrammatik; 160 | l:PTLexElem); 161 | VAR 162 | zaehler :INTEGER; 163 | z11 : 1..c11; 164 | z4 : 1.. c4; 165 | ch : CHAR; 166 | st5 : STRING(.c5.); 167 | 168 | BEGIN 169 | ASSIGN(f,datei); 170 | LexWurzel := NIL; 171 | RESET(f); 172 | WHILE NOT EOF(f) 173 | DO 174 | BEGIN 175 | NEW(LexEintrag); 176 | IF LexWurzel = NIL 177 | THEN 178 | BEGIN 179 | LexWurzel := LexEintrag; 180 | LexAktuell:= LexWurzel; 181 | LexEintrag^.naechstes := NIL; 182 | END 183 | ELSE 184 | BEGIN 185 | LexAktuell^.naechstes := LexEintrag; 186 | LexEIntrag^.naechstes := NIL; 187 | LexAktuell := LexAktuell^.naechstes; 188 | END; 189 | LexEintrag^.Terminal := ''; 190 | st5 := ''; 191 | FOR Zaehler := c1 to c5 192 | DO 193 | BEGIN 194 | READ(f,ch); 195 | st5 := st5 + UPCASE(ch) 196 | END; 197 | REPEAT 198 | READ(f,ch); 199 | LexEintrag^.terminal := LexEintrag^.Terminal + UPCASE(ch); 200 | UNTIL EOLN(f); 201 | READLN(f); 202 | IF st5 = 'ART**' THEN LexEintrag^.Kategorie := Art ELSE 203 | IF st5 = 'N****' THEN LexEintrag^.Kategorie := N ELSE 204 | IF st5 = 'PN***' THEN LexEintrag^.Kategorie := PN ELSE 205 | IF st5 = 'ADJ**' THEN LexEintrag^.Kategorie := Adj ELSE 206 | IF st5 = 'V****' THEN LexEintrag^.Kategorie := V ELSE 207 | IF st5 = 'PRAEP' THEN LexEintrag^.Kategorie := Praep 208 | END; 209 | END; 210 | 211 | 212 | (*-----------------------------------------------------------------------*) 213 | (* SatzLesen *) 214 | (*-----------------------------------------------------------------------*) 215 | 216 | PROCEDURE LiesDenSatz; 217 | VAR 218 | satz: STRING(.cmax.); 219 | zaehler: INTEGER; 220 | BEGIN 221 | CLRSCR; 222 | WRITELN(CopyRight); 223 | WRITE('-----> '); 224 | Wurzel.spalte := NIL; 225 | Wurzel.zeigt := NIL; 226 | READLN(satz); 227 | FOR zaehler := c1 to LENGTH(satz) 228 | DO satz(.zaehler.) := UPCASE(satz(.zaehler.)); 229 | Satz := Satz + blank; 230 | Writeln('-----> ',satz); 231 | WHILE satz <> '' 232 | DO 233 | BEGIN 234 | NEW(Pneu); 235 | Pneu^.nummer :=NimmNummer; 236 | Pneu^.wort := TRUE; 237 | NEW(Pneu^.gefunden); 238 | Pneu^.gefunden^.kante := Pneu; 239 | pneu^.gefunden^.next := NIL; 240 | Pneu^.gesucht := NIL; 241 | Pneu^.nachkomme :=FALSE; 242 | IF Wurzel.zeigt = NIL 243 | THEN 244 | BEGIN 245 | Wurzel.zeigt := pneu; 246 | Wurzel.spalte:= pneu; 247 | PZiel.spalte := pneu; 248 | PZiel.zeigt := Pneu; 249 | pneu^.vor := NIL; 250 | Pneu^.zeigt := NIL; 251 | Pneu^.nach := NIL; 252 | END 253 | ELSE 254 | BEGIN 255 | Wurzel.zeigt^.zeigt := Pneu; 256 | Pneu^.vor := Wurzel.zeigt; 257 | Pneu^.nach := NIL; 258 | Pneu^.zeigt := NIL; 259 | Wurzel.zeigt := Wurzel.zeigt^.zeigt; 260 | END; 261 | pneu^.aktiv := false; 262 | pneu^.inhalt := COPY(satz,c1,POS(blank,satz)-c1); 263 | LexAktuell := LexWurzel; 264 | WHILE LexAktuell <> NIL 265 | DO 266 | BEGIN 267 | IF LexAktuell^.Terminal = pneu^.inhalt 268 | Then 269 | BEGIN 270 | pneu^.Kategorie := LexAktuell^.Kategorie; 271 | END; 272 | LexAktuell := LexAktuell^.naechstes; 273 | END; 274 | DELETE(satz,c1,POS(blank,satz)); 275 | END; 276 | END; 277 | 278 | 279 | 280 | 281 | (*-----------------------------------------------------------------------*) 282 | (* Regel3KanteInAgendaEintragen *) 283 | (*-----------------------------------------------------------------------*) 284 | 285 | PROCEDURE Regel3KanteInAgendaEintragen (Kante:PTKante); 286 | VAR 287 | Wurzel, 288 | PZiel :TWurzel; 289 | PROCEDURE NeuesAgendaPaarAnlegen; 290 | BEGIN 291 | NEW(paar); 292 | IF Agenda = NIL 293 | THEN 294 | BEGIN 295 | Agenda := Paar; 296 | Pagenda:= Paar; 297 | Paar^.next := NIL; 298 | Paar^.back := NIL; 299 | END 300 | ELSE 301 | BEGIN 302 | PAgenda^.next := Paar; 303 | Paar^.next := NIL; 304 | Paar^.back := Pagenda; 305 | Pagenda := Pagenda^.next; 306 | END; 307 | END; 308 | 309 | BEGIN 310 | IF Kante^.aktiv 311 | THEN 312 | BEGIN 313 | Wurzel.zeigt := Kante^.zeigt; 314 | WHILE wurzel.zeigt <> NIL 315 | DO 316 | BEGIN 317 | IF NOT(wurzel.zeigt^.aktiv) 318 | THEN 319 | BEGIN 320 | NeuesAgendaPaarAnlegen; 321 | paar^.A := kante; 322 | paar^.I := wurzel.zeigt; 323 | END; 324 | Wurzel.zeigt := Wurzel.zeigt^.nach 325 | END 326 | END 327 | ELSE 328 | BEGIN 329 | PZiel.zeigt := Kante; 330 | WHILE NOT(PZiel.zeigt^.Wort) 331 | DO PZiel.Zeigt := PZiel.Zeigt^.Vor; 332 | Wurzel.Zeigt := PZiel.Zeigt; 333 | Wurzel.Spalte := PZiel.Zeigt; 334 | PZiel.Spalte := Pziel.zeigt; 335 | WHILE wurzel.spalte <> NIL 336 | DO 337 | BEGIN 338 | WHILE wurzel.zeigt <> NIL 339 | DO 340 | BEGIN 341 | IF wurzel.zeigt^.aktiv 342 | AND (Wurzel.zeigt^.zeigt = PZiel.spalte) 343 | THEN 344 | BEGIN 345 | NeuesAGendaPaarAnlegen; 346 | paar^.I := kante; 347 | paar^.A := wurzel.zeigt; 348 | END; 349 | Wurzel.zeigt := Wurzel.zeigt^.nach 350 | END; 351 | wurzel.spalte := wurzel.spalte^.vor; 352 | wurzel.zeigt := wurzel.spalte; 353 | END 354 | END 355 | END; 356 | 357 | (*-----------------------------------------------------------------------*) 358 | (* AgendaAusgabe *) 359 | (*-----------------------------------------------------------------------*) 360 | 361 | PROCEDURE NimmAgendaEintrag(VAR PEintrag:PTAgenda); 362 | BEGIN 363 | IF PAgenda = Agenda 364 | THEN 365 | BEGIN 366 | PEintrag := Agenda; 367 | PAgenda := NIL; 368 | Agenda := NIL; 369 | END 370 | ELSE 371 | BEGIN 372 | PAGENDA := PAGENDA^.back; 373 | PEintrag := PAgenda^.next; 374 | PAGENDA^.next := NIL; 375 | END; 376 | END; 377 | 378 | 379 | 380 | 381 | (*-----------------------------------------------------------------------*) 382 | (* Regel2EineNeueKanteAnlegen *) 383 | (*-----------------------------------------------------------------------*) 384 | 385 | PROCEDURE Regel2EineNeueKanteAnlegen( Kante :PTKante; 386 | Kategorie :TKategorien; 387 | Gram :TGrammatik ); 388 | VAR 389 | Wurzel :TWurzel; 390 | PHilfe, 391 | PGesuchteKategorie :PTKategorienListe; 392 | zaehler, 393 | zaehler2 :INTEGER; 394 | 395 | BEGIN 396 | Wurzel.zeigt := Kante; 397 | Wurzel.spalte:= Kante; 398 | WHILE Wurzel.zeigt^.nach <> NIL 399 | DO Wurzel.zeigt := Wurzel.zeigt^.nach; 400 | FOR zaehler := c1 To c11 401 | DO 402 | IF (kategorie = Gram(.zaehler,c1.)) 403 | AND (kategorie <> Leer) 404 | THEN 405 | BEGIN 406 | Gram(.zaehler,c1.) := Leer; 407 | NEW(pneu); 408 | Wurzel.zeigt^.nach := pneu; 409 | pneu^.nummer := NimmNummer; 410 | pneu^.vor := Wurzel.zeigt; 411 | Pneu^.nach := NIL; 412 | Pneu^.zeigt := wurzel.spalte; 413 | Wurzel.zeigt := Wurzel.zeigt^.nach; 414 | pneu^.aktiv := true; 415 | pneu^.kategorie := kategorie; 416 | Pneu^.Wort := false; 417 | Pneu^.gesucht := NIL; 418 | Pneu^.gefunden := NIL; 419 | Pneu^.nachkomme := FALSE; 420 | FOR zaehler2 := c2 TO c4 421 | DO 422 | BEGIN 423 | IF Gram(.zaehler,zaehler2.) <> Leer 424 | THEN 425 | BEGIN 426 | NEW(PGesuchteKategorie); 427 | PGesuchteKategorie^.weiter:= NIL; 428 | PGesuchteKategorie^.Kategorie := Gram(.zaehler,zaehler2.); 429 | IF Pneu^.gesucht = NIL 430 | THEN 431 | BEGIN 432 | PHilfe := PGesuchteKategorie; 433 | Pneu^.gesucht := PHilfe; 434 | END 435 | ELSE 436 | BEGIN 437 | PHilfe^.weiter := PGesuchteKategorie; 438 | PHilfe := PHilfe^.weiter; 439 | END 440 | END 441 | END; 442 | Regel3KanteInAgendaEintragen (pneu); 443 | Regel2EineNeueKanteAnlegen(Wurzel.spalte, 444 | pneu^.gesucht^.kategorie,gram); 445 | END; 446 | END; 447 | 448 | 449 | 450 | (*-----------------------------------------------------------------------*) 451 | (* Regel1EineKanteErweiternen *) 452 | (*-----------------------------------------------------------------------*) 453 | 454 | PROCEDURE Regel1EineKanteErweitern(paar:PTAgenda); 455 | VAR 456 | PneuHilf,Pneugefneu,AHilf :PTKantenListe; 457 | BEGIN 458 | 459 | IF paar^.I^.kategorie = paar^.A^.gesucht^.kategorie 460 | THEN 461 | BEGIN 462 | NEW(pneu); 463 | pneu^.nummer := NimmNummer; 464 | pneu^.kategorie := Paar^.A^.kategorie; 465 | (*---------------------------------------------------*) 466 | Pneu^.gefunden := NIL; 467 | AHilf := Paar^.A^.gefunden; 468 | 469 | WHILE AHilf <> NIL 470 | DO 471 | BEGIN 472 | NEW(Pneugefneu); 473 | IF Pneu^.gefunden = NIL 474 | THEN 475 | BEGIN 476 | Pneu^.gefunden := Pneugefneu; 477 | PneuHilf := Pneu^.gefunden; 478 | PneuHilf^.next := NIL; 479 | END 480 | ELSE 481 | BEGIN 482 | PneuHilf^.next := Pneugefneu; 483 | PneuHilf := PneuHilf^.next; 484 | PneuHilf^.next := NIL; 485 | END; 486 | 487 | Pneugefneu^.kante := AHilf^.kante; 488 | AHilf := AHilf^.next; 489 | END; 490 | 491 | NEW(Pneugefneu); 492 | IF Pneu^.gefunden = NIL 493 | THEN 494 | BEGIN 495 | Pneu^.gefunden := Pneugefneu; 496 | Pneugefneu^.next := NIL; 497 | END 498 | ELSE 499 | BEGIN 500 | PneuHilf^.next := Pneugefneu; 501 | PneuHilf := PneuHilf^.next; 502 | PneuHilf^.next := NIL; 503 | END; 504 | Pneugefneu^.kante := Paar^.I; 505 | (*--------------------------------------------*) 506 | Pneu^.wort := FALSE; 507 | IF Paar^.A^.gesucht^.weiter = NIL 508 | THEN Pneu^.gesucht := NIL 509 | ELSE Pneu^.gesucht := Paar^.A^.gesucht^.weiter; 510 | Pneu^.nachkomme := TRUE; 511 | 512 | IF pneu^.gesucht = NIL 513 | THEN Pneu^.aktiv := false 514 | ELSE Pneu^.aktiv := true; 515 | 516 | WHILE Paar^.A^.nach <> NIL 517 | DO Paar^.A := Paar^.A^.nach; 518 | 519 | Paar^.A^.nach := pneu; 520 | pneu^.vor := Paar^.A; 521 | pneu^.zeigt := Paar^.I^.zeigt; 522 | pneu^.nach := NIL; 523 | 524 | Regel3KanteInAgendaEintragen (pneu); 525 | IF Pneu^.aktiv 526 | THEN Regel2EineNeueKanteAnlegen(Pneu^.zeigt, 527 | pneu^.gesucht^.kategorie,Grammatik); 528 | END; 529 | 530 | 531 | END; 532 | (*-----------------------------------------------------------------------*) 533 | (* SatzAnalyse *) 534 | (*-----------------------------------------------------------------------*) 535 | 536 | PROCEDURE SatzAnalyse; 537 | BEGIN 538 | WHILE Agenda <> NIL 539 | DO 540 | BEGIN 541 | NimmAgendaEintrag(Paar); 542 | Regel1EineKanteErweitern(Paar); 543 | END; 544 | 545 | END; 546 | (*-----------------------------------------------------------------------*) 547 | (* SatzAusgabe *) 548 | (*-----------------------------------------------------------------------*) 549 | 550 | PROCEDURE GibAlleSatzalternativenAus; 551 | CONST 552 | BlankAnz:INTEGER = c2; 553 | VAR 554 | PHilf :PTkantenListe; 555 | 556 | PROCEDURE SatzAusgabe(Kante:PTKante;BlankAnz:INTEGER); 557 | VAR 558 | 559 | Zaehler:INTEGER; 560 | PHilf :PTKantenListe; 561 | BEGIN 562 | FOR Zaehler := c1 TO BlankAnz DO WRITE(blank); 563 | 564 | IF Kante^.kategorie = S THEN WRITELN ('S ') ELSE 565 | IF Kante^.kategorie = NP THEN WRITELN ('NP ') ELSE 566 | IF Kante^.kategorie = VP THEN WRITELN ('VP ') ELSE 567 | IF Kante^.kategorie = Art THEN WRITE ('Art ') ELSE 568 | IF Kante^.kategorie = ATR THEN WRITELN ('ATR ') ELSE 569 | IF Kante^.kategorie = N THEN WRITE ('N ') ELSE 570 | IF Kante^.kategorie = PN THEN WRITE ('PN ') ELSE 571 | IF Kante^.kategorie = PP THEN WRITELN ('PP ') ELSE 572 | IF Kante^.kategorie = Adj THEN WRITE ('Adj ') ELSE 573 | IF Kante^.kategorie = V THEN WRITE ('V ') ELSE 574 | IF Kante^.kategorie = Praep THEN WRITE ('Praep'); 575 | 576 | IF Kante^.wort 577 | THEN 578 | WRITELN('----> ',Kante^.inhalt) 579 | ELSE 580 | BEGIN 581 | PHilf := Kante^.gefunden; 582 | WHILE PHilf <> NIL 583 | DO 584 | BEGIN 585 | Satzausgabe(PHilf^.kante,Blankanz+c1); 586 | PHilf := Philf^.next; 587 | END 588 | END 589 | END; 590 | 591 | BEGIN 592 | WHILE Wurzel.zeigt^.vor <> NIL 593 | DO Wurzel.zeigt := Wurzel.zeigt^.vor; 594 | 595 | WHILE Wurzel.zeigt <> NIL 596 | DO 597 | BEGIN 598 | IF (Wurzel.zeigt^.kategorie = S) 599 | AND ((NOT(Wurzel.zeigt^.aktiv)) 600 | AND (wurzel.zeigt^.zeigt = NIL)) 601 | THEN 602 | BEGIN 603 | WRITELN('S'); 604 | PHilf := Wurzel.zeigt^.gefunden; 605 | WHILE PHilf <> NIL 606 | DO 607 | BEGIN 608 | Satzausgabe(PHilf^.kante,Blankanz+c1); 609 | PHilf := Philf^.next; 610 | END 611 | END; 612 | Wurzel.zeigt := Wurzel.zeigt^.nach; 613 | END; 614 | 615 | END; 616 | 617 | (*-----------------------------------------------------------------------*) 618 | (* FreigabeDesBenutztenSpeicherplatzes *) 619 | (*-----------------------------------------------------------------------*) 620 | 621 | PROCEDURE LoescheDieListe; 622 | PROCEDURE LoescheWort(kante :PTKante); 623 | PROCEDURE LoescheSpalte(kante:PTKante); 624 | VAR 625 | Pgefunden :PTKantenListe; 626 | Pgesucht :PTKategorienListe; 627 | PROCEDURE LoescheGesucht(p:PTKategorienListe); 628 | BEGIN 629 | IF p^.weiter <> NIL 630 | THEN LoescheGesucht(p^.weiter); 631 | IF P <> NIL THEN DISPOSE(P); 632 | END; 633 | PROCEDURE LoescheGefunden(Kante:PTKante;p:PTKantenListe); 634 | BEGIN 635 | IF p^.next <> NIL 636 | THEN LoescheGefunden(Kante,p^.next); 637 | DISPOSE(P); 638 | END; 639 | BEGIN(*LoescheSpalte*) 640 | IF Kante^.nach <> NIL 641 | THEN LoescheSpalte(kante^.nach); 642 | IF (NOT Kante^.nachkomme) AND ((Kante^.gesucht <> NIL) 643 | AND (NOT Kante^.wort)) 644 | THEN LoescheGesucht(Kante^.gesucht); 645 | IF Kante^.gefunden <> NIL 646 | THEN LoescheGefunden(Kante,Kante^.gefunden); 647 | DISPOSE(Kante) 648 | END;(*LoescheSpalte*) 649 | BEGIN(*LoescheWort*) 650 | IF Kante^.zeigt <> NIL 651 | THEN LoescheWort(Kante^.zeigt); 652 | LoescheSpalte(Kante); 653 | END;(*LoescheWort*) 654 | BEGIN(*LoescheDieListe*) 655 | WHILE Wurzel.spalte^.vor <> NIL 656 | DO Wurzel.spalte := Wurzel.spalte^.vor; 657 | LoescheWort(Wurzel.spalte); 658 | END;(*LoescheDieListe*) 659 | (***************************************************************************) 660 | (* HAUPTPROGRAMM DES CHART PARSERS *) 661 | (***************************************************************************) 662 | 663 | BEGIN 664 | Agenda := NIL; 665 | PAgenda := Agenda; 666 | LiesDasLexikon(Lexikon,Grammatik,LexWurzel); 667 | LiesDenSatz; 668 | WHILE Wurzel.spalte^.vor <> NIL 669 | DO Wurzel.spalte := Wurzel.spalte^.vor; 670 | Regel2EineNeueKanteAnlegen(Wurzel.spalte,S,Grammatik); 671 | SatzAnalyse; 672 | GibAlleSatzalternativenAus; 673 | LoescheDieListe; 674 | (***************************************************************************) 675 | (* ENDE DES HAUPTPROGRAMMS DES CHART PARSERS *) 676 | (***************************************************************************) 677 | 678 | END. 679 | -------------------------------------------------------------------------------- /genalg.pas: -------------------------------------------------------------------------------- 1 | (*Windows Free Pascal is developed by dr J.Szymanda under the GPL License*) 2 | (*************************************************************************) 3 | PROGRAM genetischer_algorithmus (output); 4 | (******************************************************************) 5 | (* Paul Koop M.A. genetischer Algorithmus *) 6 | (* Der Algorithmus optimiert die weider (froesche) *) 7 | (* Die Simulation wurde ursprunglich entwickelt, *) 8 | (* um die Verwendbarkeit von genetischen Algorithmen *) 9 | (* fuer die Algorithmisch Rekursive Sequanzanalyse *) 10 | (* zu ueberpruefen *) 11 | (* Modellcharakter hat allein der Quelltext. Eine Compilierung *) 12 | (* dient nur als Falsifikationsversuch *) 13 | (******************************************************************) 14 | USES dos,crt; 15 | (*----------------------- Const Definitionen ----------*) 16 | CONST 17 | Fn = 1; (* gen nahrung *) 18 | Fg = 2; (* gen gefahr *) 19 | Rn = 3; (* gen fressen *) 20 | Rg = 4; (* gen verteidigung *) 21 | 22 | maxfit = 80; 23 | stoffwechsel = -1; 24 | (*----------------------- Type-Definitionen------------*) 25 | 26 | TYPE 27 | Tzahl = ^inhalt; 28 | inhalt = RECORD 29 | i:integer; 30 | v, 31 | n:Tzahl; 32 | END; 33 | 34 | Tfeld = array(.1..4.) of CHAR; 35 | 36 | TPgen = ^gen; 37 | 38 | gen = RECORD 39 | vor,nach:TPgen; 40 | g:Tfeld; 41 | END; 42 | 43 | TPzelle = ^zelle; 44 | Ttorus = array(.1..80,1..24.) of TPzelle; 45 | zelle = OBJECT 46 | constructor init; 47 | destructor done;virtual; 48 | function nnahrung(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 49 | function nrauber(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 50 | function nweider(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 51 | 52 | END; 53 | 54 | TPweider= ^weider; (* Froesche nur duie Froesche werden optimiert *) 55 | weider = OBJECT(zelle) 56 | vor,nach :TPweider; 57 | gen :TPgen; 58 | fit :integer; 59 | Fg, 60 | Fn, 61 | Rg, 62 | Rn, 63 | verteidigen, 64 | gefahr, 65 | futter :boolean; 66 | constructor init; 67 | destructor done; virtual; 68 | Procedure leer; virtual; 69 | procedure Bgefahr 70 | (VAR x,y:Tzahl;VAR t:Ttorus); 71 | virtual; 72 | procedure Bfutter 73 | (VAR x,y:Tzahl;VAR t:Ttorus); 74 | virtual; 75 | procedure Rfressen; virtual; 76 | procedure Rverteidigung; virtual; 77 | procedure Rfit 78 | (zahl:integer); virtual; 79 | function getfit :integer; 80 | virtual; 81 | function getgefahr :boolean; 82 | virtual; 83 | function getverteidigen :boolean; 84 | virtual; 85 | function getfressen :boolean; 86 | virtual; 87 | function nloeschen 88 | (VAR x,y:Tzahl; 89 | VAR t:Ttorus) :boolean; 90 | virtual; 91 | END; 92 | 93 | TPrauber= ^rauber; (* Voegel Feinde der Froesche *) 94 | rauber = OBJECT(zelle) 95 | constructor init; 96 | destructor done;virtual; 97 | function rloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 98 | END; 99 | 100 | TPnahrung=^nahrung;(* INSEKTEN Nahrung der Froesche *) 101 | nahrung = OBJECT(zelle) 102 | constructor init; 103 | destructor done;virtual; 104 | function nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 105 | END; 106 | 107 | 108 | (*----------------------- Var-Definitionen -----------*) 109 | VAR 110 | n,x,y,xa,ya:Tzahl; 111 | Wzelle :TPzelle; 112 | Wweider, 113 | Aweider, 114 | Nweider :TPweider; 115 | Wnahrung :TPnahrung; 116 | Wrauber :TPrauber; 117 | Wgen, 118 | Agen, 119 | Ngen :TPgen; 120 | 121 | bilda, 122 | bildb :Ttorus; 123 | (*----------------------- Methoden -------------------*) 124 | CONSTRUCTOR zelle.init; 125 | BEGIN 126 | END; 127 | 128 | DESTRUCTOR zelle.done; 129 | BEGIN 130 | END; 131 | 132 | FUNCTION zelle.nnahrung(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 133 | VAR z:integer; 134 | BEGIN 135 | Z := 0; 136 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung) 137 | THEN z := z + 1; 138 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(nahrung) 139 | THEN z := z + 1; 140 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung) 141 | THEN z := z + 1; 142 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(nahrung) 143 | THEN z := z + 1; 144 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(nahrung) 145 | THEN z := z + 1; 146 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung) 147 | THEN z := z + 1; 148 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(nahrung) 149 | THEN z := z + 1; 150 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung) 151 | THEN z := z + 1; 152 | 153 | If z > 0 154 | THEN nnahrung:=true ELSE nnahrung:=false; 155 | END; 156 | 157 | FUNCTION zelle.nrauber(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 158 | VAR Z:integer; 159 | BEGIN 160 | z := 0; 161 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber) 162 | THEN z := z + 1; 163 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(rauber) 164 | THEN z := z + 1; 165 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber) 166 | THEN z := z + 1; 167 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(rauber) 168 | THEN z := z + 1; 169 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(rauber) 170 | THEN z := z + 1; 171 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber) 172 | THEN z := z + 1; 173 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(rauber) 174 | THEN z := z + 1; 175 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber) 176 | THEN z := z + 1; 177 | 178 | IF z > 0 179 | THEN nrauber :=true ELSE nrauber :=false; 180 | END; 181 | 182 | FUNCTION zelle.nweider(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 183 | VAR Z:integer; 184 | BEGIN 185 | z := 0; 186 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider) 187 | THEN z := z + 1; 188 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(weider) 189 | THEN z := z + 1; 190 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider) 191 | THEN z := z + 1; 192 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(weider) 193 | THEN z := z + 1; 194 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(weider) 195 | THEN z := z + 1; 196 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider) 197 | THEN z := z + 1; 198 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(weider) 199 | THEN z := z + 1; 200 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider) 201 | THEN z := z + 1; 202 | 203 | IF z > 0 204 | THEN nweider :=true ELSE nweider :=false; 205 | END; 206 | 207 | CONSTRUCTOR weider.init; 208 | BEGIN 209 | END; 210 | PROCEDURE weider.leer; 211 | BEGIN 212 | Fg := false; 213 | Fn := false; 214 | Rg := false; 215 | Rn := false; 216 | verteidigen := false; 217 | gefahr := false; 218 | futter := false; 219 | fit := maxfit; 220 | END; 221 | 222 | DESTRUCTOR weider.done; 223 | BEGIN 224 | END; 225 | 226 | PROCEDURE weider.Bgefahr(VAR x,y:Tzahl;VAR t:Ttorus); 227 | VAR z : integer; 228 | BEGIN 229 | Z := 0; 230 | IF Fg 231 | THEN 232 | BEGIN 233 | IF TypeOF(t(.x^.v^.v^.i,y^.v^.v^.i.)^)=TypeOf(rauber) 234 | THEN z := z + 1; 235 | IF TypeOF(t(.x^.v^.v^.i,y^.v^.i .)^)=TypeOf(rauber) 236 | THEN z := z + 1; 237 | IF TypeOF(t(.x^.v^.v^.i,y^.i .)^)=TypeOf(rauber) 238 | THEN z := z + 1; 239 | IF TypeOF(t(.x^.v^.v^.i,y^.n^.i .)^)=TypeOf(rauber) 240 | THEN z := z + 1; 241 | IF TypeOF(t(.x^.v^.v^.i,y^.n^.n^.i.)^)=TypeOf(rauber) 242 | THEN z := z + 1; 243 | IF TypeOF(t(.x^.v^.i ,y^.v^.v^.i.)^)=TypeOf(rauber) 244 | THEN z := z + 1; 245 | IF TypeOF(t(.x^.v^.i ,y^.n^.n^.i.)^)=TypeOf(rauber) 246 | THEN z := z + 1; 247 | IF TypeOF(t(.x^.i ,y^.v^.v^.i.)^)=TypeOf(rauber) 248 | THEN z := z + 1; 249 | IF TypeOF(t(.x^.i ,y^.n^.n^.i.)^)=TypeOf(rauber) 250 | THEN z := z + 1; 251 | IF TypeOF(t(.x^.n^.i ,y^.v^.v^.i.)^)=TypeOf(rauber) 252 | THEN z := z + 1; 253 | IF TypeOF(t(.x^.n^.i ,y^.n^.n^.i.)^)=TypeOf(rauber) 254 | THEN z := z + 1; 255 | IF TypeOF(t(.x^.n^.n^.i,y^.v^.v^.i.)^)=TypeOf(rauber) 256 | THEN z := z + 1; 257 | IF TypeOF(t(.x^.n^.n^.i,y^.v^.i .)^)=TypeOf(rauber) 258 | THEN z := z + 1; 259 | IF TypeOF(t(.x^.n^.n^.i,y^.i .)^)=TypeOf(rauber) 260 | THEN z := z + 1; 261 | IF TypeOF(t(.x^.n^.n^.i,y^.n^.i .)^)=TypeOf(rauber) 262 | THEN z := z + 1; 263 | IF TypeOF(t(.x^.n^.n^.i,y^.n^.n^.i.)^)=TypeOf(rauber) 264 | THEN z := z + 1; 265 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber) 266 | THEN z := z+1; 267 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(rauber) 268 | THEN z := z+1; 269 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber) 270 | THEN z := z+1; 271 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(rauber) 272 | THEN z := z+1; 273 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(rauber) 274 | THEN z := z+1; 275 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber) 276 | THEN z := z+1; 277 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(rauber) 278 | THEN z := z+1; 279 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber) 280 | THEN z := z+1; 281 | 282 | END; 283 | 284 | IF Z > 0 285 | THEN gefahr := true ELSE gefahr := false; 286 | 287 | END; 288 | 289 | PROCEDURE weider.Bfutter(VAR x,y:Tzahl;VAR t:Ttorus); 290 | VAR z :integer; 291 | BEGIN 292 | 293 | z := 0; 294 | IF Fn 295 | THEN 296 | BEGIN 297 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung) 298 | THEN z := z + 1; 299 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(nahrung) 300 | THEN z := z + 1; 301 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung) 302 | THEN z := z + 1; 303 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(nahrung) 304 | THEN z := z + 1; 305 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(nahrung) 306 | THEN z := z + 1; 307 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung) 308 | THEN z := z + 1; 309 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(nahrung) 310 | THEN z := z + 1; 311 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung) 312 | THEN z := z + 1; 313 | END; 314 | 315 | IF Z > 0 316 | THEN futter := true ELSE futter := false; 317 | 318 | 319 | END; 320 | 321 | function weider.nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 322 | VAR z:integer; 323 | BEGIN 324 | z := 0; 325 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider) 326 | THEN z := z+1; 327 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(weider) 328 | THEN z := z+1; 329 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider) 330 | THEN z := z+1; 331 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(weider) 332 | THEN z := z+1; 333 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(weider) 334 | THEN z := z+1; 335 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider) 336 | THEN z := z+1; 337 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(weider) 338 | THEN z := z+1; 339 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider) 340 | THEN z := z+1; 341 | IF z> 3 THEN nloeschen := true 342 | ELSE nloeschen := false; 343 | 344 | END; 345 | 346 | PROCEDURE weider.Rfressen; 347 | BEGIN 348 | IF(futter and Rn) 349 | THEN fit := fit + 2; 350 | END; 351 | 352 | PROCEDURE weider.Rverteidigung; 353 | BEGIN 354 | IF (gefahr and Rg) 355 | THEN verteidigen := true 356 | ELSE verteidigen := false 357 | END; 358 | 359 | PROCEDURE weider.Rfit (zahl:integer); 360 | BEGIN 361 | fit := fit + zahl; 362 | END; 363 | 364 | FUNCTION weider.getfit:integer; 365 | BEGIN 366 | getfit := fit; 367 | END; 368 | 369 | FUNCTION weider.getgefahr:boolean; 370 | BEGIN 371 | getgefahr := gefahr; 372 | END; 373 | 374 | 375 | FUNCTION weider.getverteidigen:boolean; 376 | BEGIN 377 | getverteidigen := verteidigen; 378 | END; 379 | 380 | FUNCTION weider.getfressen:boolean; 381 | BEGIN 382 | getfressen := Rn; 383 | END; 384 | 385 | CONSTRUCTOR rauber.init; 386 | BEGIN 387 | END; 388 | 389 | DESTRUCTOR rauber.done; 390 | BEGIN 391 | END; 392 | 393 | function rauber.rloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 394 | VAR z:integer; 395 | BEGIN 396 | z := 0; 397 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber) 398 | THEN z := z+1; 399 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(rauber) 400 | THEN z := z+1; 401 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber) 402 | THEN z := z+1; 403 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(rauber) 404 | THEN z := z+1; 405 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(rauber) 406 | THEN z := z+1; 407 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber) 408 | THEN z := z+1; 409 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(rauber) 410 | THEN z := z+1; 411 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber) 412 | THEN z := z+1; 413 | IF z > 3 THEN rloeschen := true 414 | ELSE rloeschen := false; 415 | 416 | END; 417 | CONSTRUCTOR nahrung.init; 418 | BEGIN 419 | END; 420 | 421 | DESTRUCTOR nahrung.done; 422 | BEGIN 423 | END; 424 | 425 | function nahrung.nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 426 | VAR z:integer; 427 | BEGIN 428 | z := 0; 429 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung) 430 | THEN z := z+1; 431 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(nahrung) 432 | THEN z := z+1; 433 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung) 434 | THEN z := z+1; 435 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(nahrung) 436 | THEN z := z+1; 437 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(nahrung) 438 | THEN z := z+1; 439 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung) 440 | THEN z := z+1; 441 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(nahrung) 442 | THEN z := z+1; 443 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung) 444 | THEN z := z+1; 445 | IF z> 3 THEN nloeschen := true 446 | ELSE nloeschen := false; 447 | 448 | END; 449 | 450 | (*----------------------- Prozeduren -----------------*) 451 | FUNCTION test:CHAR; 452 | VAR Z:integer; 453 | BEGIN 454 | z := random(2); 455 | IF z = 0 456 | THEN test := '0' 457 | ELSE test := '1' 458 | END; 459 | PROCEDURE aufbaugene; 460 | VAR z,z1 :integer; 461 | BEGIN 462 | NEW(Wgen); 463 | NEW(Agen); 464 | Wgen := Agen; 465 | FOR z1 := 1 TO 4 DO Agen^.g(.z1.) := test; 466 | NEW(Ngen); 467 | Ngen^.vor := Agen; 468 | Agen^.nach := Ngen; 469 | Agen := Ngen; 470 | FOR z := 1 TO 15 471 | DO 472 | BEGIN 473 | FOR z1 := 1 TO 4 DO Agen^.g(.z1.) := test; 474 | NEW(Ngen); 475 | Ngen^.vor := Agen; 476 | Agen^.nach := Ngen; 477 | Agen := Ngen; 478 | END; 479 | Agen^.nach := Wgen; 480 | Wgen^.vor := Agen; 481 | END; 482 | PROCEDURE abbaugene(z:TPgen); 483 | BEGIN 484 | IF z <> Wgen THEN abbaugene(z^.nach); 485 | dispose(z) 486 | END; 487 | 488 | PROCEDURE crossing_over; 489 | VAR 490 | max1,max2, 491 | fit, 492 | co1,co2 :TPweider; 493 | g1,g2 :TPgen; 494 | ch :CHAR; 495 | z1,z2,z3,z4:Integer; 496 | BEGIN 497 | sound(440);delay(100);nosound; 498 | NEW(max1,init); 499 | NEW(max2,init); 500 | NEW(fit,init); 501 | NEW(co1,init); 502 | NEW(co2,init); 503 | NEW(g1); 504 | NEW(g2); 505 | max1 := Wweider; 506 | max2 := Wweider^.nach; 507 | fit^.fit := 0; 508 | fit^.gen := max1^.gen; 509 | REPEAT 510 | IF fit^.getfit < max1^.getfit 511 | THEN BEGIN 512 | fit^.fit := max1^.getfit; 513 | fit^.gen := max1^.gen; 514 | END; 515 | Max1 := max1^.nach; 516 | UNTIL max1 = Wweider; 517 | Wweider^.gen := fit^.gen; 518 | max1 := Wweider; 519 | fit^.fit := 0; 520 | fit^.gen := max2^.gen; 521 | REPEAT 522 | IF fit^.getfit < max2^.getfit 523 | THEN BEGIN 524 | fit^.fit := max2^.getfit; 525 | fit^.gen := max2^.gen; 526 | END; 527 | max2 := max2^.nach; 528 | UNTIL max2 = Wweider; 529 | Wweider^.nach^.gen := fit^.gen; 530 | max2 := Wweider^.nach; 531 | co1 := max2^.nach; 532 | co2 := co1^.nach; 533 | g1^.g := max1^.gen^.g; 534 | g2^.g := max2^.gen^.g; 535 | max1^.fit := maxfit; 536 | max2^.fit := maxfit; 537 | REPEAT 538 | z1 := random(4)+1; 539 | z2 := random(4)+1; 540 | Co1^.gen^.g := g1^.g; 541 | co1^.fit := maxfit; 542 | Co2^.gen^.g := g2^.g; 543 | co2^.fit := maxfit; 544 | ch:=co1^.gen^.g(.z1.); 545 | co1^.gen^.g(.z1.):=co2^.gen^.g(.z2.); 546 | co2^.gen^.g(.z2.):= ch; 547 | z1 := random(100); 548 | IF z1 = 0 549 | THEN 550 | BEGIN 551 | sound(1000);delay(100);nosound; 552 | z1 := random(4)+1; 553 | z2 := random(4)+1; 554 | z3 :=random(2); 555 | z4 := random(2); 556 | IF z3 = 1 557 | THEN co1^.gen^.g(.z1.):='1' 558 | ELSE co1^.gen^.g(.z1.):='0'; 559 | IF z4 = 1 560 | THEN co2^.gen^.g(.z2.):='1' 561 | ELSE co2^.gen^.g(.z2.):='0'; 562 | END; 563 | co1 := co2^.nach; 564 | co2 := co2^.nach^.nach; 565 | UNTIL co1 = Wweider; 566 | Aweider := Wweider; 567 | REPEAT 568 | IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true 569 | ELSE Aweider^.Fn := false; 570 | IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg := true 571 | ELSE Aweider^.Fg := false; 572 | IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true 573 | ELSE Aweider^.Rn := false; 574 | IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true 575 | ELSE Aweider^.Rg := false; 576 | 577 | Aweider := Aweider^.nach; 578 | UNTIL Aweider = Wweider; 579 | END; 580 | 581 | PROCEDURE aufbauweider; 582 | VAR z :integer; 583 | BEGIN 584 | NEW(Wweider,init); 585 | NEW(Aweider,init); 586 | NEW(Nweider,init); 587 | NWEIDER^.leer; 588 | Nweider := Wweider; 589 | Aweider := Nweider; 590 | Agen := Wgen; 591 | Aweider^.fit := maxfit; 592 | Aweider^.gen := Agen; 593 | IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true 594 | ELSE Aweider^.Fn := false; 595 | IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg := true 596 | ELSE Aweider^.Fg := false; 597 | IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true 598 | ELSE Aweider^.Rn := false; 599 | IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true 600 | ELSE Aweider^.Rg := false; 601 | FOR z := 1 TO 15 602 | DO 603 | BEGIN 604 | NEW(Nweider,init); 605 | Nweider^.leer; 606 | Aweider^.nach := Nweider; 607 | Nweider^.vor := Aweider; 608 | Aweider := Nweider; 609 | Agen := Agen^.nach; 610 | Aweider^.gen := Agen; 611 | IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true 612 | ELSE Aweider^.Fn := false; 613 | IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg := true 614 | ELSE Aweider^.Fg := false; 615 | IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true 616 | ELSE Aweider^.Rn := false; 617 | IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true 618 | ELSE Aweider^.Rg := false; 619 | 620 | END; 621 | Aweider^.nach := Wweider; 622 | Wweider^.vor := Aweider; 623 | END; 624 | PROCEDURE abbauweider(z:TPweider); 625 | BEGIN 626 | IF z <> Wweider THEN abbauweider(z^.nach); 627 | DISPOSE(z,done); 628 | END; 629 | PROCEDURE aufbaurauber; 630 | BEGIN 631 | NEW(Wrauber,init) 632 | END; 633 | PROCEDURE abbaurauber; 634 | BEGIN 635 | DISPOSE(Wrauber,done); 636 | END; 637 | PROCEDURE aufbaunahrung; 638 | BEGIN 639 | new(Wnahrung,init); 640 | END; 641 | PROCEDURE abbaunahrung; 642 | BEGIN 643 | DISPOSE(Wnahrung,done); 644 | END; 645 | PROCEDURE aufbauzelle; 646 | BEGIN 647 | NEW(Wzelle,init) 648 | END; 649 | PROCEDURE abbauzelle; 650 | BEGIN 651 | DISPOSE(Wzelle,done) 652 | END; 653 | PROCEDURE aufbau; 654 | VAR z:integer; 655 | BEGIN 656 | z := 1; 657 | new(n); 658 | xa := n; 659 | x := n; 660 | x^.i := z; 661 | REPEAT 662 | z := z +1; 663 | new(n); 664 | x^.n := n; 665 | n^.v := x; 666 | x := n; 667 | x^.i := z; 668 | UNTIL z = 70; 669 | x^.n := xa; 670 | xa^.v := x; 671 | 672 | z := 1; 673 | new(n); 674 | ya := n; 675 | y := n; 676 | y^.i := z; 677 | REPEAT 678 | z := z +1; 679 | new(n); 680 | y^.n := n; 681 | n^.v := y; 682 | y := n; 683 | y^.i := z; 684 | UNTIL z = 24; 685 | y^.n := ya; 686 | ya^.v := y; 687 | END; 688 | 689 | PROCEDURE abbaux(x:Tzahl); 690 | BEGIN 691 | IF x^.n <> xa THEN abbaux(x^.n); 692 | dispose(x); 693 | END; 694 | 695 | PROCEDURE abbauy(y:Tzahl); 696 | BEGIN 697 | IF y^.n <> ya THEN abbauy(y^.n); 698 | dispose(y); 699 | END; 700 | 701 | FUNCTION neu (VAR r:Ttorus; VAR x,y:Tzahl):TPzelle; 702 | VAR z:TPzelle; 703 | BEGIN 704 | z := r(.x^.i,y^.i.); 705 | IF TypeOF(z^) = TypeOf(rauber) 706 | THEN 707 | BEGIN 708 | IF Wrauber^.rloeschen(x,y,r) THEN neu := Wzelle 709 | ELSE neu := z; 710 | END 711 | ELSE 712 | BEGIN 713 | IF TypeOF(z^) = TypeOf(nahrung) 714 | THEN 715 | BEGIN 716 | IF Wnahrung^.nloeschen(x,y,r) THEN neu := Wzelle 717 | ELSE neu := z; 718 | END 719 | ELSE 720 | BEGIN 721 | IF TypeOF(z^) = TypeOf(weider) 722 | THEN 723 | BEGIN 724 | (*neu := z;*) 725 | Aweider := Wweider; 726 | REPEAT 727 | Aweider := Aweider^.nach 728 | UNTIL @Aweider^ =@z^; 729 | (*Aweider^.init; schon beim Aufbau Konsturktor aufgerufen*) 730 | IF Aweider^.nloeschen(x,y,r) 731 | THEN neu := Wzelle 732 | ELSE 733 | IF Aweider^.getfit = 0 734 | THEN 735 | neu:= Wzelle 736 | ELSE 737 | BEGIN 738 | Aweider^.Rfit(stoffwechsel); 739 | Aweider^.Bgefahr(x,y,r); 740 | Aweider^.Rverteidigung; 741 | IF ((Aweider^.getgefahr)AND NOT(Aweider^.getverteidigen)) 742 | THEN 743 | BEGIN 744 | Aweider^.Rfit(-1*(Aweider^.getfit)); 745 | neu := Wzelle; 746 | END 747 | ELSE 748 | BEGIN 749 | Aweider^.Bfutter(x,y,r); 750 | Aweider^.Rfressen; 751 | neu := @Aweider^; 752 | END 753 | END; 754 | END 755 | ELSE 756 | BEGIN 757 | IF TypeOF(z^) = TypeOf(zelle) 758 | THEN 759 | BEGIN 760 | IF z^.nnahrung(x,y,r) 761 | THEN neu:= Wnahrung 762 | ELSE 763 | BEGIN 764 | IF z^.nrauber(x,y,r) 765 | THEN neu:= Wrauber 766 | ELSE 767 | BEGIN 768 | IF z^.nweider(x,y,r) 769 | THEN neu:= Aweider 770 | ELSE neu := z 771 | END; 772 | END 773 | END 774 | END 775 | END 776 | END 777 | END; 778 | 779 | PROCEDURE status; 780 | BEGIN 781 | textbackground(red); 782 | textcolor(white); 783 | window(1,1,10,24); 784 | CLRSCR;gotoxy(1,1); 785 | WRITELN('ngfv fit'); 786 | Aweider := Wweider; 787 | REPEAT 788 | writeln(Aweider^.gen^.g,' ',Aweider^.fit); 789 | Aweider := Aweider^.nach; 790 | UNTIL Aweider^.nach = Wweider; 791 | END; 792 | 793 | PROCEDURE schreibe (z:TPzelle); 794 | BEGIN 795 | IF TYPEOF(z^) = TypeOf(rauber) 796 | THEN BEGIN textcolor(red); WRITE(char(4)) END 797 | ELSE 798 | BEGIN 799 | IF TypeOf(z^) = TypeOF(weider) 800 | THEN BEGIN textcolor(lightgreen); WRITE(char(2)) END 801 | ELSE 802 | BEGIN 803 | IF TypeOf(z^) = TYPEOF(nahrung) 804 | THEN BEGIN textcolor (yellow );Write(char(26)) END 805 | ELSE BEGIN textcolor(blue);WRITE(' ') END 806 | END; 807 | END 808 | 809 | END; 810 | PROCEDURE spiel(VAR von,nach :Ttorus); 811 | BEGIN 812 | x:=xa; 813 | y:=ya; 814 | textbackground(blue); 815 | window(11,1,80,25); 816 | GOTOxy(1,1); 817 | REPEAT 818 | REPEAT 819 | nach(.x^.i,y^.i.):= (* von(.x^.i,y^.i.) ;*)neu(von,x,y); 820 | schreibe(nach(.x^.i,y^.i.)); 821 | x := x^.n 822 | UNTIL x =xa; 823 | y := y^.n 824 | UNTIL y =ya; 825 | END; 826 | 827 | PROCEDURE zufall(VAR a:Ttorus); 828 | VAR z :integer; 829 | BEGIN 830 | Textbackground(blue); 831 | window(11,1,80,24); 832 | clrscr; 833 | GOTOxy(1,1); 834 | window(11,1,80,25); 835 | Aweider := Wweider; 836 | y :=ya; 837 | x :=xa; 838 | REPEAT 839 | REPEAT 840 | (*Zufallsbelegung*) 841 | z := random(100); 842 | CASE z OF 843 | 0: a(.x^.i,y^.i.) := Wnahrung; 844 | 1: a(.x^.i,y^.i.) := Wrauber; 845 | 2: a(.x^.i,y^.i.) := Wzelle; 846 | 3: BEGIN 847 | a(.x^.i,y^.i.):= Aweider; 848 | Aweider := Aweider^.nach; 849 | END 850 | ELSE a(.x^.i,y^.i.) := Wzelle; 851 | END; 852 | schreibe(a(.x^.i,y^.i.)); 853 | x := x^.n 854 | UNTIL x =xa; 855 | y := y^.n 856 | UNTIL y =ya; 857 | status; 858 | Aweider:= Wweider; 859 | END; 860 | 861 | 862 | PROCEDURE hauptprogramm; 863 | VAR z:integer; 864 | BEGIN 865 | Window(1,25,80,25); 866 | textcolor(white); 867 | textbackground(red); 868 | clrscr; 869 | write('n Nahrung g gefahr f fressen v verteidigen Koop M.A. genetischer Algorithmus'); 870 | randomize; 871 | REPEAT 872 | zufall(bilda); 873 | Z := 0; 874 | REPEAT 875 | spiel(bilda,bildb); 876 | Status; 877 | spiel(bildb,bilda); 878 | Status; 879 | z := z + 1; 880 | Until keypressed or (z = 5); 881 | crossing_over; 882 | UNTIL KEYPRESSED 883 | END; 884 | (*----------------------- Hauptprogramm --------------*) 885 | 886 | BEGIN 887 | checkbreak := false; 888 | clrscr; 889 | aufbau; 890 | aufbaugene; 891 | aufbauweider; 892 | aufbaunahrung; 893 | aufbaurauber; 894 | aufbauzelle; 895 | hauptprogramm; 896 | x := xa; 897 | abbaux(x); 898 | Agen := Wgen; 899 | abbaugene(Agen); 900 | Aweider := Wweider; 901 | abbauweider(Aweider); 902 | abbaunahrung; 903 | abbaurauber; 904 | abbauzelle; 905 | y:=ya; 906 | abbauy(y); 907 | window(1,1,80,25); 908 | textbackground(black); 909 | textcolor(white); 910 | clrscr; 911 | checkbreak := true; 912 | END. -------------------------------------------------------------------------------- /genalgESS.pas: -------------------------------------------------------------------------------- 1 | (*Windows Free Pascal is developed by dr J.Szymanda under the GPL License*) 2 | (*************************************************************************) 3 | PROGRAM genetischer_algorithmus (output); 4 | (******************************************************************) 5 | (* Paul Koop M.A. genetischer Algorithmus *) 6 | (* Der Algorithmus optimiert die weider (froesche) *) 7 | (* Die Simulation wurde ursprunglich entwickelt, *) 8 | (* um die Verwendbarkeit von genetischen Algorithmen *) 9 | (* fuer die Algorithmisch Rekursive Sequanzanalyse *) 10 | (* zu ueberpruefen *) 11 | (* Modellcharakter hat allein der Quelltext. Eine Compilierung *) 12 | (* dient nur als Falsifikationsversuch *) 13 | (******************************************************************) 14 | 15 | USES dos,crt; 16 | (*----------------------- Const Definitionen ----------*) 17 | CONST 18 | Fn = 1; (* gen nahrung *) 19 | Fg = 2; (* gen gefahr *) 20 | Rn = 3; (* gen fressen *) 21 | Rg = 4; (* gen verteidigung *) 22 | 23 | Fk = 5; (* gen andere weider erkennen *) 24 | Rk = 6; (* gen mit anderen weidern kooperieren *) 25 | maxfit = 80; 26 | stoffwechsel = -1; 27 | (*----------------------- Type-Definitionen------------*) 28 | 29 | TYPE 30 | Tzahl = ^inhalt; 31 | inhalt = RECORD 32 | i:integer; 33 | v, 34 | n:Tzahl; 35 | END; 36 | 37 | Tfeld = array(.1..6.) of CHAR; 38 | 39 | TPgen = ^gen; 40 | 41 | gen = RECORD 42 | vor,nach:TPgen; 43 | g:Tfeld; 44 | END; 45 | 46 | TPzelle = ^zelle; 47 | Ttorus = array(.1..80,1..24.) of TPzelle; 48 | zelle = OBJECT 49 | constructor init; 50 | destructor done;virtual; 51 | function nnahrung(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 52 | function nrauber(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 53 | function nweider(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 54 | 55 | END; 56 | 57 | TPweider= ^weider; (* Froesche nur duie Froesche werden optimiert *) 58 | weider = OBJECT(zelle) 59 | vor,nach :TPweider; 60 | gen :TPgen; 61 | fit :integer; 62 | Fg, 63 | Fn, 64 | Rg, 65 | Rn, 66 | Fk, 67 | Rk, 68 | verteidigen, 69 | gefahr, 70 | futter, 71 | weidererkennen, 72 | kooperieren :boolean; 73 | constructor init; 74 | destructor done; virtual; 75 | Procedure leer; virtual; 76 | procedure Bgefahr 77 | (VAR x,y:Tzahl;VAR t:Ttorus); 78 | virtual; 79 | procedure Bfutter 80 | (VAR x,y:Tzahl;VAR t:Ttorus); 81 | virtual; 82 | procedure Rfressen 83 | (VAR x,y:Tzahl;VAR t:Ttorus); 84 | virtual; 85 | procedure Rverteidigung; virtual; 86 | procedure Rkooperieren; virtual; 87 | procedure Rfit 88 | (zahl:integer); virtual; 89 | function getfit :integer; 90 | virtual; 91 | function getgefahr :boolean; 92 | virtual; 93 | function getverteidigen :boolean; 94 | virtual; 95 | function getfressen :boolean; 96 | virtual; 97 | procedure Rweidererkennen 98 | (VAR x,y:Tzahl;VAR t:Ttorus); 99 | virtual; 100 | function getkooperatoren 101 | (VAR x,y:Tzahl; 102 | VAR t:Ttorus) :integer; 103 | virtual; 104 | 105 | function nloeschen 106 | (VAR x,y:Tzahl; 107 | VAR t:Ttorus) :boolean; 108 | virtual; 109 | END; 110 | 111 | TPrauber= ^rauber; (* Voegel Feinde der Froesche *) 112 | rauber = OBJECT(zelle) 113 | constructor init; 114 | destructor done;virtual; 115 | function rloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 116 | END; 117 | 118 | TPnahrung=^nahrung;(* INSEKTEN Nahrung der Froesche *) 119 | nahrung = OBJECT(zelle) 120 | constructor init; 121 | destructor done;virtual; 122 | function nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean;virtual; 123 | END; 124 | 125 | 126 | (*----------------------- Var-Definitionen -----------*) 127 | VAR 128 | n,x,y,xa,ya:Tzahl; 129 | Wzelle :TPzelle; 130 | Wweider, 131 | Aweider, 132 | Nweider :TPweider; 133 | Wnahrung :TPnahrung; 134 | Wrauber :TPrauber; 135 | Wgen, 136 | Agen, 137 | Ngen :TPgen; 138 | 139 | bilda, 140 | bildb :Ttorus; 141 | (*----------------------- Methoden -------------------*) 142 | CONSTRUCTOR zelle.init; 143 | BEGIN 144 | END; 145 | 146 | DESTRUCTOR zelle.done; 147 | BEGIN 148 | END; 149 | 150 | FUNCTION zelle.nnahrung(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 151 | VAR z:integer; 152 | BEGIN 153 | Z := 0; 154 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung) 155 | THEN z := z + 1; 156 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(nahrung) 157 | THEN z := z + 1; 158 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung) 159 | THEN z := z + 1; 160 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(nahrung) 161 | THEN z := z + 1; 162 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(nahrung) 163 | THEN z := z + 1; 164 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung) 165 | THEN z := z + 1; 166 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(nahrung) 167 | THEN z := z + 1; 168 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung) 169 | THEN z := z + 1; 170 | 171 | If z > 0 172 | THEN nnahrung:=true ELSE nnahrung:=false; 173 | END; 174 | 175 | FUNCTION zelle.nrauber(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 176 | VAR Z:integer; 177 | BEGIN 178 | z := 0; 179 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber) 180 | THEN z := z + 1; 181 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(rauber) 182 | THEN z := z + 1; 183 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber) 184 | THEN z := z + 1; 185 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(rauber) 186 | THEN z := z + 1; 187 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(rauber) 188 | THEN z := z + 1; 189 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber) 190 | THEN z := z + 1; 191 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(rauber) 192 | THEN z := z + 1; 193 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber) 194 | THEN z := z + 1; 195 | 196 | IF z > 0 197 | THEN nrauber :=true ELSE nrauber :=false; 198 | END; 199 | 200 | FUNCTION zelle.nweider(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 201 | VAR Z:integer; 202 | BEGIN 203 | z := 0; 204 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider) 205 | THEN z := z + 1; 206 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(weider) 207 | THEN z := z + 1; 208 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider) 209 | THEN z := z + 1; 210 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(weider) 211 | THEN z := z + 1; 212 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(weider) 213 | THEN z := z + 1; 214 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider) 215 | THEN z := z + 1; 216 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(weider) 217 | THEN z := z + 1; 218 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider) 219 | THEN z := z + 1; 220 | 221 | IF z > 0 222 | THEN nweider :=true ELSE nweider :=false; 223 | END; 224 | 225 | CONSTRUCTOR weider.init; 226 | BEGIN 227 | END; 228 | PROCEDURE weider.leer; 229 | BEGIN 230 | Fg := false; 231 | Fn := false; 232 | Rg := false; 233 | Rn := false; 234 | Fk := false; 235 | Rk := false; 236 | verteidigen := false; 237 | gefahr := false; 238 | futter := false; 239 | weidererkennen := false; 240 | kooperieren := false; 241 | fit := maxfit; 242 | END; 243 | 244 | DESTRUCTOR weider.done; 245 | BEGIN 246 | END; 247 | 248 | PROCEDURE weider.Bgefahr(VAR x,y:Tzahl;VAR t:Ttorus); 249 | VAR z : integer; 250 | BEGIN 251 | Z := 0; 252 | IF Fg 253 | THEN 254 | BEGIN 255 | IF TypeOF(t(.x^.v^.v^.i,y^.v^.v^.i.)^)=TypeOf(rauber) 256 | THEN z := z + 1; 257 | IF TypeOF(t(.x^.v^.v^.i,y^.v^.i .)^)=TypeOf(rauber) 258 | THEN z := z + 1; 259 | IF TypeOF(t(.x^.v^.v^.i,y^.i .)^)=TypeOf(rauber) 260 | THEN z := z + 1; 261 | IF TypeOF(t(.x^.v^.v^.i,y^.n^.i .)^)=TypeOf(rauber) 262 | THEN z := z + 1; 263 | IF TypeOF(t(.x^.v^.v^.i,y^.n^.n^.i.)^)=TypeOf(rauber) 264 | THEN z := z + 1; 265 | IF TypeOF(t(.x^.v^.i ,y^.v^.v^.i.)^)=TypeOf(rauber) 266 | THEN z := z + 1; 267 | IF TypeOF(t(.x^.v^.i ,y^.n^.n^.i.)^)=TypeOf(rauber) 268 | THEN z := z + 1; 269 | IF TypeOF(t(.x^.i ,y^.v^.v^.i.)^)=TypeOf(rauber) 270 | THEN z := z + 1; 271 | IF TypeOF(t(.x^.i ,y^.n^.n^.i.)^)=TypeOf(rauber) 272 | THEN z := z + 1; 273 | IF TypeOF(t(.x^.n^.i ,y^.v^.v^.i.)^)=TypeOf(rauber) 274 | THEN z := z + 1; 275 | IF TypeOF(t(.x^.n^.i ,y^.n^.n^.i.)^)=TypeOf(rauber) 276 | THEN z := z + 1; 277 | IF TypeOF(t(.x^.n^.n^.i,y^.v^.v^.i.)^)=TypeOf(rauber) 278 | THEN z := z + 1; 279 | IF TypeOF(t(.x^.n^.n^.i,y^.v^.i .)^)=TypeOf(rauber) 280 | THEN z := z + 1; 281 | IF TypeOF(t(.x^.n^.n^.i,y^.i .)^)=TypeOf(rauber) 282 | THEN z := z + 1; 283 | IF TypeOF(t(.x^.n^.n^.i,y^.n^.i .)^)=TypeOf(rauber) 284 | THEN z := z + 1; 285 | IF TypeOF(t(.x^.n^.n^.i,y^.n^.n^.i.)^)=TypeOf(rauber) 286 | THEN z := z + 1; 287 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber) 288 | THEN z := z+1; 289 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(rauber) 290 | THEN z := z+1; 291 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber) 292 | THEN z := z+1; 293 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(rauber) 294 | THEN z := z+1; 295 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(rauber) 296 | THEN z := z+1; 297 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber) 298 | THEN z := z+1; 299 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(rauber) 300 | THEN z := z+1; 301 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber) 302 | THEN z := z+1; 303 | 304 | END; 305 | 306 | IF Z > 0 307 | THEN gefahr := true ELSE gefahr := false; 308 | 309 | END; 310 | 311 | PROCEDURE weider.Bfutter(VAR x,y:Tzahl;VAR t:Ttorus); 312 | VAR z :integer; 313 | BEGIN 314 | 315 | z := 0; 316 | IF Fn 317 | THEN 318 | BEGIN 319 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung) 320 | THEN z := z + 1; 321 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(nahrung) 322 | THEN z := z + 1; 323 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung) 324 | THEN z := z + 1; 325 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(nahrung) 326 | THEN z := z + 1; 327 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(nahrung) 328 | THEN z := z + 1; 329 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung) 330 | THEN z := z + 1; 331 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(nahrung) 332 | THEN z := z + 1; 333 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung) 334 | THEN z := z + 1; 335 | END; 336 | 337 | IF Z > 0 338 | THEN futter := true ELSE futter := false; 339 | 340 | 341 | END; 342 | 343 | function weider.nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 344 | VAR z:integer; 345 | BEGIN 346 | z := 0; 347 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider) 348 | THEN z := z+1; 349 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(weider) 350 | THEN z := z+1; 351 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider) 352 | THEN z := z+1; 353 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(weider) 354 | THEN z := z+1; 355 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(weider) 356 | THEN z := z+1; 357 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider) 358 | THEN z := z+1; 359 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(weider) 360 | THEN z := z+1; 361 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider) 362 | THEN z := z+1; 363 | IF z> 3 THEN nloeschen := true 364 | ELSE nloeschen := false; 365 | 366 | END; 367 | 368 | procedure weider.Rweidererkennen(VAR x,y:Tzahl;VAR t:Ttorus); 369 | VAR Z:integer; 370 | BEGIN 371 | z := 0; 372 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider) 373 | THEN z := z + 1; 374 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(weider) 375 | THEN z := z + 1; 376 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider) 377 | THEN z := z + 1; 378 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(weider) 379 | THEN z := z + 1; 380 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(weider) 381 | THEN z := z + 1; 382 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider) 383 | THEN z := z + 1; 384 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(weider) 385 | THEN z := z + 1; 386 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider) 387 | THEN z := z + 1; 388 | 389 | IF ((z > 0) AND Fk) 390 | THEN weidererkennen :=true ELSE weidererkennen :=false; 391 | END; 392 | 393 | function weider.getkooperatoren(VAR x,y:Tzahl;VAR t:Ttorus):integer; 394 | VAR z:integer; 395 | BEGIN 396 | z := 0; 397 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(weider) 398 | THEN 399 | BEGIN 400 | Aweider := Wweider; 401 | REPEAT 402 | Aweider := Aweider^.nach 403 | UNTIL @Aweider^ =@t(.x^.v^.i,y^.v^.i.)^; 404 | IF Aweider^.kooperieren THEN z:=z+1; 405 | END; 406 | 407 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(weider) 408 | THEN 409 | BEGIN 410 | Aweider := Wweider; 411 | REPEAT 412 | Aweider := Aweider^.nach 413 | UNTIL @Aweider^ =@t(.x^.v^.i,y^.i .)^; 414 | IF Aweider^.kooperieren THEN z:=z+1; 415 | END; 416 | 417 | 418 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(weider) 419 | THEN 420 | BEGIN 421 | Aweider := Wweider; 422 | REPEAT 423 | Aweider := Aweider^.nach 424 | UNTIL @Aweider^ =@t(.x^.v^.i,y^.n^.i.)^; 425 | IF Aweider^.kooperieren THEN z:=z+1; 426 | END; 427 | 428 | 429 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(weider) 430 | THEN 431 | BEGIN 432 | Aweider := Wweider; 433 | REPEAT 434 | Aweider := Aweider^.nach 435 | UNTIL @Aweider^ =@t(.x^.i ,y^.v^.i.)^; 436 | IF Aweider^.kooperieren THEN z:=z+1; 437 | END; 438 | 439 | 440 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(weider) 441 | THEN 442 | BEGIN 443 | Aweider := Wweider; 444 | REPEAT 445 | Aweider := Aweider^.nach 446 | UNTIL @Aweider^ =@t(.x^.i ,y^.n^.i.)^; 447 | IF Aweider^.kooperieren THEN z:=z+1; 448 | END; 449 | 450 | 451 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(weider) 452 | THEN 453 | BEGIN 454 | Aweider := Wweider; 455 | REPEAT 456 | Aweider := Aweider^.nach 457 | UNTIL @Aweider^ =@t(.x^.n^.i,y^.v^.i.)^; 458 | IF Aweider^.kooperieren THEN z:=z+1; 459 | END; 460 | 461 | 462 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(weider) 463 | THEN 464 | BEGIN 465 | Aweider := Wweider; 466 | REPEAT 467 | Aweider := Aweider^.nach 468 | UNTIL @Aweider^ =@t(.x^.n^.i,y^.i .)^; 469 | IF Aweider^.kooperieren THEN z:=z+1; 470 | END; 471 | 472 | 473 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(weider) 474 | THEN 475 | BEGIN 476 | Aweider := Wweider; 477 | REPEAT 478 | Aweider := Aweider^.nach 479 | UNTIL @Aweider^ =@t(.x^.n^.i,y^.n^.i.)^; 480 | IF Aweider^.kooperieren THEN z:=z+1; 481 | END; 482 | 483 | (*IF Z>0 THEN z:=1 ELSE z:=-1;*) 484 | getkooperatoren :=z; 485 | END; 486 | 487 | procedure weider.Rkooperieren; 488 | BEGIN 489 | IF(weidererkennen and Rk) 490 | THEN kooperieren:=true; 491 | END; 492 | 493 | PROCEDURE weider.Rfressen (VAR x,y:Tzahl;VAR t:Ttorus); 494 | BEGIN 495 | IF(futter and Rn) 496 | THEN 497 | BEGIN 498 | fit := fit + 1+weider.getkooperatoren(x,y,t); 499 | IF NOT(kooperieren) THEN fit := fit + 1; 500 | END; 501 | END; 502 | 503 | PROCEDURE weider.Rverteidigung; 504 | BEGIN 505 | IF (gefahr and Rg) 506 | THEN verteidigen := true 507 | ELSE verteidigen := false 508 | END; 509 | 510 | PROCEDURE weider.Rfit (zahl:integer); 511 | BEGIN 512 | fit := fit + zahl; 513 | END; 514 | 515 | FUNCTION weider.getfit:integer; 516 | BEGIN 517 | getfit := fit; 518 | END; 519 | 520 | FUNCTION weider.getgefahr:boolean; 521 | BEGIN 522 | getgefahr := gefahr; 523 | END; 524 | 525 | 526 | FUNCTION weider.getverteidigen:boolean; 527 | BEGIN 528 | getverteidigen := verteidigen; 529 | END; 530 | 531 | FUNCTION weider.getfressen:boolean; 532 | BEGIN 533 | getfressen := Rn; 534 | END; 535 | 536 | CONSTRUCTOR rauber.init; 537 | BEGIN 538 | END; 539 | 540 | DESTRUCTOR rauber.done; 541 | BEGIN 542 | END; 543 | 544 | function rauber.rloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 545 | VAR z:integer; 546 | BEGIN 547 | z := 0; 548 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(rauber) 549 | THEN z := z+1; 550 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(rauber) 551 | THEN z := z+1; 552 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(rauber) 553 | THEN z := z+1; 554 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(rauber) 555 | THEN z := z+1; 556 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(rauber) 557 | THEN z := z+1; 558 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(rauber) 559 | THEN z := z+1; 560 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(rauber) 561 | THEN z := z+1; 562 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(rauber) 563 | THEN z := z+1; 564 | IF z > 3 THEN rloeschen := true 565 | ELSE rloeschen := false; 566 | 567 | END; 568 | CONSTRUCTOR nahrung.init; 569 | BEGIN 570 | END; 571 | 572 | DESTRUCTOR nahrung.done; 573 | BEGIN 574 | END; 575 | 576 | function nahrung.nloeschen(VAR x,y:Tzahl;VAR t:Ttorus):boolean; 577 | VAR z:integer; 578 | BEGIN 579 | z := 0; 580 | IF TypeOF(t(.x^.v^.i,y^.v^.i.)^)=TypeOF(nahrung) 581 | THEN z := z+1; 582 | IF TypeOF(t(.x^.v^.i,y^.i .)^)=TypeOF(nahrung) 583 | THEN z := z+1; 584 | IF TypeOF(t(.x^.v^.i,y^.n^.i.)^)=TypeOF(nahrung) 585 | THEN z := z+1; 586 | IF TypeOF(t(.x^.i ,y^.v^.i.)^)=TypeOF(nahrung) 587 | THEN z := z+1; 588 | IF TypeOF(t(.x^.i ,y^.n^.i.)^)=TypeOF(nahrung) 589 | THEN z := z+1; 590 | IF TypeOF(t(.x^.n^.i,y^.v^.i.)^)=TypeOF(nahrung) 591 | THEN z := z+1; 592 | IF TypeOF(t(.x^.n^.i,y^.i .)^)=TypeOF(nahrung) 593 | THEN z := z+1; 594 | IF TypeOF(t(.x^.n^.i,y^.n^.i.)^)=TypeOF(nahrung) 595 | THEN z := z+1; 596 | IF z> 3 THEN nloeschen := true 597 | ELSE nloeschen := false; 598 | 599 | END; 600 | 601 | (*----------------------- Prozeduren -----------------*) 602 | FUNCTION test:CHAR; 603 | VAR Z:integer; 604 | BEGIN 605 | z := random(2); 606 | IF z = 0 607 | THEN test := '0' 608 | ELSE test := '1' 609 | END; 610 | PROCEDURE aufbaugene; 611 | VAR z,z1 :integer; 612 | BEGIN 613 | NEW(Wgen); 614 | NEW(Agen); 615 | Wgen := Agen; 616 | FOR z1 := 1 TO 6 DO Agen^.g(.z1.) := test; 617 | NEW(Ngen); 618 | Ngen^.vor := Agen; 619 | Agen^.nach := Ngen; 620 | Agen := Ngen; 621 | FOR z := 1 TO 15 622 | DO 623 | BEGIN 624 | FOR z1 := 1 TO 6 DO Agen^.g(.z1.) := test; 625 | NEW(Ngen); 626 | Ngen^.vor := Agen; 627 | Agen^.nach := Ngen; 628 | Agen := Ngen; 629 | END; 630 | Agen^.nach := Wgen; 631 | Wgen^.vor := Agen; 632 | END; 633 | PROCEDURE abbaugene(z:TPgen); 634 | BEGIN 635 | IF z <> Wgen THEN abbaugene(z^.nach); 636 | dispose(z) 637 | END; 638 | 639 | PROCEDURE crossing_over; 640 | VAR 641 | max1,max2, 642 | fit, 643 | co1,co2 :TPweider; 644 | g1,g2 :TPgen; 645 | ch :CHAR; 646 | z1,z2,z3,z4:Integer; 647 | BEGIN 648 | sound(440);delay(100);nosound; 649 | NEW(max1,init); 650 | NEW(max2,init); 651 | NEW(fit,init); 652 | NEW(co1,init); 653 | NEW(co2,init); 654 | NEW(g1); 655 | NEW(g2); 656 | max1 := Wweider; 657 | max2 := Wweider^.nach; 658 | fit^.fit := 0; 659 | fit^.gen := max1^.gen; 660 | REPEAT 661 | IF fit^.getfit < max1^.getfit 662 | THEN BEGIN 663 | fit^.fit := max1^.getfit; 664 | fit^.gen := max1^.gen; 665 | END; 666 | Max1 := max1^.nach; 667 | UNTIL max1 = Wweider; 668 | Wweider^.gen := fit^.gen; 669 | max1 := Wweider; 670 | fit^.fit := 0; 671 | fit^.gen := max2^.gen; 672 | REPEAT 673 | IF fit^.getfit < max2^.getfit 674 | THEN BEGIN 675 | fit^.fit := max2^.getfit; 676 | fit^.gen := max2^.gen; 677 | END; 678 | max2 := max2^.nach; 679 | UNTIL max2 = Wweider; 680 | Wweider^.nach^.gen := fit^.gen; 681 | max2 := Wweider^.nach; 682 | co1 := max2^.nach; 683 | co2 := co1^.nach; 684 | g1^.g := max1^.gen^.g; 685 | g2^.g := max2^.gen^.g; 686 | max1^.fit := maxfit; 687 | max2^.fit := maxfit; 688 | REPEAT 689 | z1 := random(6)+1; 690 | z2 := random(6)+1; 691 | Co1^.gen^.g := g1^.g; 692 | co1^.fit := maxfit; 693 | Co2^.gen^.g := g2^.g; 694 | co2^.fit := maxfit; 695 | ch:=co1^.gen^.g(.z1.); 696 | co1^.gen^.g(.z1.):=co2^.gen^.g(.z2.); 697 | co2^.gen^.g(.z2.):= ch; 698 | z1 := random(100); 699 | IF z1 = 0 700 | THEN 701 | BEGIN 702 | sound(1000);delay(100);nosound; 703 | z1 := random(6)+1; 704 | z2 := random(6)+1; 705 | z3 :=random(2); 706 | z4 := random(2); 707 | IF z3 = 1 708 | THEN co1^.gen^.g(.z1.):='1' 709 | ELSE co1^.gen^.g(.z1.):='0'; 710 | IF z4 = 1 711 | THEN co2^.gen^.g(.z2.):='1' 712 | ELSE co2^.gen^.g(.z2.):='0'; 713 | END; 714 | co1 := co2^.nach; 715 | co2 := co2^.nach^.nach; 716 | UNTIL co1 = Wweider; 717 | Aweider := Wweider; 718 | REPEAT 719 | IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true 720 | ELSE Aweider^.Fn := false; 721 | IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg := true 722 | ELSE Aweider^.Fg := false; 723 | IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true 724 | ELSE Aweider^.Rn := false; 725 | IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true 726 | ELSE Aweider^.Rg := false; 727 | IF Aweider^.gen^.g(.Fk.) = '1' THEN Aweider^.Fk := true 728 | ELSE Aweider^.Fk := false; 729 | IF Aweider^.gen^.g(.Rk.) = '1' THEN Aweider^.Rk := true 730 | ELSE Aweider^.Rk := false; 731 | Aweider := Aweider^.nach; 732 | UNTIL Aweider = Wweider; 733 | END; 734 | 735 | PROCEDURE aufbauweider; 736 | VAR z :integer; 737 | BEGIN 738 | NEW(Wweider,init); 739 | NEW(Aweider,init); 740 | NEW(Nweider,init); 741 | NWEIDER^.leer; 742 | Nweider := Wweider; 743 | Aweider := Nweider; 744 | Agen := Wgen; 745 | Aweider^.fit := maxfit; 746 | Aweider^.gen := Agen; 747 | IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true 748 | ELSE Aweider^.Fn := false; 749 | IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg := true 750 | ELSE Aweider^.Fg := false; 751 | IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true 752 | ELSE Aweider^.Rn := false; 753 | IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true 754 | ELSE Aweider^.Rg := false; 755 | IF Aweider^.gen^.g(.Fk.) = '1' THEN Aweider^.Fk := true 756 | ELSE Aweider^.Fk := false; 757 | IF Aweider^.gen^.g(.Rk.) = '1' THEN Aweider^.Rk := true 758 | ELSE Aweider^.Rk := false; 759 | FOR z := 1 TO 15 760 | DO 761 | BEGIN 762 | NEW(Nweider,init); 763 | Nweider^.leer; 764 | Aweider^.nach := Nweider; 765 | Nweider^.vor := Aweider; 766 | Aweider := Nweider; 767 | Agen := Agen^.nach; 768 | Aweider^.gen := Agen; 769 | IF Aweider^.gen^.g(.Fn.) = '1' THEN Aweider^.Fn := true 770 | ELSE Aweider^.Fn := false; 771 | IF Aweider^.gen^.g(.Fg.) = '1' THEN Aweider^.Fg := true 772 | ELSE Aweider^.Fg := false; 773 | IF Aweider^.gen^.g(.Rn.) = '1' THEN Aweider^.Rn := true 774 | ELSE Aweider^.Rn := false; 775 | IF Aweider^.gen^.g(.Rg.) = '1' THEN Aweider^.Rg := true 776 | ELSE Aweider^.Rg := false; 777 | IF Aweider^.gen^.g(.Fk.) = '1' THEN Aweider^.Fk := true 778 | ELSE Aweider^.Fk := false; 779 | IF Aweider^.gen^.g(.Rk.) = '1' THEN Aweider^.Rk := true 780 | ELSE Aweider^.Rk := false; 781 | 782 | END; 783 | Aweider^.nach := Wweider; 784 | Wweider^.vor := Aweider; 785 | END; 786 | PROCEDURE abbauweider(z:TPweider); 787 | BEGIN 788 | IF z <> Wweider THEN abbauweider(z^.nach); 789 | DISPOSE(z,done); 790 | END; 791 | PROCEDURE aufbaurauber; 792 | BEGIN 793 | NEW(Wrauber,init) 794 | END; 795 | PROCEDURE abbaurauber; 796 | BEGIN 797 | DISPOSE(Wrauber,done); 798 | END; 799 | PROCEDURE aufbaunahrung; 800 | BEGIN 801 | new(Wnahrung,init); 802 | END; 803 | PROCEDURE abbaunahrung; 804 | BEGIN 805 | DISPOSE(Wnahrung,done); 806 | END; 807 | PROCEDURE aufbauzelle; 808 | BEGIN 809 | NEW(Wzelle,init) 810 | END; 811 | PROCEDURE abbauzelle; 812 | BEGIN 813 | DISPOSE(Wzelle,done) 814 | END; 815 | PROCEDURE aufbau; 816 | VAR z:integer; 817 | BEGIN 818 | z := 1; 819 | new(n); 820 | xa := n; 821 | x := n; 822 | x^.i := z; 823 | REPEAT 824 | z := z +1; 825 | new(n); 826 | x^.n := n; 827 | n^.v := x; 828 | x := n; 829 | x^.i := z; 830 | UNTIL z = 69; 831 | x^.n := xa; 832 | xa^.v := x; 833 | 834 | z := 1; 835 | new(n); 836 | ya := n; 837 | y := n; 838 | y^.i := z; 839 | REPEAT 840 | z := z +1; 841 | new(n); 842 | y^.n := n; 843 | n^.v := y; 844 | y := n; 845 | y^.i := z; 846 | UNTIL z = 24; 847 | y^.n := ya; 848 | ya^.v := y; 849 | END; 850 | 851 | PROCEDURE abbaux(x:Tzahl); 852 | BEGIN 853 | IF x^.n <> xa THEN abbaux(x^.n); 854 | dispose(x); 855 | END; 856 | 857 | PROCEDURE abbauy(y:Tzahl); 858 | BEGIN 859 | IF y^.n <> ya THEN abbauy(y^.n); 860 | dispose(y); 861 | END; 862 | 863 | FUNCTION neu (VAR r:Ttorus; VAR x,y:Tzahl):TPzelle; 864 | VAR z:TPzelle; 865 | BEGIN 866 | z := r(.x^.i,y^.i.); 867 | IF TypeOF(z^) = TypeOf(rauber) 868 | THEN 869 | BEGIN 870 | IF Wrauber^.rloeschen(x,y,r) THEN neu := Wzelle 871 | ELSE neu := z; 872 | END 873 | ELSE 874 | BEGIN 875 | IF TypeOF(z^) = TypeOf(nahrung) 876 | THEN 877 | BEGIN 878 | IF Wnahrung^.nloeschen(x,y,r) THEN neu := Wzelle 879 | ELSE neu := z; 880 | END 881 | ELSE 882 | BEGIN 883 | IF TypeOF(z^) = TypeOf(weider) 884 | THEN 885 | BEGIN 886 | (*neu := z;*) 887 | Aweider := Wweider; 888 | REPEAT 889 | Aweider := Aweider^.nach 890 | UNTIL @Aweider^ =@z^; 891 | (*Aweider^.init; schon beim Aufbau Konsturktor aufgerufen*) 892 | IF Aweider^.nloeschen(x,y,r) 893 | THEN neu := Wzelle 894 | ELSE 895 | IF Aweider^.getfit = 0 896 | THEN 897 | neu:= Wzelle 898 | ELSE 899 | BEGIN 900 | Aweider^.Rfit(stoffwechsel); 901 | Aweider^.Bgefahr(x,y,r); 902 | Aweider^.Rverteidigung; 903 | Aweider^.Rweidererkennen(x,y,r); 904 | Aweider^.Rkooperieren; 905 | IF ((Aweider^.getgefahr)AND NOT(Aweider^.getverteidigen)) 906 | THEN 907 | BEGIN 908 | Aweider^.Rfit(-1*(Aweider^.getfit)); 909 | neu := Wzelle; 910 | END 911 | ELSE 912 | BEGIN 913 | Aweider^.Bfutter(x,y,r); 914 | Aweider^.Rfressen(x,y,r); 915 | neu := @Aweider^; 916 | END 917 | END; 918 | END 919 | ELSE 920 | BEGIN 921 | IF TypeOF(z^) = TypeOf(zelle) 922 | THEN 923 | BEGIN 924 | IF z^.nnahrung(x,y,r) 925 | THEN neu:= Wnahrung 926 | ELSE 927 | BEGIN 928 | IF z^.nrauber(x,y,r) 929 | THEN neu:= Wrauber 930 | ELSE 931 | BEGIN 932 | IF z^.nweider(x,y,r) 933 | THEN neu:= Aweider 934 | ELSE neu := z 935 | END; 936 | END 937 | END 938 | END 939 | END 940 | END 941 | END; 942 | 943 | PROCEDURE status; 944 | BEGIN 945 | textbackground(red); 946 | textcolor(white); 947 | window(1,1,11,24); 948 | CLRSCR;gotoxy(1,1); 949 | WRITELN('ngfvwk fit'); 950 | Aweider := Wweider; 951 | REPEAT 952 | writeln(Aweider^.gen^.g,' ',Aweider^.fit); 953 | Aweider := Aweider^.nach; 954 | UNTIL Aweider^.nach = Wweider; 955 | END; 956 | 957 | PROCEDURE schreibe (z:TPzelle); 958 | BEGIN 959 | IF TYPEOF(z^) = TypeOf(rauber) 960 | THEN BEGIN textcolor(red); WRITE(char(4)) END 961 | ELSE 962 | BEGIN 963 | IF TypeOf(z^) = TypeOF(weider) 964 | THEN BEGIN textcolor(lightgreen); WRITE(char(2)) END 965 | ELSE 966 | BEGIN 967 | IF TypeOf(z^) = TYPEOF(nahrung) 968 | THEN BEGIN textcolor (yellow );Write(char(26)) END 969 | ELSE BEGIN textcolor(blue);WRITE(' ') END 970 | END; 971 | END 972 | 973 | END; 974 | PROCEDURE spiel(VAR von,nach :Ttorus); 975 | BEGIN 976 | x:=xa; 977 | y:=ya; 978 | textbackground(blue); 979 | window(12,1,80,25); 980 | GOTOxy(1,1); 981 | REPEAT 982 | REPEAT 983 | nach(.x^.i,y^.i.):= (* von(.x^.i,y^.i.) ;*)neu(von,x,y); 984 | schreibe(nach(.x^.i,y^.i.)); 985 | x := x^.n 986 | UNTIL x =xa; 987 | y := y^.n 988 | UNTIL y =ya; 989 | END; 990 | 991 | PROCEDURE zufall(VAR a:Ttorus); 992 | VAR z :integer; 993 | BEGIN 994 | Textbackground(blue); 995 | window(11,1,80,24); 996 | clrscr; 997 | GOTOxy(1,1); 998 | window(11,1,80,25); 999 | Aweider := Wweider; 1000 | y :=ya; 1001 | x :=xa; 1002 | REPEAT 1003 | REPEAT 1004 | (*Zufallsbelegung*) 1005 | z := random(100); 1006 | CASE z OF 1007 | 0: a(.x^.i,y^.i.) := Wnahrung; 1008 | 1: a(.x^.i,y^.i.) := Wrauber; 1009 | 2: a(.x^.i,y^.i.) := Wzelle; 1010 | 3: BEGIN 1011 | a(.x^.i,y^.i.):= Aweider; 1012 | Aweider := Aweider^.nach; 1013 | END 1014 | ELSE a(.x^.i,y^.i.) := Wzelle; 1015 | END; 1016 | schreibe(a(.x^.i,y^.i.)); 1017 | x := x^.n 1018 | UNTIL x =xa; 1019 | y := y^.n 1020 | UNTIL y =ya; 1021 | status; 1022 | Aweider:= Wweider; 1023 | END; 1024 | 1025 | 1026 | PROCEDURE hauptprogramm; 1027 | VAR z:integer; 1028 | BEGIN 1029 | Window(1,25,80,25); 1030 | textcolor(white); 1031 | textbackground(red); 1032 | clrscr; 1033 | write('n Nahrung g gefahr f fressen v verteidigen w Weider erkennen k kooperieren '); 1034 | randomize; 1035 | REPEAT 1036 | zufall(bilda); 1037 | Z := 0; 1038 | REPEAT 1039 | spiel(bilda,bildb); 1040 | Status; 1041 | spiel(bildb,bilda); 1042 | Status; 1043 | z := z + 1; 1044 | Until keypressed or (z = 5); 1045 | crossing_over; 1046 | UNTIL KEYPRESSED 1047 | END; 1048 | (*----------------------- Hauptprogramm --------------*) 1049 | 1050 | BEGIN 1051 | checkbreak := false; 1052 | clrscr; 1053 | aufbau; 1054 | aufbaugene; 1055 | aufbauweider; 1056 | aufbaunahrung; 1057 | aufbaurauber; 1058 | aufbauzelle; 1059 | hauptprogramm; 1060 | x := xa; 1061 | abbaux(x); 1062 | Agen := Wgen; 1063 | abbaugene(Agen); 1064 | Aweider := Wweider; 1065 | abbauweider(Aweider); 1066 | abbaunahrung; 1067 | abbaurauber; 1068 | abbauzelle; 1069 | y:=ya; 1070 | abbauy(y); 1071 | window(1,1,80,25); 1072 | textbackground(black); 1073 | textcolor(white); 1074 | clrscr; 1075 | checkbreak := true; 1076 | END. --------------------------------------------------------------------------------