mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-07-27 07:29:00 +00:00
628 lines
9.2 KiB
Forth
628 lines
9.2 KiB
Forth
|
|
\ *** Block No. 0, Hexblock 0
|
|
|
|
***************** CRAPS *****************************jrg 06okt88
|
|
nach Wil Baden
|
|
|
|
Da es in Deutschland das Würfelspiel CRAPS nicht gibt, habe ich
|
|
diesem Begriff ein Würfel- und Trinkspiel aus der Schulzeit
|
|
unterlegt.
|
|
Bei diesem Spiel steht in der Tischmitte ein Vorrat an gefüllten
|
|
Gläsern. Danach soll ein Mitspieler abhängig von seinem Wurf
|
|
|
|
entweder ein neues Glas aus der Tischmitte vor sich stellen
|
|
oder eines seiner Gläser seinem Nachbarn zur linken oder
|
|
zur rechten zuschieben
|
|
oder alle vor ihm stehenden Gläser austrinken.
|
|
|
|
Zuordnung: 1=nehmen, 2/3=links, 4/5=rechts, 6 trinken
|
|
|
|
|
|
\ *** Block No. 1, Hexblock 1
|
|
|
|
\ nehmen trinken links rechts schieben jrg 03feb89
|
|
|
|
: nehmen bright ." ein Glas nehmen" normal 2 spaces ;
|
|
: trinken bright ." alle Gläser austrinken" normal 2 spaces ;
|
|
: links bright ." ein Glas nach LINKS" normal 2 spaces ;
|
|
: rechts bright ." ein Glas nach RECHTS" normal 2 spaces ;
|
|
|
|
: schieben ;
|
|
|
|
|
|
: Anfrage ." Sollen Sie nehmen, trinken oder schieben? "
|
|
cr ." Bitte Ihre Augenzahl und <cr> : " ;
|
|
|
|
: Glückwunsch cr ." Viel Glück beim nächsten Wurf ... " ;
|
|
|
|
cr .( Sprüche geladen )
|
|
|
|
\ *** Block No. 2, Hexblock 2
|
|
|
|
\ Auswertung mit IF...THEN / ENDIF jrg 03feb89
|
|
|
|
' THEN Alias ENDIF immediate restrict
|
|
|
|
: Auswertung ( 1<= Wurfergebnis <=6 -- )
|
|
|
|
dup 1 = IF nehmen ENDIF
|
|
dup 2 = IF links schieben ENDIF
|
|
dup 3 = IF links schieben ENDIF
|
|
dup 4 = IF rechts schieben ENDIF
|
|
dup 5 = IF rechts schieben ENDIF
|
|
dup 6 = IF trinken ENDIF
|
|
|
|
1 6 between not IF invers ." Betrug!" normal ENDIF
|
|
;
|
|
|
|
|
|
\ *** Block No. 3, Hexblock 3
|
|
|
|
\ =or jrg 06okt88
|
|
|
|
code =or ( n1 f1 n2 -- n1 f2 )
|
|
A D xchg D pop
|
|
S W mov
|
|
W ) A cmp
|
|
0= ?[ -1 # D mov ]?
|
|
next
|
|
end-code
|
|
|
|
\ : =or ( n1 f1 n2 -- n1 f2 ) 2 pick = or ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 4, Hexblock 4
|
|
|
|
\ Auswertung mit IF...THEN und =or jrg 06okt88
|
|
|
|
: Auswertung ( 1<= Wurfergebnis <=6 -- )
|
|
dup
|
|
1 6 between IF
|
|
dup 1 = IF nehmen ENDIF
|
|
dup 6 = IF trinken ENDIF
|
|
dup 2 = 3 =or IF links ENDIF
|
|
dup 4 = 5 =or IF rechts ENDIF
|
|
ELSE
|
|
invers ." Betrugsversuch" normal
|
|
ENDIF
|
|
drop
|
|
;
|
|
|
|
|
|
|
|
\ *** Block No. 5, Hexblock 5
|
|
|
|
\ CASE OF ENDOF END-CASE BREAK jrg 30mai89
|
|
|
|
: CASE ( n -- n n ) dup ; restrict
|
|
|
|
: OF [compile] IF compile drop ; immediate restrict
|
|
|
|
: ENDOF [compile] ELSE 4+ ; immediate restrict
|
|
|
|
: ENDCASE compile drop
|
|
BEGIN
|
|
3 case?
|
|
WHILE
|
|
>resolve
|
|
REPEAT ; immediate restrict
|
|
|
|
: BREAK compile exit [compile] THEN ; immediate restrict
|
|
|
|
\ *** Block No. 6, Hexblock 6
|
|
|
|
\ Auswerten mit CASE OF ENDOF ENDCASE jjrg 05feb89
|
|
|
|
: Auswertung ( 1<= n <=6 -- )
|
|
|
|
dup 1 6 between not IF ." Betrug" drop exit ENDIF
|
|
|
|
CASE 1 = OF nehmen ENDOF
|
|
CASE 6 = OF trinken ENDOF
|
|
CASE 4 < OF links ENDOF
|
|
CASE 3 > OF rechts ENDOF
|
|
ENDCASE
|
|
;
|
|
|
|
|
|
|
|
\ Man beachte die Stellung der Plausibilitätsprüfung
|
|
|
|
\ *** Block No. 7, Hexblock 7
|
|
|
|
\ Auswerten mit =or und BREAK jrg 05feb89
|
|
|
|
: Auswertung ( 1<= n <=6 -- )
|
|
|
|
CASE 1 = OF nehmen BREAK
|
|
CASE 2 = 3 =or OF links BREAK
|
|
CASE 4 = 5 =or OF rechts BREAK
|
|
CASE 6 = OF trinken BREAK
|
|
ENDCASE
|
|
|
|
invers ." Betrugsversuch" normal
|
|
;
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 8, Hexblock 8
|
|
|
|
\ Das CRAPS Programm wie in PASCAL etc. jrg 07okt88
|
|
|
|
: CRAPS
|
|
|
|
cr Anfrage cr
|
|
|
|
input#
|
|
Auswertung
|
|
|
|
cr Glückwunsch
|
|
;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 9, Hexblock 9
|
|
|
|
\ ------------- VECTOR EXECUTION --------------------jrg 07okt88
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 10, Hexblock a
|
|
|
|
\ 4TH braucht Prozeduren jrg 05feb89
|
|
|
|
|
|
: bewegen ( adr n -- cfa )
|
|
2* + perform ;
|
|
|
|
: richtig ( n -- 0<= n <= 3 )
|
|
swap
|
|
1 max 6 min \ ein bißchen Sicherheit
|
|
3 case? IF 2 1- exit ENDIF
|
|
5 case? IF 4 1- exit ENDIF
|
|
1- ; \ ein bißchen Justage
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 11, Hexblock b
|
|
|
|
\ Die möglichen Bewegungen mit ] [ oder Create: jrg 05feb89
|
|
|
|
Create Glas
|
|
] nehmen links schieben
|
|
rechts schieben trinken [
|
|
|
|
|
|
\ oder:
|
|
|
|
Create: Glas
|
|
nehmen
|
|
links schieben
|
|
rechts schieben
|
|
trinken ;
|
|
|
|
|
|
|
|
\ *** Block No. 12, Hexblock c
|
|
|
|
\ Create: ; :Does> jrg 05feb89
|
|
|
|
Create: Auswertung
|
|
nehmen
|
|
links schieben
|
|
rechts schieben
|
|
trinken ;
|
|
:Does>
|
|
richtig bewegen ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 13, Hexblock d
|
|
|
|
\ Das vollständige Programm jrg 05feb89
|
|
|
|
: CRAPS
|
|
cr Anfrage cr
|
|
input#
|
|
Glas richtig bewegen
|
|
cr Glückwunsch
|
|
;
|
|
|
|
\ ausschließlich als Datenstruktur
|
|
: CRAPS
|
|
cr Anfrage cr
|
|
input#
|
|
Auswertung
|
|
cr Glückwunsch
|
|
;
|
|
|
|
\ *** Block No. 14, Hexblock e
|
|
|
|
\ #### positional CASE def.words Case: Associative: jrg 01feb89
|
|
: Case: ( -- )
|
|
Create:
|
|
Does> ( pfa -- ) swap 2* + perform ;
|
|
|
|
: Associative: ( n -- )
|
|
Constant Does> ( n - index )
|
|
dup @ -rot
|
|
dup @ 0
|
|
DO 2+ 2dup @ =
|
|
IF 2drop drop I 0 0 LEAVE THEN
|
|
LOOP 2drop ;
|
|
|
|
\ alternative Definition für CASE:
|
|
: Case:
|
|
: Does> ( pfa -- ) swap 2* + perform ;
|
|
|
|
\ *** Block No. 15, Hexblock f
|
|
|
|
\ CASE: in der Anwendung jrg 01feb89
|
|
|
|
Case: bewegen \ besteht aus :
|
|
nehmen
|
|
links links
|
|
rechts rechts
|
|
trinken ;
|
|
|
|
|
|
6 Associative: auswerten
|
|
|
|
1 ,
|
|
2 , 3 ,
|
|
4 , 5 ,
|
|
6 ,
|
|
|
|
|
|
\ *** Block No. 16, Hexblock 10
|
|
|
|
\ CASE: und Associative: jrg 01feb89
|
|
|
|
: CRAPS ( -- )
|
|
|
|
cr Anfrage cr
|
|
input#
|
|
auswerten
|
|
bewegen
|
|
cr Glückwunsch
|
|
;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 17, Hexblock 11
|
|
|
|
************* Beginn der Kommentare *****************jrg 07okt88
|
|
|
|
|
|
|
|
|
|
|
|
|
|
SCHIEBEN gefällt mir deshalb so gut, weil es vorher nur als
|
|
Füllsel arbeitet, aber hinterher als Dummy in der
|
|
Tabelle die wichtige Funktion hat, sechs mögliche
|
|
Würfe sauber abzuarbeiten.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 18, Hexblock 12
|
|
|
|
\\ Auswertung mit IF...THEN / ENDIF jrg 01feb89
|
|
|
|
ENDIF macht deutlich(er), warum FORTH ohne Verbundanweisung wie
|
|
z.B. PASCAL auskommt.
|
|
AUSWERTUNG führt entsprechend einem Selektor genau eine von 6
|
|
möglichen Prozeduren aus.
|
|
|
|
Auch eine mögliche Form der Auswertung mit CASE? :
|
|
: Auswertung ( 1<= Wurfergebnis <=6 -- )
|
|
1 case? IF nehmen exit ENDIF
|
|
2 case? IF links schieben exit ENDIF
|
|
3 case? IF links schieben exit ENDIF
|
|
4 case? IF rechts schieben exit ENDIF
|
|
5 case? IF rechts schieben exit ENDIF
|
|
6 case? IF trinken exit ENDIF
|
|
1 6 between not IF invers ." Betrugsversuch" normal ENDIF ;
|
|
|
|
\ *** Block No. 19, Hexblock 13
|
|
|
|
\\ hilfreiche Prozeduren für das kommende CASE
|
|
|
|
=OR prüft eine Zahl n2 auf Gleichheit mit einem Testwert n1
|
|
und verknüpft resultierende Ergebnis mit einem bereits
|
|
vorliegenden flag f1. Es werden das neue flag f2 und der
|
|
"alte" Testwert n1 übergeben.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 20, Hexblock 14
|
|
|
|
\\ bedingte Verzweigung mit IF .. ELSE .. ENDIF
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 21, Hexblock 15
|
|
|
|
\\ Die Definitionen für die CASE Anweisung jrg 07okt88
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
BREAK ist ein EXIT aus der CASE-Anweisung; return to caller
|
|
|
|
\ *** Block No. 22, Hexblock 16
|
|
|
|
\\ Auswertung mit CASE OF ENDOF
|
|
|
|
|
|
|
|
Sicherheit gegen falsche Zahlen
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 23, Hexblock 17
|
|
|
|
\\ Die elegantere Auswertung mit BREAK jrg 07okt88
|
|
|
|
BREAK = Verlassen des Callee
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Wird trotz BREAK dieser Prozedurteil erreicht, muß die Zahl un-
|
|
gültig gewesen sein.
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 24, Hexblock 18
|
|
|
|
jrg 07okt88
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 25, Hexblock 19
|
|
|
|
\ Ui jui jui / Test für ein CRAPS
|
|
|
|
: Test
|
|
full page
|
|
20 0 DO
|
|
craps
|
|
LOOP ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 26, Hexblock 1a
|
|
|
|
\\ Für Datenobjekte sind Prozeduren notwendig
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 27, Hexblock 1b
|
|
|
|
\\ Was sind denn die Datenobjekte ? jrg 07okt88
|
|
|
|
GLAS als Datenteil enthält natürlich die in Frage kommenden
|
|
Prozeduren.
|
|
|
|
|
|
|
|
|
|
GLAS ist der gleiche Datenteil wie oben, nur eleganter.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 28, Hexblock 1c
|
|
|
|
\\ Zusammenfassen des Datenteils und des Zugriffsteiljrg 07okt88
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
RICHTIG und BEWEGEN sind die eigens für den Datenteil GLAS ent-
|
|
worfenen Zugriffsprozeduren. Deshalb bietet es sich an,
|
|
diese mit GLAS zusammenzufügen.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 29, Hexblock 1d
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 30, Hexblock 1e
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 31, Hexblock 1f
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 32, Hexblock 20
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|