1 2(********************************************************************) 3(* *) 4(* wator.sd7 Planet Wator simulation with fish and sharks *) 5(* Copyright (C) 2006 Thomas Mertes *) 6(* *) 7(* This program is free software; you can redistribute it and/or *) 8(* modify it under the terms of the GNU General Public License as *) 9(* published by the Free Software Foundation; either version 2 of *) 10(* the License, or (at your option) any later version. *) 11(* *) 12(* This program is distributed in the hope that it will be useful, *) 13(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 15(* GNU General Public License for more details. *) 16(* *) 17(* You should have received a copy of the GNU General Public *) 18(* License along with this program; if not, write to the *) 19(* Free Software Foundation, Inc., 51 Franklin Street, *) 20(* Fifth Floor, Boston, MA 02110-1301, USA. *) 21(* *) 22(********************************************************************) 23 24 25$ include "seed7_05.s7i"; 26 include "console.s7i"; 27 include "window.s7i"; 28 include "keybd.s7i"; 29 include "float.s7i"; 30 include "draw.s7i"; 31 include "stdfont9.s7i"; 32 include "pixmap_file.s7i"; 33 include "editline.s7i"; 34 35const integer: MAX_LINE is 100; 36const integer: MAX_COLUMN is 100; 37const integer: CELL_SIZE is 4; 38const integer: SCALE_FISH is 150; 39const integer: SCALE_SHARKS is 40; 40const integer: GRAPH_TOP is CELL_SIZE * (MAX_LINE + 2); 41const integer: GRAPH_BOTTOM is 478; 42 43var integer: nfish is 0; 44var integer: nsharks is 0; 45var integer: fbreed is 1; 46var integer: sbreed is 1; 47var integer: slife is 1; 48 49var integer: cycle is 0; 50 51var integer: maxfish is 0; 52var integer: minfish is 0; 53var integer: maxsharks is 0; 54var integer: minsharks is 0; 55 56const integer: EMPTY is 1; 57const integer: FISH is 2; 58const integer: SHARK is 3; 59 60const type: cellType is new struct 61 var integer: content is EMPTY; 62 var boolean: processed is FALSE; 63 var integer: fish is -1; 64 var integer: shark is -1; 65 var integer: starve is -1; 66 end struct; 67 68const type: fieldType is array array cellType; 69 70var fieldType: field is MAX_LINE times MAX_COLUMN times cellType.value; 71 72var array integer: sumContent is 3 times 0; 73 74var text: scr is STD_NULL; 75var text: info is STD_NULL; 76 77 78const proc: introduction is func 79 local 80 var text: intro is STD_NULL; 81 begin 82 # intro := openWindow(scr, 1, 12, height(scr), width(scr) - 12); 83 intro := scr; 84 setPos(intro, 1, 1); 85 writeln(intro, "W A T O R"); 86 setPos(intro, 3, 1); 87 writeln(intro, "Copyright (C) 2006 Thomas Mertes"); 88 setPos(intro, 5, 1); 89 writeln(intro, "This program is free software under the"); 90 setPos(intro, 6, 1); 91 writeln(intro, "terms of the GNU General Public License"); 92 setPos(intro, 8, 1); 93 writeln(intro, "Wator is written in the Seed7 programming language"); 94 setPos(intro, 9, 1); 95 writeln(intro, "Homepage: http://seed7.sourceforge.net"); 96 setPos(intro, 12, 1); 97 writeln(intro, "This program simulates the planet WATOR as described in Scientific American Computer"); 98 writeln(intro, "Recreations column, Dec 1984. WATOR (or Wa-Tor) is a toroidal (donut-shaped) planet"); 99 writeln(intro, "inhabited by fish and sharks. The fish feed on a ubiquitous plankton and the sharks"); 100 writeln(intro, "feed on the fish. Time passes in discrete jumps or cycles. During each cycle, fish"); 101 writeln(intro, "move randomly to an unoccupied square, and reproduce if old enough. Sharks move to"); 102 writeln(intro, "a square occupied by a fish and eat it, if possible, or move to an open square if no"); 103 writeln(intro, "meals are available. Sharks will also breed if old enough, but will starve if they"); 104 writeln(intro, "do not eat within a specified period of time."); 105 writeln(intro); 106 writeln(intro, "Parameters selected at the beginning of the run are as follows:"); 107 writeln(intro, " nfish: Number of fish at start of run-distributed randomly."); 108 writeln(intro, " nsharks: Number of sharks at start, also distributed randomly."); 109 writeln(intro, " fbreed: Number of cycles a fish must exist before reproducing."); 110 writeln(intro, " sbreed: Number of cycles sharks must exist before reproducing."); 111 writeln(intro, " starve: Number of cycles a shark has to find food before starving."); 112 writeln(intro); 113 writeln(intro, "On the screen, fish are green and sharks are blue. After the initial screen is"); 114 writeln(intro, "displayed, press any key to start the simulation. During the run, pressing any key"); 115 writeln(intro, "will stop the program."); 116 writeln(intro); 117 writeln(intro, "Press any key to continue."); 118 end func; 119 120 121const proc: display is func 122 local 123 var integer: line is 0; 124 var integer: column is 0; 125 var integer: newfish is 0; 126 var integer: newsharks is 0; 127 begin 128 sumContent := 3 times 0; 129 for line range 1 to MAX_LINE do 130 for column range 1 to MAX_COLUMN do 131 if field[line][column].processed then 132 field[line][column].processed := FALSE; 133 if field[line][column].content = EMPTY then 134 rect(CELL_SIZE * column, CELL_SIZE * line, CELL_SIZE, CELL_SIZE, black); 135 elsif field[line][column].content = FISH then 136 incr(newfish); 137 rect(CELL_SIZE * column, CELL_SIZE * line, CELL_SIZE, CELL_SIZE, light_green); 138 else # if field[line][column].content = SHARK then 139 incr(newsharks); 140 rect(CELL_SIZE * column, CELL_SIZE * line, CELL_SIZE, CELL_SIZE, light_blue); 141 end if; 142 else 143 incr(sumContent[field[line][column].content]); 144 end if; 145 end for; 146 end for; 147 sumContent[FISH] +:= newfish; 148 sumContent[SHARK] +:= newsharks; 149 end func; 150 151 152const proc: writeInfo is func 153 begin 154 rect(CELL_SIZE * succ(MAX_LINE) + 60, 8 * lineHeight(stdFont9), 155 40, lineHeight(stdFont9), black); 156 setPosXY(info, 90 - width(stdFont9, str(sumContent[FISH])), 157 8 * lineHeight(stdFont9) + baseLineDelta(stdFont9)); 158 write(info, sumContent[FISH]); 159 if sumContent[FISH] < minfish then 160 minfish := sumContent[FISH]; 161 rect(CELL_SIZE * succ(MAX_LINE) + 60, 9 * lineHeight(stdFont9), 162 40, lineHeight(stdFont9), black); 163 setPosXY(info, 90 - width(stdFont9, str(minfish)), 164 9 * lineHeight(stdFont9) + baseLineDelta(stdFont9)); 165 write(info, minfish); 166 elsif sumContent[FISH] > maxfish then 167 maxfish := sumContent[FISH]; 168 rect(CELL_SIZE * succ(MAX_LINE) + 60, 10 * lineHeight(stdFont9), 169 40, lineHeight(stdFont9), black); 170 setPosXY(info, 90 - width(stdFont9, str(maxfish)), 171 10 * lineHeight(stdFont9) + baseLineDelta(stdFont9)); 172 write(info, maxfish); 173 end if; 174 rect(CELL_SIZE * succ(MAX_LINE) + 60, 12 * lineHeight(stdFont9), 175 40, lineHeight(stdFont9), black); 176 setPosXY(info, 90 - width(stdFont9, str(sumContent[SHARK])), 177 12 * lineHeight(stdFont9) + baseLineDelta(stdFont9)); 178 write(info, sumContent[SHARK]); 179 if sumContent[SHARK] < minsharks then 180 minsharks := sumContent[SHARK]; 181 rect(CELL_SIZE * succ(MAX_LINE) + 60, 13 * lineHeight(stdFont9), 182 40, lineHeight(stdFont9), black); 183 setPosXY(info, 90 - width(stdFont9, str(minsharks)), 184 13 * lineHeight(stdFont9) + baseLineDelta(stdFont9)); 185 write(info, minsharks); 186 elsif sumContent[SHARK] > maxsharks then 187 maxsharks := sumContent[SHARK]; 188 rect(CELL_SIZE * succ(MAX_LINE) + 60, 14 * lineHeight(stdFont9), 189 40, lineHeight(stdFont9), black); 190 setPosXY(info, 90 - width(stdFont9, str(maxsharks)), 191 14 * lineHeight(stdFont9) + baseLineDelta(stdFont9)); 192 write(info, maxsharks); 193 end if; 194 rect(CELL_SIZE * succ(MAX_LINE) + 90, 16 * lineHeight(stdFont9), 195 50, lineHeight(stdFont9), black); 196 setPosXY(info, 130 - width(stdFont9, str(cycle)), 197 16 * lineHeight(stdFont9) + baseLineDelta(stdFont9)); 198 write(info, cycle); 199 end func; 200 201 202const proc: initInfo is func 203 begin 204 maxfish := sumContent[FISH]; 205 minfish := sumContent[FISH]; 206 maxsharks := sumContent[SHARK]; 207 minsharks := sumContent[SHARK]; 208 setPos(info, 9, 1); 209 writeln(info, "Fish:"); 210 writeln(info, " min:"); 211 writeln(info, " max:"); 212 writeln(info); 213 writeln(info, "Sharks:"); 214 writeln(info, " min:"); 215 writeln(info, " max:"); 216 writeln(info); 217 writeln(info, "Generation: "); 218 writeInfo; 219 end func; 220 221 222const proc: initialize is func 223 (* Initialize arrays, get starting parameters, set up the screen *) 224 local 225 var integer: line is 0; 226 var integer: column is 0; 227 var integer: number is 0; 228 begin 229 cycle := 0; 230 clear(info); 231 setPos(info, 1, 1); 232 writeln(info, "W A T O R"); 233 repeat 234 setPos(info, 3, 1); 235 write(info, "nfish= "); 236 readln(nfish); 237 if nfish > MAX_LINE * MAX_COLUMN then 238 writeln(info, "*** Too many fish (" <& nfish <& ")"); 239 write(info, "Maximum is " <& MAX_LINE * MAX_COLUMN); 240 setPos(info, 3, 1); 241 write(info, " " mult 30); 242 else 243 writeln(info, " " mult 30); 244 write(info, " " mult 30); 245 end if; 246 until nfish <= MAX_LINE * MAX_COLUMN; 247 repeat 248 setPos(info, 4, 1); 249 write(info, "nsharks= "); 250 readln(nsharks); 251 if nfish + nsharks > MAX_LINE * MAX_COLUMN then 252 writeln(info, "*** Too many sharks (" <& nsharks <& ")"); 253 write(info, "Maximum is " <& MAX_LINE * MAX_COLUMN - nfish); 254 setPos(info, 4, 1); 255 write(info, " " mult 30); 256 else 257 writeln(info, " " mult 30); 258 write(info, " " mult 30); 259 end if; 260 until nfish + nsharks <= MAX_LINE * MAX_COLUMN; 261 setPos(info, 5, 1); 262 write(info, "fbreed= "); 263 readln(fbreed); 264 write(info, "sbreed= "); 265 readln(sbreed); 266 write(info, "slife= "); 267 readln(slife); 268 for line range 1 to MAX_LINE do 269 for column range 1 to MAX_COLUMN do 270 field[line][column].content := EMPTY; 271 field[line][column].processed := FALSE; 272 field[line][column].fish := -1; 273 field[line][column].shark := -1; 274 field[line][column].starve := -1; 275 end for; 276 end for; 277 for number range 1 to nfish do 278 repeat 279 line := rand(1, MAX_LINE); 280 column := rand(1, MAX_COLUMN); 281 until field[line][column].content = EMPTY; 282 field[line][column].content := FISH; 283 field[line][column].processed := TRUE; 284 field[line][column].fish := rand(0, pred(fbreed)); 285 end for; 286 for number range 1 to nsharks do 287 repeat 288 line := rand(1, MAX_LINE); 289 column := rand(1, MAX_COLUMN); 290 until field[line][column].content = EMPTY; 291 field[line][column].content := SHARK; 292 field[line][column].processed := TRUE; 293 field[line][column].shark := rand(0, pred(sbreed)); 294 field[line][column].starve := rand(0, pred(slife)); 295 end for; 296 boxTo(CELL_SIZE - 3, CELL_SIZE - 3, 297 CELL_SIZE * succ(MAX_LINE) + 2, 298 CELL_SIZE * succ(MAX_LINE) + 2, white); 299 display; 300 initInfo; 301 end func; 302 303 304const proc: moveFish (inout cellType: source, inout cellType: dest) is func 305 (* Make move, fish breeds if old enough to reproduce *) 306 begin 307 dest.content := FISH; 308 dest.processed := TRUE; 309 if source.fish = fbreed then 310 dest.fish := 0; 311 source.fish := rand(0, pred(fbreed)); # Randomize parent breed time. This was 0 312 else 313 dest.fish := succ(source.fish); 314 source.content := EMPTY; 315 source.processed := TRUE; 316 end if; 317 end func; 318 319 320const proc: moveAllFish is func 321 local 322 var integer: line is 0; 323 var integer: column is 0; 324 var integer: up_line is 0; 325 var integer: down_line is 0; 326 var integer: left_column is 0; 327 var integer: right_column is 0; 328 var integer: column_byond is 0; 329 var integer: column_step is 0; 330 var integer: nmoves is 0; 331 var array integer: moveopts is 4 times 0; 332 begin 333 for line range 1 to MAX_LINE do 334 if line = 1 then 335 up_line := MAX_LINE; 336 else 337 up_line := pred(line); 338 end if; 339 if line = MAX_LINE then 340 down_line := 1; 341 else 342 down_line := succ(line); 343 end if; 344 if odd(line) then 345 column := 1; 346 column_byond := succ(MAX_COLUMN); 347 column_step := 1; 348 else 349 column := MAX_COLUMN; 350 column_byond := 0; 351 column_step := -1; 352 end if; 353 while column <> column_byond do 354 (* Look through array for fish and check if already processed *) 355 if field[line][column].content = FISH and not field[line][column].processed then 356 if column = 1 then 357 left_column := MAX_COLUMN; 358 else 359 left_column := pred(column); 360 end if; 361 if column = MAX_COLUMN then 362 right_column := 1; 363 else 364 right_column := succ(column); 365 end if; 366 nmoves := 0; 367 (* Look around to see where fish can be moved *) 368 if field[line][left_column].content = EMPTY then 369 incr(nmoves); 370 moveopts[nmoves] := 1; 371 end if; 372 if field[line][right_column].content = EMPTY then 373 incr(nmoves); 374 moveopts[nmoves] := 2; 375 end if; 376 if field[up_line][column].content = EMPTY then 377 incr(nmoves); 378 moveopts[nmoves] := 3; 379 end if; 380 if field[down_line][column].content = EMPTY then 381 incr(nmoves); 382 moveopts[nmoves] := 4; 383 end if; 384 if nmoves = 0 then 385 (* If nowhere to go they just get older *) 386 if field[line][column].fish = fbreed then 387 field[line][column].fish := 0 388 else 389 incr(field[line][column].fish); 390 end if; 391 else 392 (* Pick a move to make *) 393 case moveopts[rand(1, nmoves)] of 394 when {1}: 395 moveFish(field[line][column], field[line][left_column]); 396 when {2}: 397 moveFish(field[line][column], field[line][right_column]); 398 when {3}: 399 moveFish(field[line][column], field[up_line][column]); 400 when {4}: 401 moveFish(field[line][column], field[down_line][column]); 402 end case; 403 end if; 404 end if; 405 column +:= column_step; 406 end while; 407 end for; 408 end func; 409 410 411const proc: killFish (inout cellType: source, inout cellType: dest) is func 412 begin 413 dest.content := SHARK; 414 dest.processed := TRUE; 415 dest.starve := 0; 416 if source.shark = sbreed then 417 dest.shark := 0; 418 source.shark := rand(0, pred(sbreed)); # Randomize parent breed time. This was 0 419 source.starve := 0; 420 else 421 dest.shark := succ(source.shark); 422 source.content := EMPTY; 423 source.processed := TRUE; 424 end if; 425 end func; 426 427 428const proc: moveShark (inout cellType: source, inout cellType: dest) is func 429 begin 430 dest.content := SHARK; 431 dest.processed := TRUE; 432 dest.starve := succ(source.starve); 433 if source.shark = sbreed then 434 dest.shark := 0; 435 source.shark := rand(0, pred(sbreed)); # Randomize parent breed time. This was 0 436 incr(source.starve); 437 else 438 dest.shark := succ(source.shark); 439 source.content := EMPTY; 440 source.processed := TRUE; 441 end if; 442 end func; 443 444 445const proc: moveAllSharks is func 446 local 447 var integer: line is 0; 448 var integer: column is 0; 449 var integer: up_line is 0; 450 var integer: down_line is 0; 451 var integer: left_column is 0; 452 var integer: right_column is 0; 453 var integer: nmoves is 0; 454 var integer: nmeals is 0; 455 var array integer: moveopts is 4 times 0; 456 begin 457 for line range 1 to MAX_LINE do 458 if line = 1 then 459 up_line := MAX_LINE; 460 else 461 up_line := pred(line); 462 end if; 463 if line = MAX_LINE then 464 down_line := 1; 465 else 466 down_line := succ(line); 467 end if; 468 for column range 1 to MAX_COLUMN do 469 (* Look through array for sharks and check if already processed *) 470 if field[line][column].content = SHARK and not field[line][column].processed then 471 if column = 1 then 472 left_column := MAX_COLUMN; 473 else 474 left_column := pred(column); 475 end if; 476 if column = MAX_COLUMN then 477 right_column := 1; 478 else 479 right_column := succ(column); 480 end if; 481 nmeals := 0; 482 (* Look around to see where sharks can be moved *) 483 if field[line][left_column].content = FISH then 484 incr(nmeals); 485 moveopts[nmeals] := 1; 486 end if; 487 if field[line][right_column].content = FISH then 488 incr(nmeals); 489 moveopts[nmeals] := 2; 490 end if; 491 if field[up_line][column].content = FISH then 492 incr(nmeals); 493 moveopts[nmeals] := 3; 494 end if; 495 if field[down_line][column].content = FISH then 496 incr(nmeals); 497 moveopts[nmeals] := 4; 498 end if; 499 (* If the shark finds a fish to eat, pick one and eat it, breed if possible *) 500 if nmeals > 0 then 501 case moveopts[rand(1, nmeals)] of 502 when {1}: 503 killFish(field[line][column], field[line][left_column]); 504 when {2}: 505 killFish(field[line][column], field[line][right_column]); 506 when {3}: 507 killFish(field[line][column], field[up_line][column]); 508 when {4}: 509 killFish(field[line][column], field[down_line][column]); 510 end case; 511 elsif field[line][column].starve < slife then 512 (* If no meals in vicinity, look for an empty square to move to *) 513 nmoves := 0; 514 if field[line][left_column].content = EMPTY then 515 incr(nmoves); 516 moveopts[nmoves] := 1; 517 end if; 518 if field[line][right_column].content = EMPTY then 519 incr(nmoves); 520 moveopts[nmoves] := 2; 521 end if; 522 if field[up_line][column].content = EMPTY then 523 incr(nmoves); 524 moveopts[nmoves] := 3; 525 end if; 526 if field[down_line][column].content = EMPTY then 527 incr(nmoves); 528 moveopts[nmoves] := 4; 529 end if; 530 if nmoves = 0 then 531 (* If there is nothing to eat and no place to go the shark gets older *) 532 if field[line][column].shark = sbreed then 533 field[line][column].shark := 0; 534 else 535 incr(field[line][column].shark); 536 end if; 537 incr(field[line][column].starve); 538 else 539 (* If there is a move to make pick one from the available squares *) 540 case moveopts[rand(1, nmoves)] of 541 when {1}: 542 moveShark(field[line][column], field[line][left_column]) 543 when {2}: 544 moveShark(field[line][column], field[line][right_column]) 545 when {3}: 546 moveShark(field[line][column], field[up_line][column]) 547 when {4}: 548 moveShark(field[line][column], field[down_line][column]) 549 end case; 550 end if; 551 else 552 field[line][column].content := EMPTY; 553 field[line][column].processed := TRUE; 554 end if; 555 end if; 556 end for; 557 end for; 558 end func; 559 560 561const proc: main is func 562 local 563 var char: inchar is ' '; 564 var integer: oldFishGraph is 0; 565 var integer: oldSharkGraph is 0; 566 var integer: newFishGraph is 0; 567 var integer: newSharkGraph is 0; 568 begin 569 screen(640, 480); 570 selectInput(curr_win, KEY_CLOSE, TRUE); 571 clear(black); 572 scr := openPixmapFontFile(curr_win, 35, 10); 573 setFont(scr, stdFont9); 574 color(scr, white, black); 575 info := openPixmapFontFile(curr_win, CELL_SIZE * succ(MAX_LINE) + 10, 0); 576 setFont(info, stdFont9); 577 color(info, white, black); 578 KEYBOARD := GRAPH_KEYBOARD; 579 IN := openEditLine(KEYBOARD, info); 580 introduction; 581 inchar := upper(getc(KEYBOARD)); 582 while inchar <> 'Q' and inchar <> KEY_CLOSE and inchar <> KEY_ESC do 583 clear(black); 584 initialize; 585 oldFishGraph := GRAPH_BOTTOM - sumContent[FISH] div SCALE_FISH; 586 oldSharkGraph := GRAPH_BOTTOM - sumContent[SHARK] div SCALE_SHARKS; 587 point(cycle rem 640, oldFishGraph, light_green); 588 point(cycle rem 640, oldSharkGraph, light_blue); 589 setPos(info, 26, 1); 590 writeln(info, "Simulation prepared. Press"); 591 writeln(info, " Enter to start"); 592 writeln(info, " N to start a new simulation"); 593 writeln(info, " Q to Quit"); 594 inchar := upper(getc(KEYBOARD)); 595 setPos(info, 26, 1); 596 erase(info, "Simulation prepared. Press"); 597 writeln(info); 598 erase(info, " Enter to start"); 599 writeln(info); 600 erase(info, " N to start a new simulation"); 601 writeln(info); 602 erase(info, " Q to Quit"); 603 while inchar not in {'N', 'Q', KEY_CLOSE, KEY_ESC} do 604 moveAllFish; 605 moveAllSharks; 606 display; 607 writeInfo; 608 incr(cycle); 609 newFishGraph := GRAPH_BOTTOM - sumContent[FISH] div SCALE_FISH; 610 if newFishGraph < GRAPH_TOP then 611 newFishGraph := GRAPH_TOP; 612 end if; 613 newSharkGraph := GRAPH_BOTTOM - sumContent[SHARK] div SCALE_SHARKS; 614 if newSharkGraph < GRAPH_TOP then 615 newSharkGraph := GRAPH_TOP; 616 end if; 617 rectTo(cycle rem 640, GRAPH_TOP, cycle rem 640 + 4, GRAPH_BOTTOM, black); 618 if cycle rem 640 = 0 then 619 point(cycle rem 640, newFishGraph, light_green); 620 point(cycle rem 640, newSharkGraph, light_blue); 621 else 622 lineTo(pred(cycle rem 640), oldFishGraph, cycle rem 640, newFishGraph, light_green); 623 lineTo(pred(cycle rem 640), oldSharkGraph, cycle rem 640, newSharkGraph, light_blue); 624 end if; 625 oldFishGraph := newFishGraph; 626 oldSharkGraph := newSharkGraph; 627 if keypressed(KEYBOARD) then 628 repeat 629 inchar := getc(KEYBOARD); 630 until not keypressed(KEYBOARD); 631 setPos(info, 26, 1); 632 writeln(info, "Simulation interrupted. Press"); 633 writeln(info, " Enter to continue"); 634 writeln(info, " N to start a new simulation"); 635 writeln(info, " Q to Quit"); 636 inchar := upper(getc(KEYBOARD)); 637 setPos(info, 26, 1); 638 erase(info, "Simulation interrupted. Press"); 639 writeln(info); 640 erase(info, " Enter to continue"); 641 writeln(info); 642 erase(info, " N to start a new simulation"); 643 writeln(info); 644 erase(info, " Q to Quit"); 645 end if; 646 end while; 647 end while; 648 end func; 649