From 072e03569bc60adea3e74e78d834706f04680998 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 4 Jan 2021 10:45:08 +0100 Subject: [PATCH 1/2] Alternative implemenatations/updates of the MS-DOS editor --- msdos/cursor/ced.fb | 1 + msdos/cursor/cursor.txt | 27 ++ msdos/cursor/editor.fb | 1 + sources/msdos/cursor/ced.fth | 171 +++++++ sources/msdos/cursor/editor.fth | 798 ++++++++++++++++++++++++++++++++ 5 files changed, 998 insertions(+) create mode 100644 msdos/cursor/ced.fb create mode 100644 msdos/cursor/cursor.txt create mode 100644 msdos/cursor/editor.fb create mode 100644 sources/msdos/cursor/ced.fth create mode 100644 sources/msdos/cursor/editor.fth diff --git a/msdos/cursor/ced.fb b/msdos/cursor/ced.fb new file mode 100644 index 0000000..96bad38 --- /dev/null +++ b/msdos/cursor/ced.fb @@ -0,0 +1 @@ +\ Commandline EDitor fr volksFORTH rev. 3.80 UH 05feb89Dieses File enthaelt Definitionen, die es ermglichen die Kommandozeile zu editieren. Es gibt eine Commandline History, die es ermglicht alte Eingaben wiederzuholen. Diese werden zyklisch auf Screen 0 im File History gesichert und bleiben so auch ber ein SAVESYSTEM erhalten. Tasten: Cursor links/rechts   Zeichen lschen und <- Zeile lschen Einfgen an aus Zeile abschlieen Anfang/Ende der Zeile alte Zeilen wiederholen   \ Commandline EDitor LOAD-Screen UH 20Nov87 jrg 14mr89 : curleft ( -- ) at? 1- at ; : currite ( -- ) at? 1+ at ; 1 5 +thru \ Erweiterte Eingabe .( Kommandozeilen Editor geladen ) cr \ History -- Kommandogeschichte jrg 14mr89makefile history 1 more | Variable line# line# off | Variable lastline# lastline# off | : 'history ( n -- addr ) pushfile history c/l * b/blk /mod block + ; | : @line ( n -- addr len ) 'history c/l -trailing ; | : !history ( addr line# -- ) 'history dup c/l blank span @ c/l min cmove update ; | : @history ( addr line# -- ) @line rot swap dup span ! cmove ; | : +line ( n addr -- ) dup @ rot + l/s mod swap ! ; \ Ende der Eingabe jrg 18dez89 | Variable maxchars | Variable cinsert cinsert on | : -text ( a1 a2 l -- 0=equal ) bounds ?DO count I c@ - ?dup IF nip ENDLOOP exit THEN LOOP 0= ; | : done ( a p1 -- a p2 ) 2dup at? rot - span @ dup maxchars ! + at space blankline line# @ @line span @ = IF span @ -text 0=exit 2dup THEN drop lastline# @ !history 1 lastline# +line ; \ Erweiterte Eingabe UH 08OCt87 jrg 19dez89 : redisplay ( addr pos -- ) at? 2swap span @ swap /string type blankline at ; | : del ( addr pos -- ) span @ 0=exit dup >r + dup 1+ swap span @ r> - cmove -1 span +! ; | : ins ( addr pos1 -- ) dup >r + dup dup 1+ span @ r> - cmove> bl swap c! 1 span +! ; | : delete ( a p1 -- a p2 ) 2dup del 2dup redisplay ; | : back ( a p1 -- a p2 ) 1- curleft delete ; | : recall ( a p1 -- a p2 ) at? rot - at dup line# @ @history dup 0 redisplay at? span @ + at span @ ; | : r cinsert @ IF 2dup ins THEN 2dup + r> swap c! 1+ dup span @ max span ! 2dup redisplay ; \ Patch UH 08Oct87 jrg 19dez89 : showcur ( -- ) curshape? swap drop \ bot top cinsert @ IF dup 2/ \ top = bot/2 ELSE dup 1- THEN swap curshape ; : (expect ( addr len -- ) maxchars ! span off lastline# @ line# ! 0 BEGIN span @ maxchars @ u< WHILE key decode showcur REPEAT 2drop ; ' (decode ' keyboard 6 + ! ' (expect ' keyboard 8 + ! \ No newline at end of file diff --git a/msdos/cursor/cursor.txt b/msdos/cursor/cursor.txt new file mode 100644 index 0000000..03c7768 --- /dev/null +++ b/msdos/cursor/cursor.txt @@ -0,0 +1,27 @@ +Im volksFORTH rev.3.81.41 treten, bedingt durch die Vielfalt an +Grafik-Karten fr den PC, unter Umstnden Probleme mit dem CURSOR +auf. Denn in dem meisten PCs verrichtet eine Hercules-Karte ihre +Dienste, auf die einige Worte im EDITOR und im Kommando-zeilen- +Editor CED zugeschnitten sind. +Die Worte CURON und CUROFF bestimmen das Erscheinungsbild des +Cursors durch Zahlenwerte fr CURSHAPE, die grafikkartenabhngig +sind. Hier bietet sich eine nderung mit Hilfe des Video- +Interrupts INT$10 an, dessen Funktion $3 im C-Register die +aktuelle Start- und End-Zeile des Cursors wiedergibt. Als +Warnung: Im Zuge meiner amateurhaften Versuche zur +Interruptprogrammierung hat, nach ungesichertem R-Register, ein V +(aktuellen Screen editieren) dafr gesorgt, da meine gesamte +freie Festplattenkapazitt der Datei EDITOR.SCR zugeschlagen +wurde. +Mit den neuen Varianten von CURON/OFF mten auch EGA und andere +Karten einen Cursor auf dem Schirm anzeigen. Mit dem +Kommandozeilen-Editor CED hngt auch das zweite Problem zusammen: +Wie man in SHOWCUR sieht, wird der Einfge- oder berschreibmodus +durch das Erscheinungsbild des Cursors verdeutlicht. Da liegt es +auf der Hand, da in (EXPECT die Wortfolge KEY DECODE SHOWCUR +nach jeder Zeicheneingabe das Aussehen des Cursor in Abhngigkeit +vom jeweiligen Modus festlegt und ein etwaiges ( top bot) CURSHAPE +unwirksam machen. Soll dem nicht so sein, knnte man eventuell +die jetzt gelschte Cursor-Anfangszeile in einem der beiden Modi +INS/OVER beibehalten. + \ No newline at end of file diff --git a/msdos/cursor/editor.fb b/msdos/cursor/editor.fb new file mode 100644 index 0000000..9c9387b --- /dev/null +++ b/msdos/cursor/editor.fb @@ -0,0 +1 @@ + volksFORTH Full-Screen-Editor HELP Screen Editor verlassen : flushed: ESC updated: ^E nderungen verwerfen: ^U (UNDO) Cursor bewegen : Cursortasten (lschen mit DEL oder <- ) Einfgen : INS (an/aus), ^ENTER (Screen einfgen) Tabs : TAB (nach rechts), SHIFT TAB (nach links) Blttern : Pg Dn (nchster), Pg Up (voriger) : F9 (alternate), SHIFT F9 (shadow) mark alternate Scr. : F10 Zeile lschen/einf. : ^Y (lschen), ^N (einfgen) Zeile teilen : ^PgDn (split), ^PgUp (join) Suchen und Ersetzen : F2 (Break mit ESC, replace mit 'R' ) Zeilenpuffer : F3 (push&delete), F5 (push), F7 (pop) Zeichenpuffer : F4 (push&delete), F6 (push), F8 (pop) Sonstige : ^F (Fix), ^L (Showload), ^S (Screen #) --> \ Full-Screen Editor ks 22 dez 87 Dieses File enthaelt den Full-Screen Editor fuer die IBM - volksFORTH-Version. Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- Funktion und des sichtbaren Laden von Screens (showload). Durch die integrierte Tastaturtabelle (keytable) laesst sich dieKommandobelegung der Tasten auf einfache Art und Weise aendern. Angepat fr den IBM PC von K.Schleisiek am 22 dez 87 Anregungen, Kritik und Verbesserungsvorschlaege bitte an: U. Hoffmann Harmsstrasse 71 2300 Kiel \ Load Screen for the Editor jrg 18dez89 Onlyforth \needs Assembler 2 loadfrom asm.scr 3 load \ PC adaption \ &10 load \ ANSI display interface \ &11 load \ BIOS display interface \ &12 load \ MULTItasking display interface &4 &40 thru \ Editor Onlyforth .( Screen Editor geladen) cr \ curshape? curon curoff jrg 20dez89\ gleiches Konzept wie curat? , nur C nach D geschoben \ da C die Cursor-Start & -End-Reihe enthlt Code curshape? ( -- top bot ) D push R push $F # A+ mov $10 int \ in AL der Videomodus !! 3 # A+ mov $10 int R pop C D mov 0 # A mov D+ A- xchg A push Next end-code : curon curshape? curshape ; \ VGA hat max. 15 Reihen! : curoff &16 dup curshape ; \ BIM adaption jrg 18dez89| : ?range ( n -- n ) isfile@ 0=exit ( n) dup 0< 9 and ?diskerror dup capacity - 1+ 0 max ?dup 0=exit more ; | : block ( n -- adr ) ?range block ; $1B Constant #esc Variable caps caps off Label ?capital 1 # caps #) byte test 0= ?[ (capital # jmp ]? ret end-code \ search delete insert replace ks 20 dez 87 | : delete ( buffer size count -- ) over min >r r@ - ( left over ) dup 0> IF 2dup swap dup r@ + -rot swap cmove THEN + r> bl fill ; | : insert ( string length buffer size -- ) rot over min >r r@ - ( left over ) over dup r@ + rot cmove> r> cmove ; | : replace ( string length buffer size -- ) rot min cmove ; \ usefull definitions and Editor vocabulary UH 11mai88 Vocabulary Editor ' Forth | Alias [F] immediate ' Editor | Alias [E] immediate Editor also definitions | : c ( n --) \ moves cyclic thru the screen r# @ + b/blk mod r# ! ; | Variable r#' r#' off | Variable scr' scr' off ' fromfile | Alias isfile' | Variable lastfile | Variable lastscr | Variable lastr# \\ move cursor with position-checking ks 18 dez 87 \ different versions of cursor positioning error reporting | : c ( n --) \ checks the cursor position r# @ + dup 0 b/blk uwithin not Abort" There is a border!" r# ! ; | : c ( n --) \ goes thru the screens r# @ + dup b/blk 1- > IF 1 scr +! THEN dup 0< IF -1 scr +! THEN b/blk mod r# ! ; | : c ( n --) \ moves cyclic thru the screen r# @ + b/blk mod r# ! ; \ calculate addresses ks 20 dez 87 | : *line ( l -- adr ) c/l * ; | : /line ( n -- c l ) c/l /mod ; | : top ( -- ) r# off ; | : cursor ( -- n ) r# @ ; | : 'start ( -- adr ) scr @ block ; | : 'end ( -- adr ) 'start b/blk + ; | : 'cursor ( -- adr ) 'start cursor + ; | : position ( -- c l ) cursor /line ; | : line# ( -- l ) position nip ; | : col# ( -- c ) position drop ; | : 'line ( -- adr ) 'start line# *line + ; | : 'line-end ( -- adr ) 'line c/l + 1- ; | : #after ( -- n ) c/l col# - ; | : #remaining ( -- n ) b/blk cursor - ; | : #end ( -- n ) b/blk line# *line - ; \ move cursor directed UH 11dez88| Create >at 0 , 0 , | : curup c/l negate c ; | : curdown c/l c ; | : curleft -1 c ; | : curright 1 c ; | : +tab ( 1/4 -> ) cursor $10 / 1+ $10 * cursor - c ; | : -tab ( 1/8 <- ) cursor 8 mod negate dup 0= 8 * + c ; | : >last ( adr len -- ) -trailing nip b/blk min r# ! ; | : #after c ; | : ( -- ) 'start line# 1+ *line 1- >last ; | : >""end ( -- ) 'start b/blk >last ; \ show border UH 29Sep87 &14 | Constant dx 1 | Constant dy | : horizontal ( row eck1 eck2 -- row' ) rot dup >r dx 1- at swap emit c/l 0 DO Ascii emit LOOP emit r> 1+ ; | : vertical ( row -- row' ) l/s 0 DO dup dx 1- at Ascii emit row dx c/l + at Ascii emit 1+ LOOP ; | : border dy 1- Ascii Ascii horizontal vertical Ascii Ascii horizontal drop ; | : edit-at ( -- ) position swap dy dx d+ at ; \\ ANSI display interface ksjrg 18dez89 | : redisplay ( line# -- ) dup dy + dx at *line 'start + c/l type ; | : (done ( -- ) ; immediate | : install-screen ( -- ) l/s 6 + 0 >at 2! page ; \\ BIOS-display interface ksjrg 18dez89| Code (.line ( line addr videoseg -- ) A pop W pop I push E: push D E: mov $0E # W add W W add A I xchg c/l # C mov attribut #) A+ mov [[ byte lods stos C0= ?] E: pop I pop D pop Next end-code | : redisplay ( line# -- ) dup 1+ c/row * swap c/l * 'start + video@ (.line ; | : (done ( -- ) ; immediate | : install-screen ( -- ) l/s 6 + 0 >at 2! page ; \ MULTI-display interface ks UH 10Sep87| Code (.line ( line addr videoseg -- ) C pop W pop I push E: push D E: mov $0E # W add W W add u' area U D) I mov u' catt I D) A+ mov C I mov c/l # C mov [[ byte lods stos C0= ?] E: pop I pop D pop Next end-code | : redisplay ( line# -- ) dup 1+ c/row * swap c/l * 'start + video@ (.line ; | : (done ( -- ) line# 2+ c/col 2- window ; | : cleartop ( -- ) 0 l/s 5 + window (page ; | : install-screen ( -- ) row l/s 6 + u< IF l/s 6 + 0 full page ELSE at? cleartop THEN >at 2! ; \ display screen jrg 18dez89Forth definitions : updated? ( -- f) 'start 2- @ 0< ; Editor definitions | : .updated ( -- ) 9 0 at updated? IF 4 spaces ELSE ." not " THEN ." updated" ; | : .screen l/s 0 DO I redisplay LOOP ; \ | : .file ( fcb -- ) \ ?dup IF body> >name .name exit THEN ." direct" ; | : .title [ DOS ] 1 0 at isfile@ invers .file normal dx 1- tab 2 0 at drv (.drv scr @ 6 .r 4 0 at fromfile @ underline .file normal dx 1- tab 5 0 at fswap drv (.drv scr' @ 6 .r fswap .updated ; | : .all .title .screen ; \ check errors UH 02Nov86 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip Abort" You would lose a line" ; | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > IF line# redisplay true Abort" You would lose a char" THEN ; | : ?end 1 ?fit ; \ programmer's id ks jrg 24nov89 $12 | Constant id-len Create id id-len allot id id-len erase | : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; | : ?stamp ( -- ) updated? IF stamp THEN ; | : ## ( n -- ) base push decimal 0 <# # # #> id 1+ attach ; | : get-id ( -- ) id c@ ?exit ID on cr ." Enter your ID : " at? 3 0 DO Ascii . emit LOOP at id 2+ 3 expect span @ dup id 1+ c! 0=exit bl id 1+ append date@ rot ## swap >months id 1+ attach ## ; \ update screen-display UH 28Aug87 | : emptybuf prev @ 2+ dup on 4+ off ; | : undo emptybuf .all ; | : modified updated? ?exit update .updated ; | : linemodified modified line# redisplay ; | : screenmodified modified l/s line# ?DO I redisplay LOOP ; | : .modified ( -- ) >at 2@ at space scr @ . updated? not IF ." un" THEN ." modified" ?stamp ; \ leave editor jrg 04jul88| Variable (pad (pad off | : memtop ( -- adr) sp@ $100 - ; | Create char 1 allot | Variable imode imode off | : .imode at? 7 0 at imode @ IF ." insert " ELSE bright ." overwrite" normal THEN at ; | : setimode imode on .imode ; | : clrimode imode off .imode ; | : done ( -- ) (done ['] (quit is 'quit ['] (error errorhandler ! quit ; | : update-exit ( -- ) .modified done ; | : flushed-exit ( -- ) .modified save-buffers done ; \ handle screens UH 21jan89 | : insert-screen ( scr -- ) \ before scr 1 more fromfile push isfile@ fromfile ! capacity 2- over 1+ convey ; | : wipe-screen ( -- ) 'start b/blk blank ; | : new-screen ( -- ) scr @ insert-screen wipe-screen top screenmodified ; \ handle lines UH 01Nov86 | : (clear-line 'line c/l blank ; | : clear-line (clear-line linemodified ; | : clear> 'cursor #after blank linemodified ; | : delete-line 'line #end c/l delete screenmodified ; | : backline curup delete-line ; | : (insert-line ?bottom 'line c/l over #end insert (clear-line ; | : insert-line (insert-line screenmodified ; \ join and split lines UH 11dez88 | : insert-spaces ( n -- ) 'cursor swap 2dup over #remaining insert blank ; | : split ( -- ) ?bottom cursor col# insert-spaces r# ! #after insert-spaces screenmodified ; | : delete-characters ( n -- ) 'cursor #remaining rot delete ; | : join ( -- ) cursor line> col# Abort" next line will not fit!" #after + dup delete-characters cursor c/l rot - dup 0< IF negate insert-spaces ELSE delete-characters THEN r# ! screenmodified ; \ handle characters UH 01Nov86 | : delete-char 'cursor #after 1 delete linemodified ; | : backspace curleft delete-char ; | : (insert-char ?end 'cursor 1 over #after insert ; | : insert-char (insert-char bl 'cursor c! linemodified ; | : putchar ( --) char c@ imode @ IF (insert-char THEN 'cursor c! linemodified curright ; \ stack lines UH 31Oct86 | Create lines 4 allot \ { 2+pointer | 2base } | : 'lines ( -- adr) lines 2@ + ; | : @line 'lines memtop u> Abort" line buffer full" 'line 'lines c/l cmove c/l lines +! ; | : copyline @line curdown ; | : line>buf @line delete-line ; | : !line c/l negate lines +! 'lines 'line c/l cmove ; | : buf>line lines @ 0= Abort" line buffer empty" ?bottom (insert-line !line screenmodified ; \ stack characters UH 01Nov86 | Create chars 4 allot \ { 2+pointer | 2base } | : 'chars ( -- adr) chars 2@ + ; | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" 'cursor c@ 'chars c! 1 chars +! ; | : copychar @char curright ; | : char>buf @char delete-char ; | : !char -1 chars +! 'chars c@ 'cursor c! ; | : buf>char chars @ 0= Abort" char buffer empty" ?end (insert-char !char linemodified ; \ switch screens UH 11mai88 | : imprint ( -- ) \ remember valid file isfile@ lastfile ! scr @ lastscr ! r# @ lastr# ! ; | : remember ( -- ) lastfile @ isfile ! lastscr @ scr ! lastr# @ r# ! ; | : associate \ switch to alternate screen isfile' @ isfile@ isfile' ! isfile ! scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .all ; | : n ?stamp 1 scr +! .all ; | : b ?stamp -1 scr +! .all ; | : a ?stamp associate .all ; \ shadow screens UH 03Nov86 Variable shadow shadow off | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; | : >shadow ?stamp \ switch to shadow screen (shadow dup scr @ u> not IF negate THEN scr +! .all ; \ load and show screens ks 02 mr 88 | : showoff ['] exit 'name ! normal ; | : show ( -- ) blk @ 0= IF showoff exit THEN >in @ 1- r# ! edit-at imprint blk @ scr @ - 0=exit blk @ scr ! normal curoff .all invers curon ; | : showload ( -- ) ?stamp save-buffers ['] show 'name ! curon invers adr .status push ['] noop is .status scr @ scr push scr off r# push r# @ (load showoff ; \ find strings ks 20 dez 87 | Variable insert-buffer | Variable find-buffer | : 'insert ( -- addr ) insert-buffer @ ; | : 'find ( -- addr ) find-buffer @ ; | : .buf ( addr -- ) count type ." " &80 col - spaces ; | : get ( addr -- ) >r at? r@ .buf 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN at r> .buf ; | : get-buffers dy l/s + 2+ dx 1- 2dup at ." find: " 'find get swap 1+ swap 2- at ." ? replace: " 'insert get ; \ ks 20 dez 87 Code match ( addr1 len1 string -- addr2 len2 ) D W mov W ) D- mov $FF # D and 0= ?[ D pop Next ]? W inc D dec C pop I A mov I pop A push W ) A- mov W inc ?capital # call A- A+ mov D C sub >= ?[ I inc Label done I dec A pop I push A I mov C D add Next ]? [[ byte lods ?capital # call A+ A- cmp 0= ?[ D D or done 0= not ?] I push W push C push A push D C mov [[ byte lods ?capital # call A+ A- xchg W ) A- mov W inc ?capital # call A+ A- cmp 0= ?[[ C0= ?] A pop C pop W pop I pop done ]] ]? A pop C pop W pop I pop ]? C0= ?] I inc done ]] end-code \ search for string UH 11mai88 | : skip ( addr -- addr' ) 'find c@ + ; | : search ( buf len string -- offset flag ) >r stash r@ match r> c@ < IF drop 0= false exit THEN swap - true ; | : find? ( -- r# f ) 'cursor #remaining 'find search ; | : searchthru ( -- r# scr ) find? IF skip cursor + scr @ exit THEN drop capacity scr @ 1+ ?DO I 2 3 at 6 .r I block b/blk 'find search IF skip I endloop exit THEN stop? Abort" Break!" LOOP true Abort" not found!" ; \ replace strings UH 14mai88| : replace? ( -- f ) dy l/s + 3+ dx 3 - at key dup #cr = IF line# redisplay true Abort" Break!" THEN capital Ascii R = ; | : "mark ( -- ) r# push 'find count dup negate c edit-at invers type normal ; | : (replace 'insert c@ 'find c@ - ?fit r# push 'find c@ negate c 'cursor #after 'find c@ delete 'insert count 'cursor #after insert modified ; | : "replace get-buffers BEGIN searchthru scr @ - ?dup IF ?stamp scr +! .all THEN r# ! imprint "mark replace? IF (replace THEN line# redisplay REPEAT ;\ Display Help-Screen, misc commands jrg 24nov89 | : helpfile ( -- ) fromfile push editor.scr ; | : .help ( --) isfile push scr push helpfile scr off .screen ; | : help ( -- ) .help key drop .screen ; | : screen# ( -- scr ) scr @ ; | Defer (fix-word | : fix-word ( -- ) isfile@ loadfile ! scr @ blk ! cursor >in ! (fix-word ; \ Control-Characters IBM-PC Functionkeys UH 10Sep87 Forth definitions : Ctrl ( -- c ) name 1+ c@ $1F and state @ IF [compile] Literal THEN ; immediate \needs #del $7F Constant #del Editor definitions | : flipimode imode @ 0= imode ! .imode ; | : F ( # -- 16b ) $FFC6 swap - ; | : shift ( n -- n' ) dup 0< + &24 - ; \ Control-Characters IBM-PC Functionkeys UH 11dez88 Create keytable -&72 , -&75 , -&80 , -&77 , 3 F , 4 F , 7 F , 8 F , Ctrl F , Ctrl S , 5 F , 6 F , 1 F , Ctrl H , #del , -&83 , Ctrl Y , Ctrl N , -&82 , #cr , #tab , #tab shift , -&119 , -&117 , 2 F , Ctrl U , Ctrl E , #esc , Ctrl L , 9 F shift , -&81 , -&73 , 9 F , &10 F , -&71 , -&79 , -&118 , -&132 , #lf , here keytable - 2/ Constant #keys \ Try a screen Editor UH 11dez88 Create: actiontable curup curleft curdown curright line>buf char>buf buf>line buf>char fix-word screen# copyline copychar help backspace backspace delete-char ( insert-char ) delete-line insert-line flipimode ( clear-line clear> ) +tab -tab top >""end "replace undo update-exit flushed-exit showload >shadow n b a mark split join new-screen ; here actiontable - 2/ 1- #keys - abort( # of actions) \ find keys ks 20 dez 87 | : findkey ( key -- adr/default ) #keys 0 DO dup keytable [F] I 2* + @ = IF drop [E] actiontable [F] I 2* + @ endloop exit THEN LOOP drop ['] putchar ; \ allocate buffers UH 01Nov86 c/l 2* | Constant cstack-size | : nextbuf ( adr -- adr' ) cstack-size + ; | : ?clearbuffer pad (pad @ = ?exit pad dup (pad ! nextbuf dup find-buffer ! 'find off nextbuf dup insert-buffer ! 'insert off nextbuf dup 0 chars 2! nextbuf 0 lines 2! ; \ enter and exit the editor, editor's loop UH 11mai88 | Variable jingle jingle on | : bell 07 charout jingle off ; | : clear-error ( -- ) jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; | : fullquit ( -- ) BEGIN ?clearbuffer edit-at key dup char c! findkey imprint execute ( .status ) clear-error REPEAT ; | : fullerror ( string -- ) jingle @ IF bell THEN count dy l/s + 1+ over 2/ dx $20 + swap - at invers type normal &80 col - spaces remember .all quit ; | : install ( -- ) ['] fullquit Is 'quit ['] fullerror errorhandler ! ; \ enter and exit the Editor jrg 30mr89 Forth definitions : v ( -- ) [E] 'start drop get-id install-screen install ?clearbuffer border .all .imode .status quit ; \ ' v Alias ed : l ( scr -- ) 1 arguments scr ! [E] top [F] v ; ' l Alias edit \ savesystem enhanced view UH 24jun88 : savesystem [E] id off (pad off savesystem ; Editor definitions | : >find ?clearbuffer >in push name dup c@ 2+ >r bl over c! r> 'find place ; Forth definitions : fix [ Dos ] >find ' @view >file isfile ! scr ! [E] top curdown find? IF skip 1- THEN c v ; ' fix Is (fix-word \\ Ecken und Macken jrg 18dez89 Das Problem fr einige GrafikKarten, keinen Cursor zu haben, wird im CED.scr verursacht, denn SHOWCUR macht ein konstantes, GrafikKarten-abhngiges CURSHAPE. Ein zweites Problem ist das sinnlose Arbeiten des Wortes CURSHAPE selbst: Die Cursorgre wird neu eingestellt, dann abervon einem der Ausgabeworte (welchem?) gelscht. Verdacht: (TYPE \ No newline at end of file diff --git a/sources/msdos/cursor/ced.fth b/sources/msdos/cursor/ced.fth new file mode 100644 index 0000000..1e581b4 --- /dev/null +++ b/sources/msdos/cursor/ced.fth @@ -0,0 +1,171 @@ + +\ *** Block No. 0, Hexblock 0 + +\ Commandline EDitor für volksFORTH rev. 3.80 UH 05feb89 +Dieses File enthaelt Definitionen, die es ermöglichen die +Kommandozeile zu editieren. +Es gibt eine Commandline History, die es ermöglicht alte +Eingaben wiederzuholen. Diese werden zyklisch auf Screen 0 +im File History gesichert und bleiben so auch über ein +SAVESYSTEM erhalten. + +Tasten: + Cursor links/rechts   + Zeichen löschen und <- + Zeile löschen + Einfügen an aus + Zeile abschließen + Anfang/Ende der Zeile + alte Zeilen wiederholen   + +\ *** Block No. 1, Hexblock 1 + +\ Commandline EDitor LOAD-Screen UH 20Nov87 jrg 14mär89 + + +: curleft ( -- ) at? 1- at ; +: currite ( -- ) at? 1+ at ; + +1 5 +thru \ Erweiterte Eingabe + +.( Kommandozeilen Editor geladen ) cr + + + + + + + + +\ *** Block No. 2, Hexblock 2 + +\ History -- Kommandogeschichte jrg 14mär89 +makefile history 1 more + +| Variable line# line# off +| Variable lastline# lastline# off + +| : 'history ( n -- addr ) pushfile history + c/l * b/blk /mod block + ; + +| : @line ( n -- addr len ) 'history c/l -trailing ; +| : !history ( addr line# -- ) + 'history dup c/l blank span @ c/l min cmove update ; +| : @history ( addr line# -- ) + @line rot swap dup span ! cmove ; + +| : +line ( n addr -- ) dup @ rot + l/s mod swap ! ; + +\ *** Block No. 3, Hexblock 3 + +\ Ende der Eingabe jrg 18dez89 + +| Variable maxchars | Variable cinsert cinsert on + +| : -text ( a1 a2 l -- 0=equal ) bounds + ?DO count I c@ - ?dup IF nip ENDLOOP exit THEN LOOP 0= ; + +| : done ( a p1 -- a p2 ) 2dup + at? rot - span @ dup maxchars ! + at space blankline + line# @ @line span @ = IF span @ -text 0=exit 2dup THEN + drop lastline# @ !history 1 lastline# +line ; + + + + + + +\ *** Block No. 4, Hexblock 4 + +\ Erweiterte Eingabe UH 08OCt87 jrg 19dez89 + : redisplay ( addr pos -- ) + at? 2swap span @ swap /string type blankline at ; + +| : del ( addr pos -- ) span @ 0=exit dup >r + dup 1+ swap + span @ r> - cmove -1 span +! ; +| : ins ( addr pos1 -- ) dup >r + dup dup 1+ + span @ r> - cmove> bl swap c! 1 span +! ; + +| : delete ( a p1 -- a p2 ) 2dup del 2dup redisplay ; +| : back ( a p1 -- a p2 ) 1- curleft delete ; + +| : recall ( a p1 -- a p2 ) at? rot - at dup line# @ @history + dup 0 redisplay at? span @ + at span @ ; + +| : r cinsert @ IF 2dup ins THEN 2dup + + r> swap c! 1+ dup span @ max span ! 2dup redisplay ; + +\ *** Block No. 6, Hexblock 6 + +\ Patch UH 08Oct87 jrg 19dez89 + +: showcur ( -- ) + curshape? swap drop \ bot top + cinsert @ IF dup 2/ \ top = bot/2 + ELSE dup 1- + THEN swap curshape ; + +: (expect ( addr len -- ) maxchars ! span off + lastline# @ line# ! 0 + BEGIN span @ maxchars @ u< + WHILE key decode showcur REPEAT 2drop ; + +' (decode ' keyboard 6 + ! +' (expect ' keyboard 8 + ! + + +\ *** Block No. 7, Hexblock 7 + + + + + + + + + + + + + + + + + + +\ *** Block No. 8, Hexblock 8 + + + + + + + + + + + + + + + + + diff --git a/sources/msdos/cursor/editor.fth b/sources/msdos/cursor/editor.fth new file mode 100644 index 0000000..113397c --- /dev/null +++ b/sources/msdos/cursor/editor.fth @@ -0,0 +1,798 @@ + +\ *** Block No. 0, Hexblock 0 + + volksFORTH Full-Screen-Editor HELP Screen + +Editor verlassen : flushed: ESC updated: ^E +Änderungen verwerfen: ^U (UNDO) +Cursor bewegen : Cursortasten (löschen mit DEL oder <- ) +Einfügen : INS (an/aus), ^ENTER (Screen einfügen) +Tabs : TAB (nach rechts), SHIFT TAB (nach links) +Blättern : Pg Dn (nächster), Pg Up (voriger) + : F9 (alternate), SHIFT F9 (shadow) +mark alternate Scr. : F10 +Zeile löschen/einf. : ^Y (löschen), ^N (einfügen) +Zeile teilen : ^PgDn (split), ^PgUp (join) +Suchen und Ersetzen : F2 (Break mit ESC, replace mit 'R' ) +Zeilenpuffer : F3 (push&delete), F5 (push), F7 (pop) +Zeichenpuffer : F4 (push&delete), F6 (push), F8 (pop) +Sonstige : ^F (Fix), ^L (Showload), ^S (Screen #) + +\ *** Block No. 1, Hexblock 1 + +--> \ Full-Screen Editor ks 22 dez 87 +Dieses File enthaelt den Full-Screen Editor fuer die IBM - +volksFORTH-Version. + +Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion +sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- +Funktion und des sichtbaren Laden von Screens (showload). + +Durch die integrierte Tastaturtabelle (keytable) laesst sich die +Kommandobelegung der Tasten auf einfache Art und Weise aendern. + +Angepaßt für den IBM PC von K.Schleisiek am 22 dez 87 +Anregungen, Kritik und Verbesserungsvorschlaege bitte an: + U. Hoffmann + Harmsstrasse 71 + 2300 Kiel + +\ *** Block No. 2, Hexblock 2 + +\ Load Screen for the Editor jrg 18dez89 + + Onlyforth \needs Assembler 2 loadfrom asm.scr + + 3 load \ PC adaption + +\ &10 load \ ANSI display interface +\ &11 load \ BIOS display interface +\ &12 load \ MULTItasking display interface + + &4 &40 thru \ Editor + +Onlyforth .( Screen Editor geladen) cr + + + + +\ *** Block No. 3, Hexblock 3 + +\ curshape? curon curoff jrg 20dez89 +\ gleiches Konzept wie curat? , nur C nach D geschoben +\ da C die Cursor-Start & -End-Reihe enthält + Code curshape? ( -- top bot ) + D push R push + $F # A+ mov $10 int \ in AL der Videomodus !! + 3 # A+ mov $10 int + R pop + C D mov + 0 # A mov + D+ A- xchg + A push Next end-code + + : curon curshape? curshape ; +\ VGA hat max. 15 Reihen! + : curoff &16 dup curshape ; + +\ *** Block No. 4, Hexblock 4 + +\ BIM adaption jrg 18dez89 +| : ?range ( n -- n ) + isfile@ 0=exit + ( n) dup 0< 9 and ?diskerror + dup capacity - 1+ 0 max + ?dup 0=exit more ; + +| : block ( n -- adr ) ?range block ; + + $1B Constant #esc + + + Variable caps caps off + Label ?capital 1 # caps #) byte test + 0= ?[ (capital # jmp ]? ret end-code + + +\ *** Block No. 5, Hexblock 5 + +\ search delete insert replace ks 20 dez 87 + +| : delete ( buffer size count -- ) + over min >r r@ - ( left over ) dup 0> + IF 2dup swap dup r@ + -rot swap cmove THEN + + r> bl fill ; + +| : insert ( string length buffer size -- ) + rot over min >r r@ - ( left over ) + over dup r@ + rot cmove> r> cmove ; + +| : replace ( string length buffer size -- ) + rot min cmove ; + + + + +\ *** Block No. 6, Hexblock 6 + +\ usefull definitions and Editor vocabulary UH 11mai88 + +Vocabulary Editor + +' Forth | Alias [F] immediate +' Editor | Alias [E] immediate + +Editor also definitions + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + +| Variable r#' r#' off +| Variable scr' scr' off +' fromfile | Alias isfile' +| Variable lastfile | Variable lastscr | Variable lastr# + +\ *** Block No. 7, Hexblock 7 + +\\ move cursor with position-checking ks 18 dez 87 +\ different versions of cursor positioning error reporting + +| : c ( n --) \ checks the cursor position + r# @ + dup 0 b/blk uwithin not + Abort" There is a border!" r# ! ; + +| : c ( n --) \ goes thru the screens + r# @ + dup b/blk 1- > IF 1 scr +! THEN + dup 0< IF -1 scr +! THEN b/blk mod r# ! ; + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + + + + +\ *** Block No. 8, Hexblock 8 + +\ calculate addresses ks 20 dez 87 +| : *line ( l -- adr ) c/l * ; +| : /line ( n -- c l ) c/l /mod ; +| : top ( -- ) r# off ; +| : cursor ( -- n ) r# @ ; +| : 'start ( -- adr ) scr @ block ; +| : 'end ( -- adr ) 'start b/blk + ; +| : 'cursor ( -- adr ) 'start cursor + ; +| : position ( -- c l ) cursor /line ; +| : line# ( -- l ) position nip ; +| : col# ( -- c ) position drop ; +| : 'line ( -- adr ) 'start line# *line + ; +| : 'line-end ( -- adr ) 'line c/l + 1- ; +| : #after ( -- n ) c/l col# - ; +| : #remaining ( -- n ) b/blk cursor - ; +| : #end ( -- n ) b/blk line# *line - ; + +\ *** Block No. 9, Hexblock 9 + +\ move cursor directed UH 11dez88 +| Create >at 0 , 0 , +| : curup c/l negate c ; +| : curdown c/l c ; +| : curleft -1 c ; +| : curright 1 c ; + +| : +tab ( 1/4 -> ) cursor $10 / 1+ $10 * cursor - c ; +| : -tab ( 1/8 <- ) cursor 8 mod negate dup 0= 8 * + c ; + +| : >last ( adr len -- ) -trailing nip b/blk min r# ! ; +| : #after c ; +| : ( -- ) 'start line# 1+ *line 1- >last ; +| : >""end ( -- ) 'start b/blk >last ; + +\ *** Block No. 10, Hexblock a + +\ show border UH 29Sep87 + +&14 | Constant dx 1 | Constant dy + +| : horizontal ( row eck1 eck2 -- row' ) + rot dup >r dx 1- at swap emit + c/l 0 DO Ascii ─ emit LOOP emit r> 1+ ; + +| : vertical ( row -- row' ) + l/s 0 DO dup dx 1- at Ascii │ emit + row dx c/l + at Ascii │ emit 1+ LOOP ; + +| : border dy 1- Ascii ┌ Ascii ┐ horizontal + vertical Ascii └ Ascii ┘ horizontal drop ; + +| : edit-at ( -- ) position swap dy dx d+ at ; + +\ *** Block No. 11, Hexblock b + +\\ ANSI display interface ksjrg 18dez89 + + + + + + + +| : redisplay ( line# -- ) + dup dy + dx at *line 'start + c/l type ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + + +\ *** Block No. 12, Hexblock c + +\\ BIOS-display interface ksjrg 18dez89 +| Code (.line ( line addr videoseg -- ) + A pop W pop I push E: push D E: mov + $0E # W add W W add A I xchg c/l # C mov + attribut #) A+ mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + + +\ *** Block No. 13, Hexblock d + +\ MULTI-display interface ks UH 10Sep87 +| Code (.line ( line addr videoseg -- ) + C pop W pop I push E: push D E: mov + $0E # W add W W add u' area U D) I mov + u' catt I D) A+ mov C I mov + c/l # C mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) line# 2+ c/col 2- window ; + +| : cleartop ( -- ) 0 l/s 5 + window (page ; +| : install-screen ( -- ) row l/s 6 + u< + IF l/s 6 + 0 full page ELSE at? cleartop THEN >at 2! ; + +\ *** Block No. 14, Hexblock e + +\ display screen jrg 18dez89 +Forth definitions + : updated? ( -- f) 'start 2- @ 0< ; +Editor definitions +| : .updated ( -- ) 9 0 at + updated? IF 4 spaces ELSE ." not " THEN ." updated" ; + +| : .screen l/s 0 DO I redisplay LOOP ; +\ | : .file ( fcb -- ) +\ ?dup IF body> >name .name exit THEN ." direct" ; +| : .title [ DOS ] 1 0 at isfile@ invers .file normal dx 1- tab + 2 0 at drv (.drv scr @ 6 .r + 4 0 at fromfile @ underline .file normal dx 1- tab + 5 0 at fswap drv (.drv scr' @ 6 .r fswap .updated ; + +| : .all .title .screen ; + +\ *** Block No. 15, Hexblock f + +\ check errors UH 02Nov86 + +| : ?bottom ( -- ) 'end c/l - c/l -trailing nip + Abort" You would lose a line" ; + +| : ?fit ( n -- ) 'line c/l -trailing nip + c/l > + IF line# redisplay + true Abort" You would lose a char" THEN ; + +| : ?end 1 ?fit ; + + + + + + + +\ *** Block No. 16, Hexblock 10 + +\ programmer's id ks jrg 24nov89 + +$12 | Constant id-len +Create id id-len allot id id-len erase + +| : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; + +| : ?stamp ( -- ) updated? IF stamp THEN ; + +| : ## ( n -- ) base push decimal 0 <# # # #> id 1+ attach ; + +| : get-id ( -- ) id c@ ?exit ID on + cr ." Enter your ID : " at? 3 0 DO Ascii . emit LOOP at + id 2+ 3 expect span @ dup id 1+ c! 0=exit + bl id 1+ append date@ rot ## swap >months id 1+ attach ## ; + + +\ *** Block No. 17, Hexblock 11 + +\ update screen-display UH 28Aug87 + +| : emptybuf prev @ 2+ dup on 4+ off ; + +| : undo emptybuf .all ; + +| : modified updated? ?exit update .updated ; + +| : linemodified modified line# redisplay ; + +| : screenmodified modified + l/s line# ?DO I redisplay LOOP ; + +| : .modified ( -- ) >at 2@ at space scr @ . + updated? not IF ." un" THEN ." modified" ?stamp ; + + +\ *** Block No. 18, Hexblock 12 + +\ leave editor jrg 04jul88 +| Variable (pad (pad off +| : memtop ( -- adr) sp@ $100 - ; + +| Create char 1 allot +| Variable imode imode off +| : .imode at? 7 0 at + imode @ IF ." insert " + ELSE bright ." overwrite" normal THEN at ; +| : setimode imode on .imode ; +| : clrimode imode off .imode ; +| : done ( -- ) (done + ['] (quit is 'quit ['] (error errorhandler ! quit ; + +| : update-exit ( -- ) .modified done ; +| : flushed-exit ( -- ) .modified save-buffers done ; + +\ *** Block No. 19, Hexblock 13 + +\ handle screens UH 21jan89 + +| : insert-screen ( scr -- ) \ before scr + 1 more fromfile push isfile@ fromfile ! + capacity 2- over 1+ convey ; + +| : wipe-screen ( -- ) 'start b/blk blank ; + +| : new-screen ( -- ) + scr @ insert-screen wipe-screen top screenmodified ; + + + + + + + +\ *** Block No. 20, Hexblock 14 + +\ handle lines UH 01Nov86 + +| : (clear-line 'line c/l blank ; +| : clear-line (clear-line linemodified ; + +| : clear> 'cursor #after blank linemodified ; + +| : delete-line 'line #end c/l delete screenmodified ; + +| : backline curup delete-line ; + +| : (insert-line + ?bottom 'line c/l over #end insert (clear-line ; + +| : insert-line (insert-line screenmodified ; + + +\ *** Block No. 21, Hexblock 15 + +\ join and split lines UH 11dez88 + +| : insert-spaces ( n -- ) 'cursor swap + 2dup over #remaining insert blank ; + +| : split ( -- ) ?bottom cursor col# insert-spaces r# ! + #after insert-spaces screenmodified ; + +| : delete-characters ( n -- ) 'cursor #remaining rot delete ; + +| : join ( -- ) cursor line> col# Abort" next line will not fit!" + #after + dup delete-characters + cursor c/l rot - dup 0< + IF negate insert-spaces ELSE delete-characters THEN r# ! + screenmodified ; + +\ *** Block No. 22, Hexblock 16 + +\ handle characters UH 01Nov86 + +| : delete-char 'cursor #after 1 delete linemodified ; + +| : backspace curleft delete-char ; + +| : (insert-char ?end 'cursor 1 over #after insert ; + + +| : insert-char (insert-char bl 'cursor c! linemodified ; + +| : putchar ( --) char c@ + imode @ IF (insert-char THEN + 'cursor c! linemodified curright ; + + + +\ *** Block No. 23, Hexblock 17 + +\ stack lines UH 31Oct86 + +| Create lines 4 allot \ { 2+pointer | 2base } +| : 'lines ( -- adr) lines 2@ + ; + +| : @line 'lines memtop u> Abort" line buffer full" + 'line 'lines c/l cmove c/l lines +! ; + +| : copyline @line curdown ; +| : line>buf @line delete-line ; + +| : !line c/l negate lines +! 'lines 'line c/l cmove ; + +| : buf>line lines @ 0= Abort" line buffer empty" + ?bottom (insert-line !line screenmodified ; + + +\ *** Block No. 24, Hexblock 18 + +\ stack characters UH 01Nov86 + +| Create chars 4 allot \ { 2+pointer | 2base } +| : 'chars ( -- adr) chars 2@ + ; + +| : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" + 'cursor c@ 'chars c! 1 chars +! ; + +| : copychar @char curright ; +| : char>buf @char delete-char ; + +| : !char -1 chars +! 'chars c@ 'cursor c! ; + +| : buf>char chars @ 0= Abort" char buffer empty" + ?end (insert-char !char linemodified ; + + +\ *** Block No. 25, Hexblock 19 + +\ switch screens UH 11mai88 + +| : imprint ( -- ) \ remember valid file + isfile@ lastfile ! scr @ lastscr ! r# @ lastr# ! ; + +| : remember ( -- ) + lastfile @ isfile ! lastscr @ scr ! lastr# @ r# ! ; + +| : associate \ switch to alternate screen + isfile' @ isfile@ isfile' ! isfile ! + scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; + +| : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .all ; +| : n ?stamp 1 scr +! .all ; +| : b ?stamp -1 scr +! .all ; +| : a ?stamp associate .all ; + +\ *** Block No. 26, Hexblock 1a + +\ shadow screens UH 03Nov86 + +Variable shadow shadow off + +| : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; + +| : >shadow ?stamp \ switch to shadow screen + (shadow dup scr @ u> not IF negate THEN scr +! .all ; + + + + + + + + + +\ *** Block No. 27, Hexblock 1b + +\ load and show screens ks 02 mär 88 + +| : showoff ['] exit 'name ! normal ; + +| : show ( -- ) blk @ 0= IF showoff exit THEN + >in @ 1- r# ! edit-at imprint blk @ scr @ - 0=exit + blk @ scr ! normal curoff .all invers curon ; + +| : showload ( -- ) ?stamp save-buffers + ['] show 'name ! curon invers + adr .status push ['] noop is .status + scr @ scr push scr off r# push r# @ (load showoff ; + + + + + +\ *** Block No. 28, Hexblock 1c + +\ find strings ks 20 dez 87 +| Variable insert-buffer +| Variable find-buffer + +| : 'insert ( -- addr ) insert-buffer @ ; +| : 'find ( -- addr ) find-buffer @ ; + +| : .buf ( addr -- ) count type ." │" &80 col - spaces ; + +| : get ( addr -- ) >r at? r@ .buf + 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN + at r> .buf ; + +| : get-buffers dy l/s + 2+ dx 1- 2dup at + ." find: │" 'find get swap 1+ swap 2- at + ." ? replace: │" 'insert get ; + +\ *** Block No. 29, Hexblock 1d + +\ ks 20 dez 87 + Code match ( addr1 len1 string -- addr2 len2 ) + D W mov W ) D- mov $FF # D and 0= ?[ D pop Next ]? + W inc D dec C pop I A mov I pop A push + W ) A- mov W inc ?capital # call A- A+ mov D C sub + >= ?[ I inc Label done I dec + A pop I push A I mov C D add Next ]? + [[ byte lods ?capital # call A+ A- cmp 0= + ?[ D D or done 0= not ?] + I push W push C push A push D C mov + [[ byte lods ?capital # call A+ A- xchg + W ) A- mov W inc ?capital # call A+ A- cmp + 0= ?[[ C0= ?] A pop C pop + W pop I pop done ]] + ]? A pop C pop W pop I pop + ]? C0= ?] I inc done ]] end-code + +\ *** Block No. 30, Hexblock 1e + +\ search for string UH 11mai88 + +| : skip ( addr -- addr' ) 'find c@ + ; + +| : search ( buf len string -- offset flag ) + >r stash r@ match r> c@ < + IF drop 0= false exit THEN swap - true ; + +| : find? ( -- r# f ) 'cursor #remaining 'find search ; + +| : searchthru ( -- r# scr ) + find? IF skip cursor + scr @ exit THEN drop + capacity scr @ 1+ + ?DO I 2 3 at 6 .r I block b/blk 'find search + IF skip I endloop exit THEN stop? Abort" Break!" + LOOP true Abort" not found!" ; + +\ *** Block No. 31, Hexblock 1f + +\ replace strings UH 14mai88 +| : replace? ( -- f ) dy l/s + 3+ dx 3 - at + key dup #cr = IF line# redisplay true Abort" Break!" THEN + capital Ascii R = ; + +| : "mark ( -- ) r# push + 'find count dup negate c edit-at invers type normal ; + +| : (replace 'insert c@ 'find c@ - ?fit + r# push 'find c@ negate c + 'cursor #after 'find c@ delete + 'insert count 'cursor #after insert modified ; + +| : "replace get-buffers BEGIN searchthru + scr @ - ?dup IF ?stamp scr +! .all THEN r# ! imprint + "mark replace? IF (replace THEN line# redisplay REPEAT ; + +\ *** Block No. 32, Hexblock 20 + +\ Display Help-Screen, misc commands jrg 24nov89 + +| : helpfile ( -- ) fromfile push editor.scr ; + +| : .help ( --) + isfile push scr push helpfile scr off .screen ; +| : help ( -- ) .help key drop .screen ; + +| : screen# ( -- scr ) scr @ ; + +| Defer (fix-word + +| : fix-word ( -- ) isfile@ loadfile ! + scr @ blk ! cursor >in ! (fix-word ; + + + +\ *** Block No. 33, Hexblock 21 + +\ Control-Characters IBM-PC Functionkeys UH 10Sep87 + +Forth definitions + +: Ctrl ( -- c ) + name 1+ c@ $1F and state @ IF [compile] Literal THEN ; +immediate + +\needs #del $7F Constant #del + +Editor definitions + +| : flipimode imode @ 0= imode ! .imode ; + +| : F ( # -- 16b ) $FFC6 swap - ; +| : shift ( n -- n' ) dup 0< + &24 - ; + +\ *** Block No. 34, Hexblock 22 + +\ Control-Characters IBM-PC Functionkeys UH 11dez88 + +Create keytable +-&72 , -&75 , -&80 , -&77 , + 3 F , 4 F , 7 F , 8 F , +Ctrl F , Ctrl S , 5 F , 6 F , + 1 F , Ctrl H , #del , -&83 , + Ctrl Y , Ctrl N , +-&82 , + #cr , #tab , #tab shift , + -&119 , -&117 , 2 F , Ctrl U , +Ctrl E , #esc , Ctrl L , 9 F shift , +-&81 , -&73 , 9 F , &10 F , +-&71 , -&79 , -&118 , -&132 , +#lf , +here keytable - 2/ Constant #keys + +\ *** Block No. 35, Hexblock 23 + +\ Try a screen Editor UH 11dez88 + +Create: actiontable +curup curleft curdown curright +line>buf char>buf buf>line buf>char +fix-word screen# copyline copychar +help backspace backspace delete-char +( insert-char ) delete-line insert-line +flipimode ( clear-line clear> ) + +tab -tab +top >""end "replace undo +update-exit flushed-exit showload >shadow +n b a mark + split join +new-screen ; +here actiontable - 2/ 1- #keys - abort( # of actions) + +\ *** Block No. 36, Hexblock 24 + +\ find keys ks 20 dez 87 + +| : findkey ( key -- adr/default ) + #keys 0 DO dup keytable [F] I 2* + @ = + IF drop [E] actiontable [F] I 2* + @ endloop exit THEN + LOOP drop ['] putchar ; + + + + + + + + + + + +\ *** Block No. 37, Hexblock 25 + +\ allocate buffers UH 01Nov86 + +c/l 2* | Constant cstack-size + +| : nextbuf ( adr -- adr' ) cstack-size + ; + +| : ?clearbuffer pad (pad @ = ?exit + pad dup (pad ! + nextbuf dup find-buffer ! 'find off + nextbuf dup insert-buffer ! 'insert off + nextbuf dup 0 chars 2! + nextbuf 0 lines 2! ; + + + + + +\ *** Block No. 38, Hexblock 26 + +\ enter and exit the editor, editor's loop UH 11mai88 + +| Variable jingle jingle on | : bell 07 charout jingle off ; + +| : clear-error ( -- ) + jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; + +| : fullquit ( -- ) BEGIN ?clearbuffer edit-at key dup char c! + findkey imprint execute ( .status ) clear-error REPEAT ; + +| : fullerror ( string -- ) jingle @ IF bell THEN count + dy l/s + 1+ over 2/ dx $20 + swap - at invers type normal + &80 col - spaces remember .all quit ; + +| : install ( -- ) + ['] fullquit Is 'quit ['] fullerror errorhandler ! ; + +\ *** Block No. 39, Hexblock 27 + +\ enter and exit the Editor jrg 30mär89 + +Forth definitions + +: v ( -- ) + [E] 'start drop get-id install-screen + install ?clearbuffer + border .all .imode .status quit ; + +\ ' v Alias ed + +: l ( scr -- ) 1 arguments scr ! [E] top [F] v ; + + ' l Alias edit + + + +\ *** Block No. 40, Hexblock 28 + +\ savesystem enhanced view UH 24jun88 + +: savesystem [E] id off (pad off savesystem ; + +Editor definitions +| : >find ?clearbuffer >in push + name dup c@ 2+ >r bl over c! r> 'find place ; + +Forth definitions +: fix [ Dos ] >find ' @view >file + isfile ! scr ! [E] top curdown + find? IF skip 1- THEN c v ; + +' fix Is (fix-word + + + +\ *** Block No. 41, Hexblock 29 + +\\ Ecken und Macken jrg 18dez89 + +Das Problem für einige GrafikKarten, keinen Cursor zu haben, +wird im CED.scr verursacht, denn SHOWCUR macht ein konstantes, +GrafikKarten-abhängiges CURSHAPE. + +Ein zweites Problem ist das sinnlose Arbeiten des Wortes +CURSHAPE selbst: Die Cursorgröße wird neu eingestellt, dann aber +von einem der Ausgabeworte (welchem?) gelöscht. +Verdacht: (TYPE + + + + + + From 3d0bcfcecebc60b32eba9dedccca42bc58faad10 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 4 Jan 2021 10:51:00 +0100 Subject: [PATCH 2/2] 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 + + + + + + + + + + + + + + + + +