CASE Implementations for VolksForth

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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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 <name> :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 <cr> : "   ;
+
+: 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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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#   ( <string> -- 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 <cr> : "   ;
+
+: 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.
+
+
+
+
+
+
+
+
+
+

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 <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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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 <cr> : "   ;
+
+: 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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+