mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-22 05:32:28 +00:00
Merge branch 'master' of https://github.com/forth-ev/VolksForth into v3.9.2
This commit is contained in:
commit
832f03b9ea
1
msdos/cursor/ced.fb
Normal file
1
msdos/cursor/ced.fb
Normal file
File diff suppressed because one or more lines are too long
27
msdos/cursor/cursor.txt
Normal file
27
msdos/cursor/cursor.txt
Normal file
@ -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.
|
||||
|
1
msdos/cursor/editor.fb
Normal file
1
msdos/cursor/editor.fb
Normal file
File diff suppressed because one or more lines are too long
228
sources/generic/case/case.4th
Normal file
228
sources/generic/case/case.4th
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
1
sources/generic/case/case.fb
Normal file
1
sources/generic/case/case.fb
Normal file
File diff suppressed because one or more lines are too long
1
sources/generic/case/casepos.fb
Normal file
1
sources/generic/case/casepos.fb
Normal file
File diff suppressed because one or more lines are too long
285
sources/generic/case/casepos.fth
Normal file
285
sources/generic/case/casepos.fth
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
1
sources/generic/case/casetru.fb
Normal file
1
sources/generic/case/casetru.fb
Normal file
File diff suppressed because one or more lines are too long
266
sources/generic/case/casetru.fth
Normal file
266
sources/generic/case/casetru.fth
Normal file
@ -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.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
1
sources/generic/case/craps.fb
Normal file
1
sources/generic/case/craps.fb
Normal file
File diff suppressed because one or more lines are too long
627
sources/generic/case/craps.fth
Normal file
627
sources/generic/case/craps.fth
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
1
sources/generic/case/eaker.fb
Normal file
1
sources/generic/case/eaker.fb
Normal file
File diff suppressed because one or more lines are too long
171
sources/generic/case/eaker.fth
Normal file
171
sources/generic/case/eaker.fth
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
171
sources/msdos/cursor/ced.fth
Normal file
171
sources/msdos/cursor/ced.fth
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
798
sources/msdos/cursor/editor.fth
Normal file
798
sources/msdos/cursor/editor.fth
Normal file
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user