\ ********************************************************** \ Life \ ********************************************************** \ Autoren: Klaus Kohl-Schöpe (KKS) \ Source: Testprogram uCF V2.1 \ \ 14.05.13 KKS: Angepaßt an SmallForth \ 17.07.07 KKS: Seq. File erstellt \ 14.04.13 KKS: r-Pentomino ergänzt \ ********************************************************** \ Hinweise: \ * Es wird der Bildschirm bis auf einen Rand verwendet \ * Bedingungen für die nächste Generation \ - bei 3 Nachbaren wird die Zelle neu besetzt \ - bei 2 oder 3 Nachbaren bleibt die Zelle erhalten \ - sonst wird die Zelle gelöscht \ ********************************************************** \ ********************************************************** \ Zusätzliche Routine: Zufallszahlengenerator \ ********************************************************** Variable (rnd #1234 (rnd ! : rnd ( -- rnd ) (rnd @ #31421 * #6927 + dup (rnd ! ; \ ********************************************************** \ Constanten und Datenfelder \ ********************************************************** \ Fenstergröße (evtl. abhängig vom Bildschirm) #64 Constant #ax #64 Constant #ay : array here ; \ ins freie RAM \ Array initialisieren : ainit ( f -- ) \ 1 = RND; 2 = r-Pentomino CASE 1 OF array #ax #ay * FOR rnd #msb u2/ u2/ u< IF $80 ELSE 0 THEN over c! 1+ NEXT drop ENDOF 2 OF array #ax #ay * FOR 0 over c! 1+ NEXT drop array #ax #ay 2/ * + #ax 2/ + $80 over c! 1+ $80 over c! #ax + 2 - $80 over c! 1+ $80 over c! #ax + $80 swap c! ENDOF ENDCASE ; \ ********************************************************** \ Array ausgeben, dabei belegte Zellen ermitteln \ ********************************************************** \ Array anzeigen : array. ( -- ) cr array #ay FOR #ax FOR count IF $01 emit ELSE space THEN NEXT cr NEXT cr drop ; \ ********************************************************** \ Nächste Generation ermitteln \ ********************************************************** \ Zellenzähler erhöhen, wenn benachbarte Zelle gesetzt : ?a++ ( addr addr2 -- addr addr2 ) dup c@ $80 and IF >r dup c@ 1+ over c! r> THEN ; \ Erste Linie : afline ( -- array+#ay ) array dup #ax + ?a++ 1+ ?a++ #ax - ?a++ swap #ax 2 - FOR ?a++ #ax + ?a++ 1+ ?a++ 1+ ?a++ #ax - ?a++ swap NEXT ?a++ #ax + ?a++ 1+ ?a++ drop 1+ ; \ Letzte Linie : alline ( addr -- ) dup #ax - ?a++ 1+ ?a++ #ax + ?a++ #ax 2 - FOR swap ?a++ #ax - ?a++ 1+ ?a++ 1+ ?a++ #ax + ?a++ NEXT swap ?a++ #ax - ?a++ 1+ ?a++ drop drop ; \ Zwischenlinien : aline ( addr -- addr+#ax ) dup #ax - ?a++ 1+ ?a++ #ax + ?a++ #ax + ?a++ 1- ?a++ #ax 2 - FOR swap 1+ swap ?a++ #ax - ?a++ #ax - ?a++ 1+ ?a++ 1+ ?a++ #ax + ?a++ #ax + ?a++ 1- ?a++ NEXT swap 1+ swap ?a++ #ax - ?a++ #ax - ?a++ 1+ ?a++ #ax 2* + ?a++ drop 1+ ; \ Werte auswerten : aeval ( -- ) array #ax #ay * FOR dup c@ dup $7f and swap $80 and IF 2 4 within ELSE 3 = THEN $80 and over c! 1+ NEXT drop ; \ Nächste Generation ermitteln : nextgen ( -- ) afline #ay 2 - FOR aline NEXT alline \ Update aeval ; \ ********************************************************** \ Bedienung und Hauptprogramm \ ********************************************************** \ Flag für letzte Taste Variable kc \ Diverse Tasten abfragen : kcheck ( -- -1 | f 0 ) kc @ 0 kc ! 0= IF key? 0= IF 0. exit THEN THEN \ Abfrage notwendig ? key dup $0d = IF drop 1 0 exit THEN \ CR = Neustart upc dup [char] R = IF drop 2 0 exit THEN \ R = r-Pentomino dup [char] X = IF drop -1 exit THEN \ "x" = Ende $20 = IF -1 kc ! THEN 0. ; \ Space = Step \ Hauptprogramm : life ( -- ) unused 0 #ax #ay um* du< IF abort" Nicht genug freier Speicher" THEN cr ." Life (Press key to start) " cr 1 BEGIN 1+ key? UNTIL key drop (rnd ! page ." Life running with mcForth V1.0 by K. Kohl-Schoepe" cr ." (Space = Step / CR = Random / R = r-Pentomino / X = End)" cr 0 kc ! 1 1 BEGIN ?dup IF ainit drop 1 ELSE nextgen 1+ THEN 0 2 at-xy ." Generation: " dup 8 .r array. depth 1- IF cr ." Stack ???" cr quit THEN kcheck UNTIL drop bye ;