From 3d0bcfcecebc60b32eba9dedccca42bc58faad10 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 4 Jan 2021 10:51:00 +0100 Subject: [PATCH] CASE Implementations for VolksForth --- sources/generic/case/case.4th | 228 +++++++++++ sources/generic/case/case.fb | 1 + sources/generic/case/casepos.fb | 1 + sources/generic/case/casepos.fth | 285 ++++++++++++++ sources/generic/case/casetru.fb | 1 + sources/generic/case/casetru.fth | 266 +++++++++++++ sources/generic/case/craps.fb | 1 + sources/generic/case/craps.fth | 627 +++++++++++++++++++++++++++++++ sources/generic/case/eaker.fb | 1 + sources/generic/case/eaker.fth | 171 +++++++++ 10 files changed, 1582 insertions(+) create mode 100644 sources/generic/case/case.4th create mode 100644 sources/generic/case/case.fb create mode 100644 sources/generic/case/casepos.fb create mode 100644 sources/generic/case/casepos.fth create mode 100644 sources/generic/case/casetru.fb create mode 100644 sources/generic/case/casetru.fth create mode 100644 sources/generic/case/craps.fb create mode 100644 sources/generic/case/craps.fth create mode 100644 sources/generic/case/eaker.fb create mode 100644 sources/generic/case/eaker.fth diff --git a/sources/generic/case/case.4th b/sources/generic/case/case.4th new file mode 100644 index 0000000..e86340e --- /dev/null +++ b/sources/generic/case/case.4th @@ -0,0 +1,228 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + + + + + + + + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ 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. 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 + +\ leapyear? nach Wil Baden VD 2/87 S.42 jrg 30mai89 + +| : leapyear? ( year# -- f : true falls Jahr = Schaltjahr ) + CASE 400 mod 0= OF true BREAK + CASE 100 mod 0= OF false BREAK + CASE 4 mod 0= OF true BREAK + drop false ; + +\\ nach Kaiser, Grundlegende Elemente ... S.160, Birkhäuser + + : leapyear? ( year# -- f : true falls Jahr = Schaltjahr ) + dup 4 mod 0= ( y# f) + swap dup 100 mod 0<> ( f1 y# f2 ) + rot and ( y# f3 ) + swap 400 mod 0= or ; + + +\ *** Block No. 5, Hexblock 5 + +\ Monatsnamen jrg 30mai89 +| 1 Constant jan +| 2 Constant feb +| 3 Constant mär +| 4 Constant apr +| 5 Constant mai +| 6 Constant jun +| 7 Constant jul +| 8 Constant aug +| 9 Constant sep +| 10 Constant okt +| 11 Constant nov +| 12 Constant dez + +\\ +| Create months ," janfebmäraprmaijunjulaugsepoktnovdez" + +\ *** Block No. 6, Hexblock 6 + +\ Tage im Monat jrg 30mai89 + +: #days ( month# -- days-in-month ) + CASE jan = apr =or jun =or nov =or OF 30 BREAK + CASE feb = not OF 31 BREAK + drop leapyear? IF 29 ELSE 28 THEN ; + +: .all + 12 1+ 1 + DO cr + I . + I >months type ." hat " + I #days . ." Tage." + LOOP ; + + + +\ *** Block No. 7, Hexblock 7 + +% Schaltjahr ? jrg 30mai89 + +Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be- +zeichnet, werden zunächst die ohne Rest durch 4 teilbaren Jahre +durch + JAHR MOD 4 = 0 +erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch + + (JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0) + +"entfernt". +Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin- +zugefügt: + +((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0) + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + +% Schaltjahr ? jrg 30mai89 + +Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be- +zeichnet, werden zunächst die ohne Rest durch 4 teilbaren Jahre +durch + JAHR MOD 4 = 0 +erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch + + (JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0) + +"entfernt". +Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin- +zugefügt: + +((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0) + + +\ *** Block No. 10, Hexblock a + + + + + + + + + + + + + + + + + + +\ *** Block No. 11, Hexblock b + + + + + + + + + + + + + + + + + diff --git a/sources/generic/case/case.fb b/sources/generic/case/case.fb new file mode 100644 index 0000000..33b9c81 --- /dev/null +++ b/sources/generic/case/case.fb @@ -0,0 +1 @@ + \ 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 \ =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 ; \ leapyear? nach Wil Baden VD 2/87 S.42 jrg 30mai89 | : leapyear? ( year# -- f : true falls Jahr = Schaltjahr ) CASE 400 mod 0= OF true BREAK CASE 100 mod 0= OF false BREAK CASE 4 mod 0= OF true BREAK drop false ; \\ nach Kaiser, Grundlegende Elemente ... S.160, Birkhuser : leapyear? ( year# -- f : true falls Jahr = Schaltjahr ) dup 4 mod 0= ( y# f) swap dup 100 mod 0<> ( f1 y# f2 ) rot and ( y# f3 ) swap 400 mod 0= or ; \ Monatsnamen jrg 30mai89| 1 Constant jan | 2 Constant feb | 3 Constant mr | 4 Constant apr | 5 Constant mai | 6 Constant jun | 7 Constant jul | 8 Constant aug | 9 Constant sep | 10 Constant okt | 11 Constant nov | 12 Constant dez \\ | Create months ," janfebmraprmaijunjulaugsepoktnovdez" \ Tage im Monat jrg 30mai89 : #days ( month# -- days-in-month ) CASE jan = apr =or jun =or nov =or OF 30 BREAK CASE feb = not OF 31 BREAK drop leapyear? IF 29 ELSE 28 THEN ; : .all 12 1+ 1 DO cr I . I >months type ." hat " I #days . ." Tage." LOOP ; % Schaltjahr ? jrg 30mai89 Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be- zeichnet, werden zunchst die ohne Rest durch 4 teilbaren Jahre durch JAHR MOD 4 = 0 erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch (JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0) "entfernt". Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin- zugefgt: ((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0) % Schaltjahr ? jrg 30mai89 Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be- zeichnet, werden zunchst die ohne Rest durch 4 teilbaren Jahre durch JAHR MOD 4 = 0 erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch (JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0) "entfernt". Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin- zugefgt: ((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0) \ No newline at end of file diff --git a/sources/generic/case/casepos.fb b/sources/generic/case/casepos.fb new file mode 100644 index 0000000..52dc12b --- /dev/null +++ b/sources/generic/case/casepos.fb @@ -0,0 +1 @@ +***************** CRAPS *****************************jrg 06okt88nach Wil Baden Da es in Deutschland das Wrfelspiel CRAPS nicht gibt, habe ich diesem Begriff ein Wrfel- und Trinkspiel aus der Schulzeit unterlegt. Bei diesem Spiel steht in der Tischmitte ein Vorrat an geflltenGlsern. Danach soll ein Mitspieler abhngig von seinem Wurf entweder ein neues Glas aus der Tischmitte vor sich stellen oder eines seiner Glser seinem Nachbarn zur linken oder zur rechten zuschieben oder alle vor ihm stehenden Glser austrinken. Zuordnung: 1=nehmen, 2/3=links, 4/5=rechts, 6 trinken \ LoadScreen jrg 31dez89 \needs :Does> 2 load 8 load cr .( positionelles CASE geladen ) cr \ :Does> fr Create :Does> ... ;ks 25 aug 88jrg 31dez89 | : (does> here >r [compile] Does> ; : :Does> last @ 0= Abort" without reference" (does> current @ context ! hide 0 ] ; clear \\ : test cls 5 0 DO cr ." craps1 " I . ." mal" craps1 cr ." craps2 " I . ." mal" craps2 cr ." craps3 " I . ." mal" craps3 LOOP cr ." fertig." ; \ nehmen trinken links rechts schieben jrg 05feb89 : nehmen bright ." ein Glas nehmen" normal 2 spaces ; : trinken bright ." alle Glser austrinken" normal 2 spaces ; : links bright ." ein Glas nach LINKS" normal 2 spaces ; : rechts bright ." ein Glas nach RECHTS" normal 2 spaces ; : schieben ; : schimpfen invers ." Betrug! " normal ; : Anfrage cr ." Sollen Sie nehmen, trinken oder schieben? " cr ." Bitte Ihre Augenzahl und : " ; : Glckwunsch cr ." Viel Glck beim nchsten Wurf ... " ; cr .( Sprche geladen ) \ Zugriffs-Prozeduren fr Tabellen von Prozeduren jrg 05feb89 : bewegen ( adr n -- cfa ) 2* + perform ; : richtig ( n -- 0<= n <= 3 ) swap 1 max 6 min \ ein bichen Sicherheit 3 case? IF 2 1- exit ENDIF 5 case? IF 4 1- exit ENDIF 1- ; \ ein bichen Justage \ Dieses Wort lt zwar Werte < 1 und > 6 zu, justiert sie aber \ auf den Bereich zwischen 1 und 6 . \ Die mglichen Tabellen mit ] [ oder Create: jrg 05feb89\ traditionell: Create Glas ] nehmen links schieben rechts schieben trinken [ \ oder VOLKS4TH-gem : Create: Glas nehmen links schieben rechts schieben trinken ; \ Create: ; :Does> Auswertung.8 jrg 05feb89 Create: Auswertung.8 nehmen links schieben rechts schieben trinken ; :Does> richtig bewegen ; \ Das vollstndige Programm jrg 05feb89 : CRAPS1 cr Anfrage cr input# Glas richtig bewegen cr Glckwunsch ; \ ausschlielich als Datenstruktur : CRAPS2 cr Anfrage cr input# Auswertung cr Glckwunsch ; \ #### positional CASE def.words Case: Associative: jrg 05feb89: Case: ( -- ) Create: Does> ( pfa -- ) swap 2* + perform ; \ alternative Definition fr CASE: \ : Case: \ : Does> ( pfa -- ) swap 2* + perform ; : Associative: ( n -- ) Constant Does> ( n - index ) dup @ -rot \ out of range = maxIndex + 1 dup @ 0 DO 2+ 2dup @ = IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; \ CASE: in der Anwendung ( 9. Auswertung) jrg 05feb89 Case: handeln \ besteht aus : nehmen links links rechts rechts trinken schimpfen ; 6 Associative: auswerten 1 , 2 , 3 , 4 , 5 , 6 , \ Hier erzeugen MIN und MAX out of range Fehler maxIndex + 1 \ CASE: und Associative: jrg 05feb89 : CRAPS3 ( -- ) cr Anfrage cr input# auswerten handeln cr Glckwunsch ; \ No newline at end of file diff --git a/sources/generic/case/casepos.fth b/sources/generic/case/casepos.fth new file mode 100644 index 0000000..6760d3e --- /dev/null +++ b/sources/generic/case/casepos.fth @@ -0,0 +1,285 @@ + +\ *** 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 + +\ LoadScreen jrg 31dez89 + +\needs :Does> 2 load + + 8 load + cr .( positionelles CASE geladen ) cr + + + + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ :Does> für Create :Does> ... ;ks 25 aug 88jrg 31dez89 + +| : (does> here >r [compile] Does> ; + + : :Does> last @ 0= Abort" without reference" + (does> current @ context ! hide 0 ] ; + +clear +\\ +: test cls + 5 0 DO + cr ." craps1 " I . ." mal" craps1 + cr ." craps2 " I . ." mal" craps2 + cr ." craps3 " I . ." mal" craps3 + LOOP + cr ." fertig." ; + +\ *** Block No. 3, Hexblock 3 + +\ nehmen trinken links rechts schieben jrg 05feb89 + +: 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 ; +: schimpfen invers ." Betrug! " normal ; + +: Anfrage cr ." Sollen Sie nehmen, trinken oder schieben? " + cr ." Bitte Ihre Augenzahl und : " ; + +: Glückwunsch cr ." Viel Glück beim nächsten Wurf ... " ; + +cr .( Sprüche geladen ) + + +\ *** Block No. 4, Hexblock 4 + +\ Zugriffs-Prozeduren für Tabellen von 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 + + + +\ Dieses Wort läßt zwar Werte < 1 und > 6 zu, justiert sie aber +\ auf den Bereich zwischen 1 und 6 . + +\ *** Block No. 5, Hexblock 5 + +\ Die möglichen Tabellen mit ] [ oder Create: jrg 05feb89 +\ traditionell: + +Create Glas + ] nehmen links schieben + rechts schieben trinken [ + + +\ oder VOLKS4TH-gemäß : + +Create: Glas + nehmen + links schieben + rechts schieben + trinken ; + + +\ *** Block No. 6, Hexblock 6 + +\ Create: ; :Does> Auswertung.8 jrg 05feb89 + +Create: Auswertung.8 + nehmen + links schieben + rechts schieben + trinken ; + :Does> + richtig bewegen ; + + + + + + + + +\ *** Block No. 7, Hexblock 7 + +\ Das vollständige Programm jrg 05feb89 + +: CRAPS1 + cr Anfrage cr + input# + Glas richtig bewegen + cr Glückwunsch +; + +\ ausschließlich als Datenstruktur +: CRAPS2 + cr Anfrage cr + input# + Auswertung + cr Glückwunsch +; + +\ *** Block No. 8, Hexblock 8 + +\ #### positional CASE def.words Case: Associative: jrg 05feb89 +: Case: ( -- ) + Create: Does> ( pfa -- ) swap 2* + perform ; + +\ alternative Definition für CASE: +\ : Case: +\ : Does> ( pfa -- ) swap 2* + perform ; + + +: Associative: ( n -- ) + Constant Does> ( n - index ) + dup @ -rot \ out of range = maxIndex + 1 + dup @ 0 + DO 2+ 2dup @ = + IF 2drop drop I 0 0 LEAVE THEN + LOOP 2drop ; + +\ *** Block No. 9, Hexblock 9 + +\ CASE: in der Anwendung ( 9. Auswertung) jrg 05feb89 + Case: handeln \ besteht aus : + nehmen + links links + rechts rechts + trinken + schimpfen ; + +6 Associative: auswerten + + 1 , + 2 , 3 , + 4 , 5 , + 6 , + +\ Hier erzeugen MIN und MAX out of range Fehler maxIndex + 1 + +\ *** Block No. 10, Hexblock a + +\ CASE: und Associative: jrg 05feb89 + +: CRAPS3 ( -- ) + + cr Anfrage cr + input# + auswerten + handeln + cr Glückwunsch +; + + + + + + + +\ *** Block No. 11, Hexblock b + + + + + + + + + + + + + + + + + + +\ *** Block No. 12, Hexblock c + + + + + + + + + + + + + + + + + + +\ *** Block No. 13, Hexblock d + + + + + + + + + + + + + + + + + + +\ *** Block No. 14, Hexblock e + + + + + + + + + + + + + + + + + diff --git a/sources/generic/case/casetru.fb b/sources/generic/case/casetru.fb new file mode 100644 index 0000000..a3292d8 --- /dev/null +++ b/sources/generic/case/casetru.fb @@ -0,0 +1 @@ + \ F83-number? input# jrg 05feb89 : F83-number? ( string -- d f ) number? ?dup IF 0< IF extend ENDIF true exit THEN drop 0 0 false ; : input# ( -- n ) pad c/l 1- >expect pad F83-number? 2drop ; \ nehmen trinken links rechts schieben jrg 05feb89 : nehmen bright ." ein Glas nehmen" normal 2 spaces ; : trinken bright ." alle Glser austrinken" normal 2 spaces ; : links bright ." ein Glas nach LINKS" normal 2 spaces ; : rechts bright ." ein Glas nach RECHTS" normal 2 spaces ; : schieben ; : Anfrage cr ." Sollen Sie nehmen, trinken oder schieben? " cr ." Bitte Ihre Augenzahl und : " ; : Glckwunsch cr ." Viel Glck beim nchsten Wurf ... " ; cr .( Sprche geladen ) \ Auswertung.1 mit IF...ELSE...THEN jrg 05feb89 : Auswertung.1 ( Wurfergebnis --) dup 1 = IF nehmen ELSE dup 2 = IF links schieben ELSE dup 3 = IF links schieben ELSE dup 4 = IF rechts schieben ELSE dup 5 = IF rechts schieben ELSE dup 6 = IF trinken THEN THEN THEN THEN THEN THEN 1 6 between not IF invers ." Betrug!" normal ENDIF ; \ Auswertung.2 mit IF...THEN / ENDIF jrg 05feb89 ' THEN Alias ENDIF immediate restrict : Auswertung.2 ( Wurfergebnis --) 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 ; \ Auswertung.3 mit IF...ENDIF und CASE? jrg 05feb89 : Auswertung.3 ( Wurfergebnis --) 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 ; \ =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 ; \ Auswertung.4 mit IF...THEN und =or jrg 05feb89 : Auswertung.4 ( Wurfergebnis --) dup 1 6 between IF dup 1 = IF nehmen ENDIF dup 2 = 3 =or IF links schieben ENDIF dup 4 = 5 =or IF rechts schieben ENDIF dup 6 = IF trinken ENDIF ELSE invers ." Betrug!" normal ENDIF drop ; ****** Beginn der Kommentare ************************jrg 05feb89 jrg 03feb89 \\ So ist es schrecklich ! jrg 03feb89 \\ ENDIF und CASE? jrg 03feb89 ENDIF macht deutlich(er), warum FORTH ohne Verbundanweisung wie z.B. PASCAL auskommt. AUSWERTUNG fhrt entsprechend einem Selektor genau eine von 6 mglichen Prozeduren aus. jrg 03feb89 \\ =OR jrg 03feb89 =OR prft eine Zahl n2 auf Gleichheit mit einem Testwert n1 und verknpft resultierende Ergebnis mit einem bereits vorliegenden flag f1. Es werden das neue flag f2 und der "alte" Testwert n1 bergeben. \ No newline at end of file diff --git a/sources/generic/case/casetru.fth b/sources/generic/case/casetru.fth new file mode 100644 index 0000000..72d91d0 --- /dev/null +++ b/sources/generic/case/casetru.fth @@ -0,0 +1,266 @@ + +\ *** Block No. 0, Hexblock 0 + + + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ F83-number? input# jrg 05feb89 + + : F83-number? ( string -- d f ) + number? ?dup IF 0< IF extend ENDIF + true exit + THEN drop 0 0 false ; + + : input# ( -- n ) + pad c/l 1- >expect + pad F83-number? 2drop ; + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ nehmen trinken links rechts schieben jrg 05feb89 + +: 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 cr ." Sollen Sie nehmen, trinken oder schieben? " + cr ." Bitte Ihre Augenzahl und : " ; + +: Glückwunsch cr ." Viel Glück beim nächsten Wurf ... " ; + +cr .( Sprüche geladen ) + +\ *** Block No. 3, Hexblock 3 + +\ Auswertung.1 mit IF...ELSE...THEN jrg 05feb89 + +: Auswertung.1 ( Wurfergebnis --) + + dup 1 = IF nehmen ELSE + dup 2 = IF links schieben ELSE + dup 3 = IF links schieben ELSE + dup 4 = IF rechts schieben ELSE + dup 5 = IF rechts schieben ELSE + dup 6 = IF trinken THEN + THEN + THEN + THEN + THEN + THEN + 1 6 between not IF invers ." Betrug!" normal ENDIF ; + +\ *** Block No. 4, Hexblock 4 + +\ Auswertung.2 mit IF...THEN / ENDIF jrg 05feb89 + +' THEN Alias ENDIF immediate restrict + +: Auswertung.2 ( Wurfergebnis --) + + 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. 5, Hexblock 5 + +\ Auswertung.3 mit IF...ENDIF und CASE? jrg 05feb89 + +: Auswertung.3 ( Wurfergebnis --) + + 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. 6, Hexblock 6 + +\ =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. 7, Hexblock 7 + +\ Auswertung.4 mit IF...THEN und =or jrg 05feb89 + +: Auswertung.4 ( Wurfergebnis --) + dup + 1 6 between IF + dup 1 = IF nehmen ENDIF + dup 2 = 3 =or IF links schieben ENDIF + dup 4 = 5 =or IF rechts schieben ENDIF + dup 6 = IF trinken ENDIF + ELSE + invers ." Betrug!" normal + ENDIF + drop +; + + + +\ *** Block No. 8, Hexblock 8 + +****** Beginn der Kommentare ************************jrg 05feb89 + + + + + + + + + + + + + + + + +\ *** Block No. 9, Hexblock 9 + + jrg 03feb89 + + + + + + + + + + + + + + + + +\ *** Block No. 10, Hexblock a + +\\ So ist es schrecklich ! jrg 03feb89 + + + + + + + + + + + + + + + + +\ *** Block No. 11, Hexblock b + +\\ ENDIF und CASE? jrg 03feb89 + +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. + + + + + + + + + + + +\ *** Block No. 12, Hexblock c + + jrg 03feb89 + + + + + + + + + + + + + + + + +\ *** Block No. 13, Hexblock d + +\\ =OR jrg 03feb89 + +=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. + + + + + + + + + + diff --git a/sources/generic/case/craps.fb b/sources/generic/case/craps.fb new file mode 100644 index 0000000..36b8c11 --- /dev/null +++ b/sources/generic/case/craps.fb @@ -0,0 +1 @@ +***************** CRAPS *****************************jrg 06okt88nach Wil Baden Da es in Deutschland das Wrfelspiel CRAPS nicht gibt, habe ich diesem Begriff ein Wrfel- und Trinkspiel aus der Schulzeit unterlegt. Bei diesem Spiel steht in der Tischmitte ein Vorrat an geflltenGlsern. Danach soll ein Mitspieler abhngig von seinem Wurf entweder ein neues Glas aus der Tischmitte vor sich stellen oder eines seiner Glser seinem Nachbarn zur linken oder zur rechten zuschieben oder alle vor ihm stehenden Glser austrinken. Zuordnung: 1=nehmen, 2/3=links, 4/5=rechts, 6 trinken \ nehmen trinken links rechts schieben jrg 03feb89 : nehmen bright ." ein Glas nehmen" normal 2 spaces ; : trinken bright ." alle Glser 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 : " ; : Glckwunsch cr ." Viel Glck beim nchsten Wurf ... " ; cr .( Sprche geladen ) \ 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 ; \ =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 ; \ 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 ; \ 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 \ 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 Plausibilittsprfung \ 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 ; \ Das CRAPS Programm wie in PASCAL etc. jrg 07okt88 : CRAPS cr Anfrage cr input# Auswertung cr Glckwunsch ; \ ------------- VECTOR EXECUTION --------------------jrg 07okt88 \ 4TH braucht Prozeduren jrg 05feb89 : bewegen ( adr n -- cfa ) 2* + perform ; : richtig ( n -- 0<= n <= 3 ) swap 1 max 6 min \ ein bichen Sicherheit 3 case? IF 2 1- exit ENDIF 5 case? IF 4 1- exit ENDIF 1- ; \ ein bichen Justage \ Die mglichen Bewegungen mit ] [ oder Create: jrg 05feb89 Create Glas ] nehmen links schieben rechts schieben trinken [ \ oder: Create: Glas nehmen links schieben rechts schieben trinken ; \ Create: ; :Does> jrg 05feb89 Create: Auswertung nehmen links schieben rechts schieben trinken ; :Does> richtig bewegen ; \ Das vollstndige Programm jrg 05feb89 : CRAPS cr Anfrage cr input# Glas richtig bewegen cr Glckwunsch ; \ ausschlielich als Datenstruktur : CRAPS cr Anfrage cr input# Auswertung cr Glckwunsch ; \ #### 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 fr CASE: : Case: : Does> ( pfa -- ) swap 2* + perform ; \ 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 , \ CASE: und Associative: jrg 01feb89 : CRAPS ( -- ) cr Anfrage cr input# auswerten bewegen cr Glckwunsch ; ************* Beginn der Kommentare *****************jrg 07okt88 SCHIEBEN gefllt mir deshalb so gut, weil es vorher nur als Fllsel arbeitet, aber hinterher als Dummy in der Tabelle die wichtige Funktion hat, sechs mgliche Wrfe sauber abzuarbeiten. \\ Auswertung mit IF...THEN / ENDIF jrg 01feb89 ENDIF macht deutlich(er), warum FORTH ohne Verbundanweisung wie z.B. PASCAL auskommt. AUSWERTUNG fhrt entsprechend einem Selektor genau eine von 6 mglichen Prozeduren aus. Auch eine mgliche 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 ; \\ hilfreiche Prozeduren fr das kommende CASE =OR prft eine Zahl n2 auf Gleichheit mit einem Testwert n1 und verknpft resultierende Ergebnis mit einem bereits vorliegenden flag f1. Es werden das neue flag f2 und der "alte" Testwert n1 bergeben. \\ bedingte Verzweigung mit IF .. ELSE .. ENDIF \\ Die Definitionen fr die CASE Anweisung jrg 07okt88 BREAK ist ein EXIT aus der CASE-Anweisung; return to caller \\ Auswertung mit CASE OF ENDOF Sicherheit gegen falsche Zahlen \\ Die elegantere Auswertung mit BREAK jrg 07okt88 BREAK = Verlassen des Callee Wird trotz BREAK dieser Prozedurteil erreicht, mu die Zahl un- gltig gewesen sein. jrg 07okt88 \ Ui jui jui / Test fr ein CRAPS : Test full page 20 0 DO craps LOOP ; \\ Fr Datenobjekte sind Prozeduren notwendig \\ Was sind denn die Datenobjekte ? jrg 07okt88 GLAS als Datenteil enthlt natrlich die in Frage kommenden Prozeduren. GLAS ist der gleiche Datenteil wie oben, nur eleganter. \\ Zusammenfassen des Datenteils und des Zugriffsteiljrg 07okt88 RICHTIG und BEWEGEN sind die eigens fr den Datenteil GLAS ent- worfenen Zugriffsprozeduren. Deshalb bietet es sich an, diese mit GLAS zusammenzufgen. \ No newline at end of file diff --git a/sources/generic/case/craps.fth b/sources/generic/case/craps.fth new file mode 100644 index 0000000..a6eef01 --- /dev/null +++ b/sources/generic/case/craps.fth @@ -0,0 +1,627 @@ + +\ *** 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 : " ; + +: 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 + + + + + + + + + + + + + + + + + diff --git a/sources/generic/case/eaker.fb b/sources/generic/case/eaker.fb new file mode 100644 index 0000000..ff775cd --- /dev/null +++ b/sources/generic/case/eaker.fb @@ -0,0 +1 @@ +* EAKER - CASE fr volks4th83 von Heinz Schnitter **jrg 01feb89 \ Vorwrtsreferenzen als verkettete Liste ( 06.jrg 01feb89| variable caselist | : initlist ( list -- addr ) dup @ swap off ; | : >marklist ( list -- ) here over @ , swap ! ; | : >resolvelist ( addr list -- ) BEGIN dup @ WHILE dup dup @ dup @ rot ! >resolve REPEAT ! ; \ CASE ELSECASE ENDCASE ( 09.jrg 01feb89 : CASE caselist initlist 4 ; immediate restrict : ELSECASE 4 ?pairs compile drop 6 ; immediate restrict : ENDCASE dup 4 = IF drop compile drop ELSE 6 ?pairs THEN caselist >resolvelist ; immediate restrict \ OF ENDOF Control ( 09.jrg 01feb89: OF 4 ?pairs compile over compile = compile ?branch >mark compile drop 5 ; immediate restrict : ENDOF 5 ?pairs compile branch caselist >marklist >resolve 4 ; immediate restrict : Control bl word 1+ c@ $bf and state @ IF [compile] Literal THEN ; immediate \ Test ( 09.jrg 01feb89: test ." exit mit ctrl x" cr BEGIN key CASE control A OF ." action ^a " cr false ENDOF control B OF ." action ^b " cr false ENDOF control C OF ." action ^c " cr false ENDOF control D OF ." action ^d " cr false ENDOF control X OF ." exit " true ENDOF ELSECASE ." befehl unbekannt " cr false ENDCASE UNTIL ; \ nehmen trinken links rechts schieben jrg 01feb89 : nehmen bright ." ein Glas nehmen" normal 2 spaces ; : trinken bright ." alle Glser 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 : " ; : Glckwunsch ." Viel Glck beim nchsten Wurf ... " ; cr .( Sprche geladen ) \ Auswerten mit CASE OF ENDOF END-CASE jrg 01feb89 : Auswertung ( 1<= n <=6 -- ) CASE 1 OF nehmen ENDOF 6 OF trinken ENDOF 4 OF links ENDOF 5 OF links ENDOF 2 OF rechts ENDOF 3 OF rechts ENDOF ELSECASE ." Betrug! " ENDCASE ; \ Das CRAPS Programm wie in PASCAL etc. jrg 07okt88 : CRAPS cr Anfrage cr input# Auswertung cr Glckwunsch ; \ No newline at end of file diff --git a/sources/generic/case/eaker.fth b/sources/generic/case/eaker.fth new file mode 100644 index 0000000..1c95e86 --- /dev/null +++ b/sources/generic/case/eaker.fth @@ -0,0 +1,171 @@ + +\ *** Block No. 0, Hexblock 0 + +* EAKER - CASE für volks4th83 von Heinz Schnitter **jrg 01feb89 + + + + + + + + + + + + + + + + +\ *** Block No. 1, Hexblock 1 + +\ Vorwärtsreferenzen als verkettete Liste ( 06.jrg 01feb89 +| variable caselist + +| : initlist ( list -- addr ) + dup @ swap off + ; + +| : >marklist ( list -- ) + here over @ , swap ! + ; + +| : >resolvelist ( addr list -- ) + BEGIN dup @ + WHILE dup dup @ dup @ rot ! >resolve + REPEAT ! + ; + +\ *** Block No. 2, Hexblock 2 + +\ CASE ELSECASE ENDCASE ( 09.jrg 01feb89 + +: CASE caselist initlist 4 +; immediate restrict + + +: ELSECASE 4 ?pairs + compile drop 6 +; immediate restrict + + +: ENDCASE dup 4 = + IF drop compile drop + ELSE 6 ?pairs + THEN caselist >resolvelist +; immediate restrict + +\ *** Block No. 3, Hexblock 3 + +\ OF ENDOF Control ( 09.jrg 01feb89 +: OF 4 ?pairs + compile over + compile = + compile ?branch + >mark compile drop 5 +; immediate restrict + +: ENDOF 5 ?pairs + compile branch + caselist >marklist + >resolve 4 +; immediate restrict + +: Control bl word 1+ c@ $bf and state @ + IF [compile] Literal THEN ; immediate + +\ *** Block No. 4, Hexblock 4 + +\ Test ( 09.jrg 01feb89 +: test + ." exit mit ctrl x" cr + BEGIN key + CASE control A OF ." action ^a " cr false ENDOF + control B OF ." action ^b " cr false ENDOF + control C OF ." action ^c " cr false ENDOF + control D OF ." action ^d " cr false ENDOF + control X OF ." exit " true ENDOF + ELSECASE + ." befehl unbekannt " cr false + ENDCASE + UNTIL +; + + + +\ *** Block No. 5, Hexblock 5 + +\ nehmen trinken links rechts schieben jrg 01feb89 + +: 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 : " ; + +: Glückwunsch ." Viel Glück beim nächsten Wurf ... " ; + +cr .( Sprüche geladen ) + +\ *** Block No. 6, Hexblock 6 + +\ Auswerten mit CASE OF ENDOF END-CASE jrg 01feb89 + +: Auswertung ( 1<= n <=6 -- ) + + CASE 1 OF nehmen ENDOF + 6 OF trinken ENDOF + 4 OF links ENDOF + 5 OF links ENDOF + 2 OF rechts ENDOF + 3 OF rechts ENDOF + ELSECASE + ." Betrug! " + ENDCASE +; + + + +\ *** Block No. 7, Hexblock 7 + +\ Das CRAPS Programm wie in PASCAL etc. jrg 07okt88 + +: CRAPS + + cr Anfrage cr + + input# + Auswertung + + cr Glückwunsch +; + + + + + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + +