VolksForth/sources/generic/case/craps.fb

***************** CRAPS *****************************jrg 06okt88nach 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<65>lltenGl„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                                                                           \ 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<47>ckwunsch  cr ." Viel Gl<47>ck beim n„chsten Wurf ... " ;                                                                      cr .( Spr<70>che 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 Plausibilit„tspr<70>fung            \  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  Gl<47>ckwunsch                                             ;                                                                                                                                                                                                                                                                                                                                                                                               \ ------------- 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 biáchen Sicherheit    3 case? IF  2  1- exit  ENDIF                                   5 case? IF  4  1- exit  ENDIF                                   1-  ;                               \ ein biáchen Justage                                                                                                                                                                                                                                                                   \  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 ;                                                                                                                                                                              \  Create: ; :Does>                                  jrg 05feb89                                                                Create: Auswertung                                                        nehmen                                                           links schieben                                                  rechts schieben                                                trinken ;                                                   :Does>                                                             richtig bewegen ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      \  Das vollst„ndige Programm                         jrg 05feb89                                                                : CRAPS                                                              cr  Anfrage cr                                                        input#                                                          Glas richtig bewegen                                      cr  Gl<47>ckwunsch                                            ;                                                                                                                               \ ausschlieálich als Datenstruktur                              : CRAPS                                                              cr  Anfrage cr                                                        input#                                                          Auswertung                                                cr  Gl<47>ckwunsch                                            ;                                                               \ #### 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 ;               \  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  Gl<47>ckwunsch                                            ;                                                                                                                                                                                                                                                                                                                                                                                                                                                               ************* 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.                                                                                                                                                                                                                                                                                                                                                           \\ 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 ;  \\ hilfreiche Prozeduren f<>r das kommende CASE                                                                                  =OR     pr<70>ft eine Zahl n2 auf Gleichheit mit einem Testwert n1         und verkn<6B>pft resultierende Ergebnis mit einem bereits          vorliegenden flag f1. Es werden das neue flag f2 und der        "alte" Testwert n1 <20>bergeben.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           \\ bedingte Verzweigung mit IF .. ELSE .. ENDIF                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                 \\ Die Definitionen f<>r 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- g<>ltig gewesen sein.                                                                                                                                                                                                                                                                                                                                                                 jrg 07okt88                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ Ui jui jui / Test f<>r ein CRAPS                                                                                                 : Test                                                              full page                                                       20 0 DO                                                               craps                                                          LOOP ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               \\ F<>r Datenobjekte sind Prozeduren notwendig                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   \\ Was sind denn die Datenobjekte ?                  jrg 07okt88                                                                GLAS    als Datenteil enth„lt nat<61>rlich 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 f<>r den Datenteil GLAS ent-         worfenen Zugriffsprozeduren. Deshalb bietet es sich an,         diese mit GLAS zusammenzuf<75>gen.