Merge branch 'master' of https://github.com/forth-ev/VolksForth into v3.9.2

msdos/cursor/cursor.txt

@@ -0,0 +1,27 @@
+Im volksFORTH rev.3.81.41 treten, bedingt durch die Vielfalt an
+Grafik-Karten f<>r den PC, unter Umst„nden 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 f<>r CURSHAPE, die grafikkartenabh„ngig
+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) daf<61>r gesorgt, daá meine gesamte
+freie Festplattenkapazit„t der Datei EDITOR.SCR zugeschlagen
+wurde.
+Mit den neuen Varianten von CURON/OFF m<>áten auch EGA und andere
+Karten einen Cursor auf dem Schirm anzeigen. Mit dem
+Kommandozeilen-Editor CED h„ngt auch das zweite Problem zusammen:
+Wie man in SHOWCUR sieht, wird der Einf<6E>ge- 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 Abh„ngigkeit
+vom jeweiligen Modus festlegt und ein etwaiges  ( top bot) CURSHAPE
+unwirksam machen. Soll dem nicht so sein, k”nnte man eventuell
+die jetzt gel”schte Cursor-Anfangszeile in einem der beiden Modi
+INS/OVER beibehalten.
+

sources/generic/case/case.4th

@@ -0,0 +1,228 @@
+
+\ *** Block No. 0, Hexblock 0
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ CASE   OF  ENDOF   END-CASE     BREAK              jrg 30mai89
+
+ : CASE      ( n -- n n )  dup ;  restrict
+
+ : OF        [compile] IF compile drop ;  immediate restrict
+
+ : ENDOF     [compile] ELSE 4+ ;  immediate restrict
+
+ : ENDCASE   compile drop
+             BEGIN
+               3 case?
+             WHILE
+               >resolve
+             REPEAT ;  immediate restrict
+
+ : BREAK     compile exit  [compile] THEN ;  immediate restrict
+
+\ *** Block No. 3, Hexblock 3
+
+\ =or                                                jrg 06okt88
+
+  code =or       ( n1 f1 n2 -- n1 f2 )
+     A D xchg  D pop
+     S W mov
+       W ) A cmp
+       0= ?[ -1 # D mov ]?
+    next
+  end-code
+
+\ : =or  ( n1 f1 n2 -- n1 f2 )  2 pick = or ;
+
+
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ leapyear?    nach Wil Baden VD 2/87 S.42           jrg 30mai89
+
+| : leapyear?  ( year# -- f : true falls Jahr = Schaltjahr )
+       CASE 400 mod 0= OF  true   BREAK
+       CASE 100 mod 0= OF  false  BREAK
+       CASE   4 mod 0= OF  true   BREAK
+       drop   false ;
+
+\\ nach Kaiser, Grundlegende Elemente ... S.160, Birkhäuser
+
+  : leapyear?  ( year# -- f : true falls Jahr = Schaltjahr )
+       dup         4 mod 0=        ( y# f)
+       swap dup  100 mod 0<>       ( f1 y# f2 )
+       rot       and               ( y# f3 )
+       swap      400 mod 0= or  ;
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ Monatsnamen                                        jrg 30mai89
+|  1 Constant jan
+|  2 Constant feb
+|  3 Constant mär
+|  4 Constant apr
+|  5 Constant mai
+|  6 Constant jun
+|  7 Constant jul
+|  8 Constant aug
+|  9 Constant sep
+| 10 Constant okt
+| 11 Constant nov
+| 12 Constant dez
+
+\\
+| Create months  ," janfebmäraprmaijunjulaugsepoktnovdez"
+
+\ *** Block No. 6, Hexblock 6
+
+\ Tage im Monat                                      jrg 30mai89
+
+: #days  ( month# -- days-in-month )
+    CASE  jan =  apr =or  jun =or  nov =or  OF  30  BREAK
+    CASE  feb = not                         OF  31  BREAK
+    drop  leapyear? IF  29  ELSE  28  THEN ;
+
+: .all
+    12 1+  1
+             DO cr
+              I .
+              I >months type  ."  hat "
+              I #days   .     ." Tage."
+             LOOP ;
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+% Schaltjahr ?                                       jrg 30mai89
+
+Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be-
+zeichnet, werden zunächst die ohne Rest durch 4 teilbaren Jahre
+durch
+        JAHR MOD 4 = 0
+erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch
+
+        (JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)
+
+"entfernt".
+Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin-
+zugefügt:
+
+((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0)
+
+
+\ *** Block No. 8, Hexblock 8
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+% Schaltjahr ?                                       jrg 30mai89
+
+Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be-
+zeichnet, werden zunächst die ohne Rest durch 4 teilbaren Jahre
+durch
+        JAHR MOD 4 = 0
+erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch
+
+        (JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)
+
+"entfernt".
+Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin-
+zugefügt:
+
+((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0)
+
+
+\ *** Block No. 10, Hexblock a
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

sources/generic/case/casepos.fth

@@ -0,0 +1,285 @@
+
+\ *** Block No. 0, Hexblock 0
+
+***************** CRAPS *****************************jrg 06okt88
+nach Wil Baden
+
+Da es in Deutschland das Würfelspiel CRAPS nicht gibt, habe ich
+diesem Begriff ein Würfel- und Trinkspiel aus der Schulzeit
+unterlegt.
+Bei diesem Spiel steht in der Tischmitte ein Vorrat an gefüllten
+Gläsern. Danach soll ein Mitspieler abhängig von seinem Wurf
+
+entweder   ein neues Glas aus der Tischmitte vor sich stellen
+oder       eines seiner Gläser seinem Nachbarn zur linken oder
+           zur rechten zuschieben
+oder       alle vor ihm stehenden Gläser austrinken.
+
+Zuordnung: 1=nehmen, 2/3=links, 4/5=rechts, 6 trinken
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ LoadScreen                                         jrg 31dez89
+
+\needs :Does>    2 load
+
+  8 load
+  cr .( positionelles CASE geladen ) cr
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ :Does>  für  Create <name> :Does> ... ;ks 25 aug 88jrg 31dez89
+
+| : (does>   here >r [compile] Does> ;
+
+  : :Does>    last @ 0= Abort" without reference"
+     (does> current @ context !   hide 0 ] ;
+
+clear
+\\
+: test   cls
+     5 0 DO
+          cr ." craps1 " I . ." mal" craps1
+          cr ." craps2 " I . ." mal" craps2
+          cr ." craps3 " I . ." mal" craps3
+         LOOP
+    cr ." fertig."  ;
+
+\ *** Block No. 3, Hexblock 3
+
+\ nehmen  trinken  links  rechts  schieben           jrg 05feb89
+
+: nehmen   bright ." ein Glas nehmen"        normal  2 spaces ;
+: trinken  bright ." alle Gläser austrinken" normal  2 spaces ;
+: links    bright ." ein Glas nach LINKS"    normal  2 spaces ;
+: rechts   bright ." ein Glas nach RECHTS"   normal  2 spaces ;
+: schieben  ;
+: schimpfen   invers ." Betrug! " normal ;
+
+: Anfrage      cr ." Sollen Sie nehmen, trinken oder schieben? "
+               cr ." Bitte Ihre Augenzahl und <cr> : "   ;
+
+: Glückwunsch  cr ." Viel Glück beim nächsten Wurf ... " ;
+
+cr .( Sprüche geladen )
+
+
+\ *** Block No. 4, Hexblock 4
+
+\ Zugriffs-Prozeduren für Tabellen von Prozeduren    jrg 05feb89
+
+: bewegen  ( adr n -- cfa )
+    2* +  perform ;
+
+: richtig  ( n  --  0<= n <= 3 )
+    swap
+    1 max  6 min                        \ ein bißchen Sicherheit
+    3 case? IF  2  1- exit  ENDIF
+    5 case? IF  4  1- exit  ENDIF
+    1-  ;                               \ ein bißchen Justage
+
+
+
+\ Dieses Wort läßt zwar Werte < 1 und > 6 zu, justiert sie aber
+\ auf den Bereich zwischen 1 und 6 .
+
+\ *** Block No. 5, Hexblock 5
+
+\  Die möglichen Tabellen mit  ] [  oder Create:     jrg 05feb89
+\  traditionell:
+
+Create  Glas
+        ]  nehmen  links schieben
+                   rechts schieben  trinken  [
+
+
+\  oder VOLKS4TH-gemäß :
+
+Create: Glas
+         nehmen
+         links schieben
+         rechts schieben
+         trinken ;
+
+
+\ *** Block No. 6, Hexblock 6
+
+\  Create: ; :Does>      Auswertung.8                jrg 05feb89
+
+Create: Auswertung.8
+          nehmen
+           links schieben
+           rechts schieben
+          trinken ;
+      :Does>
+         richtig bewegen ;
+
+
+
+
+
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+\  Das vollständige Programm                         jrg 05feb89
+
+: CRAPS1
+     cr  Anfrage cr
+           input#
+           Glas richtig bewegen
+     cr  Glückwunsch
+;
+
+\ ausschließlich als Datenstruktur
+: CRAPS2
+     cr  Anfrage cr
+           input#
+           Auswertung
+     cr  Glückwunsch
+;
+
+\ *** Block No. 8, Hexblock 8
+
+\ #### positional CASE def.words  Case: Associative: jrg 05feb89
+: Case:    ( -- )
+   Create: Does>    ( pfa -- )  swap 2* +  perform ;
+
+\ alternative Definition für CASE:
+\ : Case:
+\     : Does>       ( pfa -- )  swap 2* +  perform ;
+
+
+: Associative:           ( n -- )
+   Constant   Does>      ( n - index )
+   dup @ -rot            \ out of range = maxIndex + 1
+   dup @ 0
+   DO  2+  2dup  @ =
+       IF  2drop drop  I  0 0  LEAVE  THEN
+   LOOP 2drop ;
+
+\ *** Block No. 9, Hexblock 9
+
+\  CASE: in der Anwendung       ( 9. Auswertung)     jrg 05feb89
+         Case:  handeln                   \ besteht aus :
+                   nehmen
+                    links  links
+                    rechts rechts
+                   trinken
+                schimpfen ;
+
+6 Associative:  auswerten
+
+                  1 ,
+                2 , 3 ,
+                4 , 5 ,
+                  6 ,
+
+\ Hier erzeugen MIN und MAX  out of range Fehler  maxIndex + 1
+
+\ *** Block No. 10, Hexblock a
+
+\  CASE:  und  Associative:                          jrg 05feb89
+
+: CRAPS3   ( -- )
+
+     cr  Anfrage cr
+         input#
+            auswerten
+            handeln
+     cr  Glückwunsch
+;
+
+
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 12, Hexblock c
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 13, Hexblock d
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 14, Hexblock e
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

sources/generic/case/casetru.fth

@@ -0,0 +1,266 @@
+
+\ *** Block No. 0, Hexblock 0
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ F83-number?  input#                                jrg 05feb89
+
+  : F83-number?   ( string -- d f )
+       number? ?dup  IF  0< IF extend ENDIF
+                         true exit
+                     THEN  drop  0 0  false ;
+
+  : input#   ( <string> -- n )
+       pad c/l 1- >expect
+       pad F83-number?  2drop ;
+
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+\ nehmen  trinken  links  rechts  schieben           jrg 05feb89
+
+: nehmen   bright ." ein Glas nehmen"        normal  2 spaces ;
+: trinken  bright ." alle Gläser austrinken" normal  2 spaces ;
+: links    bright ." ein Glas nach LINKS"    normal  2 spaces ;
+: rechts   bright ." ein Glas nach RECHTS"   normal  2 spaces ;
+
+: schieben  ;
+
+
+: Anfrage      cr ." Sollen Sie nehmen, trinken oder schieben? "
+               cr ." Bitte Ihre Augenzahl und <cr> : "   ;
+
+: Glückwunsch  cr ." Viel Glück beim nächsten Wurf ... " ;
+
+cr .( Sprüche geladen )
+
+\ *** Block No. 3, Hexblock 3
+
+\ Auswertung.1 mit IF...ELSE...THEN                  jrg 05feb89
+
+: Auswertung.1  ( Wurfergebnis --)
+
+     dup 1 = IF nehmen ELSE
+             dup 2 = IF links schieben ELSE
+             dup 3 = IF links schieben ELSE
+                     dup 4 = IF rechts schieben ELSE
+                     dup 5 = IF rechts schieben ELSE
+                             dup 6 = IF trinken THEN
+                             THEN
+                             THEN
+                     THEN
+                     THEN
+             THEN
+     1 6 between not IF invers ." Betrug!" normal ENDIF ;
+
+\ *** Block No. 4, Hexblock 4
+
+\ Auswertung.2 mit IF...THEN / ENDIF                 jrg 05feb89
+
+' THEN Alias ENDIF  immediate restrict
+
+: Auswertung.2  ( Wurfergebnis --)
+
+     dup 1 = IF nehmen          ENDIF
+     dup 2 = IF links  schieben ENDIF
+     dup 3 = IF links  schieben ENDIF
+     dup 4 = IF rechts schieben ENDIF
+     dup 5 = IF rechts schieben ENDIF
+     dup 6 = IF trinken         ENDIF
+
+     1 6 between not IF invers ." Betrug!" normal ENDIF
+;
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ Auswertung.3 mit IF...ENDIF  und  CASE?            jrg 05feb89
+
+: Auswertung.3   ( Wurfergebnis --)
+
+      1 case? IF nehmen           exit ENDIF
+      2 case? IF links  schieben  exit ENDIF
+      3 case? IF links  schieben  exit ENDIF
+      4 case? IF rechts schieben  exit ENDIF
+      5 case? IF rechts schieben  exit ENDIF
+      6 case? IF trinken          exit ENDIF
+
+  1 6 between not IF
+                   invers ." Betrugsversuch" normal
+                  ENDIF
+;
+
+
+\ *** Block No. 6, Hexblock 6
+
+\ =or                                                jrg 06okt88
+
+  code =or       ( n1 f1 n2 -- n1 f2 )
+     A D xchg  D pop
+     S W mov
+       W ) A cmp
+       0= ?[ -1 # D mov ]?
+    next
+  end-code
+
+\ : =or  ( n1 f1 n2 -- n1 f2 )  2 pick = or ;
+
+
+
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+\ Auswertung.4 mit IF...THEN  und =or                jrg 05feb89
+
+: Auswertung.4  ( Wurfergebnis --)
+     dup
+     1 6 between IF
+                  dup 1 =       IF  nehmen           ENDIF
+                  dup 2 = 3 =or IF  links schieben   ENDIF
+                  dup 4 = 5 =or IF  rechts schieben  ENDIF
+                  dup 6 =       IF  trinken          ENDIF
+                 ELSE
+                  invers ." Betrug!" normal
+                 ENDIF
+     drop
+;
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+****** Beginn der Kommentare ************************jrg 05feb89
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+                                                     jrg 03feb89
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\\ So ist es schrecklich !                           jrg 03feb89
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+\\ ENDIF  und  CASE?                                 jrg 03feb89
+
+ENDIF  macht deutlich(er), warum FORTH ohne Verbundanweisung wie
+       z.B. PASCAL auskommt.
+AUSWERTUNG führt entsprechend einem Selektor genau eine von 6
+       möglichen Prozeduren aus.
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 12, Hexblock c
+
+                                                     jrg 03feb89
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 13, Hexblock d
+
+\\ =OR                                               jrg 03feb89
+
+=OR     prüft eine Zahl n2 auf Gleichheit mit einem Testwert n1
+        und verknüpft resultierende Ergebnis mit einem bereits
+        vorliegenden flag f1. Es werden das neue flag f2 und der
+        "alte" Testwert n1 übergeben.
+
+
+
+
+
+
+
+
+
+

sources/generic/case/craps.fth

@@ -0,0 +1,627 @@
+
+\ *** Block No. 0, Hexblock 0
+
+***************** CRAPS *****************************jrg 06okt88
+nach Wil Baden
+
+Da es in Deutschland das Würfelspiel CRAPS nicht gibt, habe ich
+diesem Begriff ein Würfel- und Trinkspiel aus der Schulzeit
+unterlegt.
+Bei diesem Spiel steht in der Tischmitte ein Vorrat an gefüllten
+Gläsern. Danach soll ein Mitspieler abhängig von seinem Wurf
+
+entweder   ein neues Glas aus der Tischmitte vor sich stellen
+oder       eines seiner Gläser seinem Nachbarn zur linken oder
+           zur rechten zuschieben
+oder       alle vor ihm stehenden Gläser austrinken.
+
+Zuordnung: 1=nehmen, 2/3=links, 4/5=rechts, 6 trinken
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ nehmen  trinken  links  rechts  schieben           jrg 03feb89
+
+: nehmen   bright ." ein Glas nehmen"        normal  2 spaces ;
+: trinken  bright ." alle Gläser austrinken" normal  2 spaces ;
+: links    bright ." ein Glas nach LINKS"    normal  2 spaces ;
+: rechts   bright ." ein Glas nach RECHTS"   normal  2 spaces ;
+
+: schieben  ;
+
+
+: Anfrage      ." Sollen Sie nehmen, trinken oder schieben? "
+               cr ." Bitte Ihre Augenzahl und <cr> : "   ;
+
+: Glückwunsch  cr ." Viel Glück beim nächsten Wurf ... " ;
+
+cr .( Sprüche geladen )
+
+\ *** Block No. 2, Hexblock 2
+
+\ Auswertung mit IF...THEN / ENDIF                   jrg 03feb89
+
+' THEN Alias ENDIF  immediate restrict
+
+: Auswertung  ( 1<= Wurfergebnis <=6  -- )
+
+     dup 1 = IF nehmen          ENDIF
+     dup 2 = IF links  schieben ENDIF
+     dup 3 = IF links  schieben ENDIF
+     dup 4 = IF rechts schieben ENDIF
+     dup 5 = IF rechts schieben ENDIF
+     dup 6 = IF trinken         ENDIF
+
+     1 6 between not  IF invers ." Betrug!" normal ENDIF
+;
+
+
+\ *** Block No. 3, Hexblock 3
+
+\ =or                                                jrg 06okt88
+
+  code =or       ( n1 f1 n2 -- n1 f2 )
+     A D xchg  D pop
+     S W mov
+       W ) A cmp
+       0= ?[ -1 # D mov ]?
+    next
+  end-code
+
+\ : =or  ( n1 f1 n2 -- n1 f2 )  2 pick = or ;
+
+
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+\  Auswertung mit IF...THEN  und =or                 jrg 06okt88
+
+: Auswertung  ( 1<= Wurfergebnis <=6  -- )
+     dup
+     1 6 between IF
+                  dup 1 =       IF  nehmen   ENDIF
+                  dup 6 =       IF  trinken  ENDIF
+                  dup 2 = 3 =or IF  links    ENDIF
+                  dup 4 = 5 =or IF  rechts   ENDIF
+                 ELSE
+                  invers ." Betrugsversuch" normal
+                 ENDIF
+     drop
+;
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ CASE   OF  ENDOF   END-CASE     BREAK              jrg 30mai89
+
+ : CASE      ( n -- n n )  dup ;  restrict
+
+ : OF        [compile] IF compile drop ;  immediate restrict
+
+ : ENDOF     [compile] ELSE 4+ ;  immediate restrict
+
+ : ENDCASE   compile drop
+             BEGIN
+               3 case?
+             WHILE
+               >resolve
+             REPEAT ;  immediate restrict
+
+ : BREAK     compile exit  [compile] THEN ;  immediate restrict
+
+\ *** Block No. 6, Hexblock 6
+
+\  Auswerten mit CASE OF ENDOF ENDCASE              jjrg 05feb89
+
+: Auswertung  ( 1<= n <=6  -- )
+
+    dup  1 6 between  not IF ." Betrug" drop exit ENDIF
+
+    CASE 1 =  OF nehmen  ENDOF
+    CASE 6 =  OF trinken ENDOF
+    CASE 4 <  OF links   ENDOF
+    CASE 3 >  OF rechts  ENDOF
+    ENDCASE
+;
+
+
+
+\ Man beachte die Stellung der Plausibilitätsprüfung
+
+\ *** Block No. 7, Hexblock 7
+
+\  Auswerten mit =or und BREAK                       jrg 05feb89
+
+: Auswertung  ( 1<= n <=6  -- )
+
+    CASE 1 =        OF  nehmen    BREAK
+    CASE 2 = 3 =or  OF  links     BREAK
+    CASE 4 = 5 =or  OF  rechts    BREAK
+    CASE 6 =        OF  trinken   BREAK
+    ENDCASE
+
+  invers ." Betrugsversuch" normal
+;
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ Das CRAPS Programm wie in PASCAL etc.              jrg 07okt88
+
+: CRAPS
+
+    cr  Anfrage cr
+
+          input#
+          Auswertung
+
+    cr  Glückwunsch
+;
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ ------------- VECTOR EXECUTION --------------------jrg 07okt88
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\  4TH braucht Prozeduren                            jrg 05feb89
+
+
+: bewegen  ( adr n -- cfa )
+    2* +  perform ;
+
+: richtig  ( n  --  0<= n <= 3 )
+    swap
+    1 max  6 min                        \ ein bißchen Sicherheit
+    3 case? IF  2  1- exit  ENDIF
+    5 case? IF  4  1- exit  ENDIF
+    1-  ;                               \ ein bißchen Justage
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+\  Die möglichen Bewegungen mit  ] [  oder Create:   jrg 05feb89
+
+Create  Glas
+        ]  nehmen  links schieben
+                   rechts schieben  trinken  [
+
+
+\ oder:
+
+Create: Glas
+         nehmen
+         links schieben
+         rechts schieben
+         trinken ;
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\  Create: ; :Does>                                  jrg 05feb89
+
+Create: Auswertung
+          nehmen
+           links schieben
+           rechts schieben
+          trinken ;
+      :Does>
+         richtig bewegen ;
+
+
+
+
+
+
+
+
+\ *** Block No. 13, Hexblock d
+
+\  Das vollständige Programm                         jrg 05feb89
+
+: CRAPS
+     cr  Anfrage cr
+           input#
+           Glas richtig bewegen
+     cr  Glückwunsch
+;
+
+\ ausschließlich als Datenstruktur
+: CRAPS
+     cr  Anfrage cr
+           input#
+           Auswertung
+     cr  Glückwunsch
+;
+
+\ *** Block No. 14, Hexblock e
+
+\ #### positional CASE def.words  Case: Associative: jrg 01feb89
+: Case:     ( -- )
+   Create:
+   Does>    ( pfa -- )  swap 2* +  perform ;
+
+: Associative:           ( n -- )
+   Constant   Does>      ( n - index )
+   dup @ -rot
+   dup @ 0
+   DO  2+  2dup  @ =
+       IF  2drop drop  I  0 0  LEAVE  THEN
+   LOOP 2drop ;
+
+\ alternative Definition für CASE:
+  : Case:
+      :  Does>   ( pfa -- )  swap 2* +  perform ;
+
+\ *** Block No. 15, Hexblock f
+
+\  CASE: in der Anwendung                            jrg 01feb89
+
+         Case:  bewegen                   \ besteht aus :
+                   nehmen
+                    links  links
+                    rechts rechts
+                   trinken ;
+
+
+6 Associative:  auswerten
+
+                  1 ,
+                2 , 3 ,
+                4 , 5 ,
+                  6 ,
+
+
+\ *** Block No. 16, Hexblock 10
+
+\  CASE:  und  Associative:                          jrg 01feb89
+
+: CRAPS   ( -- )
+
+     cr  Anfrage cr
+         input#
+            auswerten
+            bewegen
+     cr  Glückwunsch
+;
+
+
+
+
+
+
+
+\ *** Block No. 17, Hexblock 11
+
+************* Beginn der Kommentare *****************jrg 07okt88
+
+
+
+
+
+
+SCHIEBEN   gefällt mir deshalb so gut, weil es vorher nur als
+           Füllsel arbeitet, aber hinterher als Dummy in der
+           Tabelle die wichtige Funktion hat, sechs mögliche
+           Würfe sauber abzuarbeiten.
+
+
+
+
+
+
+\ *** Block No. 18, Hexblock 12
+
+\\ Auswertung mit IF...THEN / ENDIF                  jrg 01feb89
+
+ENDIF  macht deutlich(er), warum FORTH ohne Verbundanweisung wie
+       z.B. PASCAL auskommt.
+AUSWERTUNG führt entsprechend einem Selektor genau eine von 6
+       möglichen Prozeduren aus.
+
+Auch eine mögliche Form der Auswertung mit CASE? :
+: Auswertung  ( 1<= Wurfergebnis <=6  -- )
+      1 case? IF nehmen           exit ENDIF
+      2 case? IF links  schieben  exit ENDIF
+      3 case? IF links  schieben  exit ENDIF
+      4 case? IF rechts schieben  exit ENDIF
+      5 case? IF rechts schieben  exit ENDIF
+      6 case? IF trinken          exit ENDIF
+  1 6 between not  IF invers ." Betrugsversuch" normal ENDIF ;
+
+\ *** Block No. 19, Hexblock 13
+
+\\ hilfreiche Prozeduren für das kommende CASE
+
+=OR     prüft eine Zahl n2 auf Gleichheit mit einem Testwert n1
+        und verknüpft resultierende Ergebnis mit einem bereits
+        vorliegenden flag f1. Es werden das neue flag f2 und der
+        "alte" Testwert n1 übergeben.
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 20, Hexblock 14
+
+\\ bedingte Verzweigung mit IF .. ELSE .. ENDIF
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 21, Hexblock 15
+
+\\ Die Definitionen für die CASE Anweisung           jrg 07okt88
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+BREAK   ist ein EXIT aus der CASE-Anweisung; return to caller
+
+\ *** Block No. 22, Hexblock 16
+
+\\ Auswertung mit CASE OF ENDOF
+
+
+
+Sicherheit gegen falsche Zahlen
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 23, Hexblock 17
+
+\\ Die elegantere Auswertung mit BREAK               jrg 07okt88
+
+BREAK  = Verlassen des Callee
+
+
+
+
+
+
+
+Wird trotz BREAK dieser Prozedurteil erreicht, muß die Zahl un-
+gültig gewesen sein.
+
+
+
+
+
+\ *** Block No. 24, Hexblock 18
+
+                                                     jrg 07okt88
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 25, Hexblock 19
+
+\ Ui jui jui / Test für ein CRAPS
+
+  : Test
+      full page
+      20 0 DO
+            craps
+           LOOP ;
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 26, Hexblock 1a
+
+\\ Für Datenobjekte sind Prozeduren notwendig
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 27, Hexblock 1b
+
+\\ Was sind denn die Datenobjekte ?                  jrg 07okt88
+
+GLAS    als Datenteil enthält natürlich die in Frage kommenden
+        Prozeduren.
+
+
+
+
+GLAS    ist der gleiche Datenteil wie oben, nur eleganter.
+
+
+
+
+
+
+
+
+\ *** Block No. 28, Hexblock 1c
+
+\\ Zusammenfassen des Datenteils und des Zugriffsteiljrg 07okt88
+
+
+
+
+
+
+
+RICHTIG und BEWEGEN sind die eigens für den Datenteil GLAS ent-
+        worfenen Zugriffsprozeduren. Deshalb bietet es sich an,
+        diese mit GLAS zusammenzufügen.
+
+
+
+
+
+
+\ *** Block No. 29, Hexblock 1d
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 30, Hexblock 1e
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 31, Hexblock 1f
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 32, Hexblock 20
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

sources/generic/case/eaker.fth

@@ -0,0 +1,171 @@
+
+\ *** Block No. 0, Hexblock 0
+
+* EAKER - CASE für volks4th83  von Heinz Schnitter **jrg 01feb89
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\ Vorwärtsreferenzen als verkettete Liste       ( 06.jrg 01feb89
+| variable caselist
+
+| : initlist    ( list -- addr )
+                dup @ swap off
+  ;
+
+| : >marklist   ( list -- )
+                here over @ , swap !
+  ;
+
+| : >resolvelist ( addr list -- )
+                BEGIN dup @
+                WHILE dup dup @ dup @ rot ! >resolve
+                REPEAT !
+  ;
+
+\ *** Block No. 2, Hexblock 2
+
+\ CASE  ELSECASE  ENDCASE                       ( 09.jrg 01feb89
+
+: CASE          caselist initlist 4
+; immediate restrict
+
+
+: ELSECASE      4 ?pairs
+                compile drop 6
+; immediate restrict
+
+
+: ENDCASE       dup 4 =
+                IF   drop compile drop
+                ELSE 6 ?pairs
+                THEN caselist >resolvelist
+; immediate restrict
+
+\ *** Block No. 3, Hexblock 3
+
+\ OF  ENDOF  Control                            ( 09.jrg 01feb89
+: OF            4 ?pairs
+                compile over
+                compile =
+                compile ?branch
+                >mark compile drop 5
+; immediate restrict
+
+: ENDOF         5 ?pairs
+                compile branch
+                caselist >marklist
+                >resolve 4
+; immediate restrict
+
+: Control       bl word 1+ c@ $bf and state @
+                IF [compile] Literal THEN ; immediate
+
+\ *** Block No. 4, Hexblock 4
+
+\ Test                                          ( 09.jrg 01feb89
+: test
+  ." exit mit ctrl x" cr
+  BEGIN key
+        CASE control A OF ." action ^a " cr false ENDOF
+             control B OF ." action ^b " cr false ENDOF
+             control C OF ." action ^c " cr false ENDOF
+             control D OF ." action ^d " cr false ENDOF
+             control X OF ." exit "         true  ENDOF
+        ELSECASE
+                   ." befehl unbekannt " cr false
+        ENDCASE
+  UNTIL
+;
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+\ nehmen  trinken  links  rechts  schieben           jrg 01feb89
+
+: nehmen   bright ." ein Glas nehmen"        normal  2 spaces ;
+: trinken  bright ." alle Gläser austrinken" normal  2 spaces ;
+: links    bright ." ein Glas nach LINKS"    normal  2 spaces ;
+: rechts   bright ." ein Glas nach RECHTS"   normal  2 spaces ;
+
+: schieben  ;
+
+
+: Anfrage  ." Sollen Sie nehmen, trinken oder schieben? "
+       cr  ." Bitte Ihre Augenzahl und <cr> : "   ;
+
+: Glückwunsch  ." Viel Glück beim nächsten Wurf ... " ;
+
+cr .( Sprüche geladen )
+
+\ *** Block No. 6, Hexblock 6
+
+\  Auswerten mit CASE OF ENDOF END-CASE              jrg 01feb89
+
+: Auswertung  ( 1<= n <=6  -- )
+
+    CASE 1  OF nehmen  ENDOF
+         6  OF trinken ENDOF
+         4  OF links   ENDOF
+         5  OF links   ENDOF
+         2  OF rechts  ENDOF
+         3  OF rechts  ENDOF
+    ELSECASE
+         ." Betrug! "
+    ENDCASE
+;
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+\ Das CRAPS Programm wie in PASCAL etc.              jrg 07okt88
+
+: CRAPS
+
+    cr  Anfrage cr
+
+          input#
+          Auswertung
+
+    cr  Glückwunsch
+;
+
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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                         <del> und <-
+  Zeile löschen                           <esc>
+  Einfügen an aus                         <ins>
+  Zeile abschließen                       <enter>
+  Anfang/Ende der Zeile                   <pos1> <end>
+  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 @ ;
+
+| : <start ( a1 p1 -- a2  p2 )  at?  rot - at  0 ;
+
+\ *** Block No. 5, Hexblock 5
+
+\ Tastenbelegung für Zeilen-Editor MS/DOS         ks jrg 19dez89
+
+: (decode ( addr pos1 key -- addr pos2 )
+  -&77  case? IF dup  span @ < 0=exit  currite 1+   exit THEN
+  -&75  case? IF dup           0=exit  curleft 1-   exit THEN
+  -&82  case? IF cinsert @     0=      cinsert !    exit THEN
+   #bs  case? IF dup           0=exit  back         exit THEN
+  -&83  case? IF span @ 2dup < and 0=exit delete    exit THEN
+  -&72  case? IF -1 line# +line recall              exit THEN
+  -&80  case? IF  1 line# +line recall              exit THEN
+   #cr  case? IF done                               exit THEN
+   #esc case? IF <start span off  2dup redisplay    exit THEN
+  -&71  case? IF <start                             exit THEN
+  -&79  case? IF at? rot -  span @ +  at  span @    exit THEN
+   dup emit >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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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# ! ;
+| : <cr>   #after c ;
+| : <line ( -- )   col# negate c  'line c/l -trailing nip 0=exit
+      BEGIN 'cursor c@ bl = WHILE curright REPEAT ;
+| : line> ( -- )   '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#  <cr> insert-spaces  r# !
+     #after insert-spaces  screenmodified ;
+
+| : delete-characters ( n -- ) 'cursor #remaining rot delete ;
+
+| : join ( -- ) cursor <cr>  line> col#  <line col# under -
+     rot r# ! #after > Abort" next line will not fit!"
+     #after +  dup delete-characters
+     cursor  <cr> 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>  )
+<cr>            +tab            -tab
+top             >""end          "replace        undo
+update-exit     flushed-exit    showload        >shadow
+n               b               a               mark
+<line           line>           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
+
+
+
+
+
+