mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-07-26 16:28:59 +00:00
172 lines
3.0 KiB
Forth
172 lines
3.0 KiB
Forth
|
|
\ *** 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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|