UMFORTH@WEIZMANN.BITNET (F.I.G.I.L.) (06/30/86)
Date: Tue, 24-JUN-1986 11:20 EST
Original_From: CIDE::ONEEL(Bruce O'Neel (301)-286-4001 bitnet bruce@uc780)
Comments: This is gatewayed mail. Warning: Mail may not
necessarily be returnable through this path.
From: General Delivery <POSTMASTER@UC780>
Subject: prolog in forth 83
Here is Ting's prolog in forth. It is in Laxon's and Perry's F83
(almost a genaric forth 83). The doc file is first
Prolog.doc80
============
Text file describing Prolog interpeter in PROLOG.SCR. 15dec85chtList it with DOS
..20
.20
C. H. Ting
San Mateo, California
..30
.30
Summary
Prolog is an interesting language with simple syntax structure.
It is rather straightforward to implement it in Forth. Since
most of the work in interpreting Prolog queries is string comparison,
the interpreter can be constructed by running two pointers,
one for the query string and the other for the data base.
This method thus eliminates the need to build data structures
according to the data types used in Prolog. In this paper,
only relations are allowed in the data base. Both the "does"
and "which" queries are implemented to use the data base.
Works to implement rules in data base is in progress.
..new
.new
..10
.10
Recently, an Artificial Modification Laboratory in the Silicon
Valley Fig Chapter. This FigAI group has had monthly meetings
to discuss various aspect of artificial intelligence and the
possibility in using Forth to do programming in this field.
A consensus was reached in the earlier meetings that Prolog
might be a worthy subject for us to study and to implement.
One reason was that the Japanese are doing it. The other reason
was that we felt it was something we could accomplish in a
relatively short time before the group fell apart.
Dr. S. Y. Tang has been guiding this project by giving tutorial
on logic programming and by implementing a version of Prolog
himself. His tutorial and the source code of the Prolog
implementation, called Forlog, were published recently in our
progress report 'FigAI Notes' (1).
Dr. Tang's Forlog allows one to compile Prolog relations and
rules either from disk or from terminal. During compilation,
data structures are built which contain information about various
data types used by Prolog, such as constants, integers, variables,
relations, and rules. The inference engine was built upon
data structures of goals and mechanism to carry out resolution
and relation proving tasks.
The program and structure of Dr. Tang's Forlog are very elaborate
and voluminous, as the source code spans more than 100 screens.
My feeling was that Prolog is a rather simple language and
there might be a simpler way to implement it or the most important
features in it. In casually observing the action of microProlog
(2), it is obvious that most of the work the inference engine
does is simple string comparison, left to right and depth first.
This kind of string comparison can be done by fetching words
sequentially from the query string and the data base as a giant
string, and comparing them. If the query sting matches with
a substring in the data base, the search is successful. Subsequent
action will then depend upon the type of query. If the query
string fails to match a substring in the data base, the search
and comparing will continue to the next substring until a match
is found or until the end of data base is reached. In the
latter case, the search failed and the failure condition will
be returned.
Using this string comparison strategy, the data base itself
is the data structure and we do not have to compile anything.
Only the inference engine, the string comparator and matcher
has to be implemented. A disadvantage is that the data base
has to be entered and stored in screens. Relations has to
be entered using a Forth editor. One cannot enter new relations
interactively as done in microProlog. At this stage of development,
only relations can be handled. Rules, with variables which
must be instantiated and uninstantiated as the inference engine
is running, are much too complicated to be implemented. However,
I don't see any fundamental difficulty to implement rules,
one just have to find a simple way to do the searching and
the resolution of variables.
In the following paragraphs, I shall briefly discuss the code
and some examples of this Prolog interpreter.
Screen 54 is the load screen which load the Prolog interpreter
which is capable of simulating the 'does' and 'which' queries
in microProlog.
Screen 55 contains a sample data base of the familiar Tudor
family tree. Since Prolog relations can be represented by
a sequence of words without intervening parentheses, the syntax
becomes very simple. It is not necessary to distinguish the
name of the relation and the constants involved in the relation.
Thus the father and mother relations do not need special notations
to distinguish them from the uniary relations as male and female.
Relations have to be separated by comma, and the data base
must be terminated by the word &. These syntax requirements
greatly reduce the burden of the Prolog interpreter, which
can then use tools available in the Forth interpreter to do
word parsing and comparing.
Screen 56 contains the goal string used in query. Sample query
sentences are:
does father henry8 edward .
does female anne .
which father henry8 *x .
which *x *y edward .
which female *x .
The query string after 'does' or 'which' is copies to Screen
56 before inference starts. Variables used in the 'which'
query must have '*' as its first character.
Screen 57 defines two pointers. QPOINTER is used to scan the
query string and DPOINTER is used to scan the data base. The
data base can be put in any consecutive sequence of screens.
The screen number of first data base screen must be stored
in the variable DATABASE. QBUFFER is a constant of 56, which
is the buffer containing the query string.
Screen 58 and 59 contain the first implementation of 'does'
query. QWORD parses out the next word in the query string,
starting at QPOINTER. After parsing, QPOINTER is pointing
to the blank character at the end of the parsed word.
DWORD parses out the next word in the data base, using DPOINTER
as the scanning pointer. FIND-DOT scans the data base from
where DPOINTER points to and place DPOINTER pointing after
the first dot (period) it finds. This initializes DPOINTER
to scan the next relation in the data base.
Screen 59 implements the 'does' query. The detailed action
in 'does' is explained in Screen 60. The basic sequence of
events is as follows: Parse out the next word in the query
string and compare it with the next word in the data base.
If these words are not the same, the query does not match the
relation currently under processing. Then comparison continues
to the next relation in the data base. If these two words
are the same, the comparison continues to the next pair of
words. If the next word in the query string is a dot, we have
reach the end of the query string and the comparison is successful,
and the affirmative answer 'yes' can be output to the terminal.
If the next word in the data base is '&', we have reached the
end of the data base without finding the relation specified
in the query, the negative message 'no' can now be printed
and the search terminated.
Screen 61 and 62 show the same 'does' query, only done using
recursive technique. It is anticipated that the searching
and querying will be done in a recursive fashion when the complete
Prolog inference engine will be implemented. At this time,
there is no difference between the two 'does' definitions.
Screen 63 to 65 implement the 'which' query, which contains
variable or wild card strings. A variable here must start
with the '*' character, and it matches any string in the data
base. Since we cannot anticipate the success of matching the
current relation with the entire query string, including the
wild card variables, we have to save the variable and the matching
word somewhere. Whenever a variable is encountered in the
query, the name of the variable and the matching word in the
data base is saved in the PAD buffer, with a pointer OPOINTER
update accordingly. These functions are performed by the word
..VARIABLE with its low level servent (.VAR). When a relation
.VARIABLE with its low level servent (.VAR). When a relation
is found to match the query string, the resolved variables
and their associated words in the data base are printed by
..ANSWER.
.ANSWER.
The 'which' loop is thus very similar to the 'does' loop in
Screen 62, with additional function in handling and printing
resolved variables.
In the last listing, I show some typical results using this
sample data base and the 'does' and 'which' interpreter. Words
typed by me are underscored. Since I treat the name of relation
the same as the arguments of a relation, as they are simply
strings as far as the interpreter is concerned, some very
interesting results can be obtained as shown in the last queries:
which *x *y edward .
which *x henry8 .
which *x *y .
The matching results shows that this syntax is more general
than Prolog's and can be more useful in obtaining meaningful
answers from the data base.
In conclusion, I hope that this Prolog interpreter demonstrates
that Forth is entirely adequate to simulate the function of
Prolog, as far as the 'does' and 'which' queries are concerned.
The Prolog syntax can also be simplified and its usefulness
can be generalized. The rules in Prolog is more complicated
because it will involve recursive searches through the data
base. If the rules can be handled conveniently, it is possible
to build a complete Prolog interpreter in Forth. This work
is in progress.
1. S. Y. Tang, Forlog -- Prolog in Forth, FigAI Notes, Offete
Enterprises, 1985, p. 10.
2. E. L. Clark, et al., A micro-Prolog Primer, Logic Programming
Associates, Ltd., 2nd Ed.
Prolog.scr80
============
Scr #0
0: F83 related experiments and studies by Dr. C. H. Ting 28nov85cht
1: Prolog, recursion, word statistics, documentation aids, etc.
2: ----------------------------------------------------------------
3: The contents of this disk is now placed in the public domain,
4: as a contribution to the disk library of the Silicon Valley
5: FIG Chapter, maintained by Mr. John Peters.
6:
7: I did not try to use shadow screens for documentation. Instead,
8: as much comments as appropriate were placed in-line with the
9: source code.
10:
11: Comments, improvements, bug lists, etc, are welcome. Please
12: send them to: Dr. C. H. Ting, 156 14th Ave., San Mateo, Ca.
13: 94402, or call (415) 571-7639 evenings.
14:
15:
Scr #1
0: \ Prolog Interpreter 14dec85cht
1: 4 LOAD ( buffers)
2: 8 9 THRU ( does)
3: 10 12 THRU ( which)
4: 13 LOAD ( where )
5: EXIT
6: 14 15 THRU ( prove)
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #2
0:
1: father henry7 henry8 .
2: father henry8 mary .
3: father henry8 elizabeth .
4: father henry8 edward .
5: mother elizabeth-of-york henry8 .
6: mother katherine mary .
7: mother ann elizabeth .
8: mother jane edward .
9: male henry7 . male henry8 . male edward .
10: female elizabeth . female elizabeth-of-york .
11: female katherine . female mary . female ann .
12: female jane .
13: &
14:
15:
Scr #3
0: father henry8 edward .
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #4
0: \ Parse Query and Database Words 14dec85cht
1: VARIABLE QPOINTER ( query text word pointer)
2: VARIABLE DPOINTER ( data base word pointer)
3: VARIABLE DATABASE 2 DATABASE ! ( first screen of file)
4: 3 CONSTANT QBUFFER ( query text buffer block)
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #5
0: \ Parse Query and Database Words 13oct85cht
1: : QWORD ( -- a #, parse out next word in query text)
2: >IN @ >R BLK @ >R QBUFFER BLK !
3: QPOINTER @ >IN ! 32 PARSE-WORD
4: >IN @ QPOINTER ! R> BLK ! R> >IN ! ;
5: : DWORD ( -- a #, parse out next word in data base)
6: >IN @ >R BLK @ >R BEGIN
7: DPOINTER @ 1024 /MOD DUP DATABASE @ + BLK ! SWAP >IN !
8: 32 PARSE-WORD ROT 1024 * >IN @ + DPOINTER !
9: DUP 0= WHILE 2DROP
10: REPEAT R> BLK ! R> >IN ! ;
11: : FIND-DOT ( -- f, true if find dot) >IN @ >R BLK @ >R
12: DPOINTER @ 1024 /MOD DUP DATABASE @ + BLK ! SWAP 1- >IN !
13: ASCII . PARSE-WORD 2DROP 1024 * >IN @ + DPOINTER !
14: >IN @ 1024 < R> BLK ! R> >IN ! ;
15:
Scr #6
0: \ does 13oct85cht
1: : does ( yes/no query)
2: QBUFFER BLOCK 1024 BLANK 0 DPOINTER ! 0 QPOINTER !
3: 1 WORD COUNT QBUFFER BLOCK SWAP CMOVE
4: BEGIN
5: QWORD 0= ABORT" query error"
6: DUP C@ ASCII . = ABORT" yes"
7: DWORD OVER C@ DUP ASCII & = ABORT" no"
8: ASCII . = IF -2 DPOINTER +!
9: OVER 20 - 20 CR TYPE ." dot error" THEN
10: COMP ( compare strings)
11: IF FIND-DOT 0= ABORT" file error"
12: 0 QPOINTER ! THEN
13: AGAIN ;
14:
15:
Scr #7
0: \ does quary 13oct85cht
1: does confirm the existance of next statement till 'dot'.
2: Accept query line and initialize query and data pointers.
3: BEGIN
4: Parse next word from input stream.
5: If it is 'dot', answer yes and exit.
6: Parse next word from data base.
7: If it is '$', answer no and exit. Failure.
8: If it is 'dot', format error. Continue.
9: Compare query word with data word,
10: If not same, reinitializa query word pointer to
11: the beginning of input stream and the data word pointer
12: to the next record in data file.
13: AGAIN Repeat until query is confirmed or data base exhaust-
14: ed.
15:
Scr #8
0: \ Parse Query and Database Words 02nov85cht
1: : QWORD ( p -- p' a #, parse out next word in query text)
2: >IN @ >R BLK @ >R QBUFFER BLK !
3: >IN ! BL PARSE-WORD
4: >IN @ -ROT R> BLK ! R> >IN ! ;
5: : DWORD ( p -- p' a #, parse out next word in data base)
6: >IN @ >R BLK @ >R BEGIN
7: 1024 /MOD DUP DATABASE @ + BLK ! SWAP >IN !
8: BL PARSE-WORD ROT 1024 * >IN @ + -ROT
9: DUP 0= WHILE 2DROP
10: REPEAT R> BLK ! R> >IN ! ;
11: : FIND-DOT ( p -- p' ) >IN @ >R BLK @ >R
12: 1024 /MOD DUP DATABASE @ + BLK ! SWAP >IN !
13: ASCII . PARSE 2DROP 1024 * >IN @ +
14: >IN @ 1024 = IF 2DROP ." file error" QUIT THEN
15: R> BLK ! R> >IN ! ;
Scr #9
0: \ does 01nov85cht
1: : (does) ( dp qp -- f, yes/no query)
2: QWORD 0= ABORT" query error"
3: DUP C@ ASCII . = IF 2DROP DROP 1 EXIT THEN
4: ROT DWORD OVER
5: C@ DUP ASCII & = IF 2DROP 2DROP 2DROP 0 EXIT THEN
6: ASCII . = IF ROT 2- -ROT THEN
7: ROT >R COMP R> SWAP
8: IF FIND-DOT NIP 0 ELSE SWAP THEN
9: RECURSE ;
10: : does QBUFFER BLOCK 1024 BLANK
11: 1 WORD COUNT QBUFFER BLOCK SWAP CMOVE
12: 0 0 (does) IF ." yes" ELSE ." no" THEN ;
13:
14:
15:
Scr #10
0: \ which 02nov85cht
1: VARIABLE OPOINTER ( output string pointer)
2: : .CHAR ( c -- , output to buffer)
3: OPOINTER @ C! 1 OPOINTER +! ;
4: : ."=" BL .CHAR ASCII = .CHAR BL .CHAR ;
5: : .BLS BL .CHAR BL .CHAR BL .CHAR ;
6: : (.VAR) ( a # -- , output a string)
7: >R OPOINTER @ R@ CMOVE R> OPOINTER +! ;
8: : .VARIABLE ( dp qp a # -- dp' qp , output variable)
9: .BLS (.VAR) ."=" SWAP DWORD
10: OVER C@ ASCII & = IF CR ." no more answers" 2DROP DROP
11: QUIT ELSE (.VAR) SWAP THEN ;
12: : .ANSWER ( print findings from output buffer)
13: PAD OPOINTER @ OVER - CR TYPE PAD OPOINTER ! ;
14: : .END ( end of messages)
15: CR ." no more answers" ;
Scr #11
0: \ which 01nov85cht
1: : (which) ( dp qp -- )
2: QWORD DUP 0= ABORT" query error"
3: OVER C@ ASCII * =
4: IF .VARIABLE RECURSE EXIT ELSE DROP THEN
5: DUP C@ ASCII . =
6: IF 2DROP FIND-DOT 0 .ANSWER RECURSE EXIT THEN
7: ROT DWORD OVER
8: C@ DUP ASCII & = IF 2DROP 2DROP 2DROP .END EXIT THEN
9: ASCII . = IF ROT 2- -ROT THEN
10: ROT >R COMP R> SWAP
11: IF FIND-DOT NIP 0 PAD OPOINTER ! ELSE SWAP THEN
12: RECURSE ;
13:
14:
15:
Scr #12
0: \ which 01nov85cht
1: : which PAD OPOINTER ! QBUFFER BLOCK 1024 BLANK
2: 1 WORD COUNT QBUFFER BLOCK SWAP CMOVE
3: 0 0 (which) ;
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #13
0: \ where 06nov85cht
1: : (where) ( qp dp qp' dp' -- qp dp", -1 if failed)
2: SWAP DWORD DUP 0= ABORT" query error"
3: OVER C@ ASCII . = IF 2DROP 2DROP EXIT THEN
4: >R ROT DWORD ( qp dp qp" p1 dp" p2 #2 )
5: OVER C@ DUP ASCII & =
6: IF 2DROP 2DROP 2DROP R> 2DROP -1 EXIT THEN
7: ASCII . =
8: IF 2DROP >R 2DROP 2DROP R> R> DROP 2DUP RECURSE EXIT THEN
9: R> OVER = IF
10: ROT >R COMP R> SWAP ( qp dp qp" dp" f)
11: IF FIND-DOT >R 2DROP R> 2DUP THEN
12: ELSE 2DROP FIND-DOT >R 2DROP DROP R> 2DUP THEN
13: RECURSE ;
14: \ Uses a sentence in the database as template for searching.
15: \ does female ann . 1024 0 1024 0 (where) .s
Scr #14
0: \ prove 09nov85cht
1: : (prove) ( qp dp --- f, prove a proposition)
2: OVER DWORD ROT DROP ROT ( qp p1 #1 dp )
3: BEGIN DWORD ( qp p1 #1 dp' p2 #2 )
4: OVER C@ ASCII & = IF 2DROP 2DROP 2DROP FALSE EXIT THEN
5: ROT >R 2OVER ROT OVER ( qp p1 #1 p2 p1 #1 #2 #1 )
6: = IF COMP R> SWAP ( qp p1 #1 dp' f )
7: 0= IF DWORD ( qp p1 #1 dp" p3 #3 )
8: DROP C@ DUP ASCII . =
9: IF 2DROP 2DROP DROP TRUE EXIT THEN
10: ASCII , = IF DUP 0 RECURSE ( qp p1 #1 dp" f )
11: IF 2DROP 2DROP TRUE EXIT THEN
12: THEN THEN
13: ELSE 2DROP R> DROP THEN
14: ( qp p1 #1 dp" ) FIND-DOT
15: AGAIN ;
Scr #15
0: \ prove 14dec85cht
1: : prove
2: 18 BLOCK 1024 BLANK
3: 1 WORD COUNT 18 BLOCK SWAP CMOVE
4: 1024 0 (prove)
5: IF ." true" ELSE ." false" THEN
6: ;
7: 17 DATABASE !
8:
9:
10:
11:
12:
13:
14:
15:
Scr #16
0: \ prove 09nov85cht
1: : prove ( qp dp --- f )
2: Get next word from qp
3: BEGIN
4: Get next word from dp
5: If it is '&', return FALSE and EXIT.
6: Does the two word match?
7: IF Get next word from dp'
8: If it is '.', return TRUE and EXIT.
9: If it is ',', prove the next word.
10: IF next word is true, return TRUE and EXIT.
11: ELSE try the next sentence
12: (Restore qp, move dp to next sentence)
13: THEN
14: AGAIN ;
15:
Scr #17
0: a , b , c . 14dec85cht
1: b , d , f .
2: b , e , f .
3: c , g .
4: e , g .
5: f , h .
6: g .
7: h .
8: &
9:
10:
11:
12:
13:
14:
15:
z POSTMAST UC780 6/24/86
' General Delivery umforth@weizmann 6/24/86 prolog in forth 83
========================================================================
Date: Tue, 24-JUN-1986 11:23 EST
From: <BRUCE@UC780>
Subject: Brodie's text formatter in forth83
To: umforth@weizmann
Original_To: BITNET%"umforth@weizmann",BRUCE
This is Leo Brodie's Text formatter written in Forth 83.
Scr #0
0: Quick Text Formatter by Leo Brodie FD 4, #3 & 4 26MAR85JAP
1: Not converted from the 79 version yet. 12dec84
2: ****************************************************************
3: ****************************************************************
4: ** **
5: ** installed by: **
6: ** Keith Manning written by Leo Brodie **
7: ** 667 E. 1750 N. FORTH Dimensions **
8: ** Ogden, Ut. 84404 vol. IV #3 and 4 **
9: ** **
10: ****************************************************************
11: ****************************************************************
12:
13:
14:
15:
Scr #1
0: \ QTF load scr 25DEC84KHM
1:
2: DOS DEFINITIONS
3:
4: WARNING OFF
5:
6: \ FENCE OFF FORGET FUDGE
7:
8: .( Loading qtf extensions)
9: 2 5 THRU \ QTF Formatter blocks
10: 8 26 THRU \ Screen editor blocks
11:
12: : GREET CR ." Quick Text Formatter "
13: CR ." Version 1.00 1984 " DOS ;
14: ' GREET IS BOOT
15:
Scr #2
0: \ Quick Text Formatter 01JAN85KHM
1: : FORMFEED 12 EMIT ; ( <-- write code for your own printer )
2: 78 CONSTANT PAPER ( 80-column width)
3: ( left, right, top and bottom margins )
4: 10 CONSTANT LMARGIN PAPER 10 - CONSTANT RMARGIN
5: 6 CONSTANT TMARGIN 55 CONSTANT BMARGIN
6: VARIABLE DELIMITER ( current delimiter character)
7: VARIABLE XTRA ( amount to indent on auto cr's)
8: VARIABLE ACROSS ( horizontal position ; absolute)
9: VARIABLE DOWNWARD ( vertical position ; absolute)
10: : SKIP ( n) DUP ACROSS +! SPACES ;
11: : \line ( begin new line at appropriate left margin)
12: 0 ACROSS ! CR 1 DOWNWARD +! LMARGIN XTRA @ + SKIP ;
13: : print ( -- ) PRINTING ON LOAD PRINTING OFF ;
14: \ print Send formatted text to printer.
15:
Scr #3
0: \ Quick Text Formatter 12DEC84KHM
1: : start ( begin page at top margin; use at start of document)
2: 0 DOWNWARD ! TMARGIN 0 DO \line LOOP ;
3: : newpage ( begin next page) CR FORMFEED start ;
4: : cr ( begin next line; if at bottom, start new page)
5: DOWNWARD @ BMARGIN > IF newpage ELSE \line THEN ;
6: : crs ( # of crs -- ) 0 DO cr LOOP ;
7: : pp ( start new paragraph) cr cr ;
8: : tab ( n) ( skip to position "n", relative to left margin)
9: ACROSS @ LMARGIN - - 1 MAX SKIP ;
10: : indent ( n) ( tab and reset left margin, until next delim.)
11: DUP XTRA ! tab ;
12: : hang-ind ( n) ( indent; subsequent lines indent 3 more)
13: DUP tab 3 + XTRA ! ;
14:
15:
Scr #4
0: \ Text Formatter 12DEC84KHM
1: : ?NEAR ( -- true: near right) ACROSS @ RMARGIN > ;
2: : ?WRAP ( -- true: at very edge) ACROSS @ PAPER = ;
3: : LETTER ( -- current char.) BLK @ BLOCK >IN @ + C@ ;
4: : FLUSH-LEFT ( after a cr, don't output a 2nd blank)
5: cr LETTER BL = IF 1 >IN +! THEN ;
6: : PARSE ( c) ( display text to delimiter "c" within margin)
7: DELIMITER ! BEGIN LETTER 1 >IN +! DUP
8: DELIMITER @ = >IN @ 1023 = OR 0= WHILE DUP EMIT
9: 1 ACROSS +! BL = ?WRAP OR IF ?NEAR IF FLUSH-LEFT
10: THEN THEN REPEAT DROP 0 XTRA ! ;
11: : [ ASCII ] PARSE ;
12: : { ASCII } PARSE ;
13:
14:
15:
Scr #5
0: \ Text Formatter Extensions 12DEC84KHM
1: : sub cr 5 hang-ind ;
2: : subsub cr 10 hang-ind ;
3: : center[ ( center between margins) >IN @ RMARGIN LMARGIN
4: - 5 + ASCII ] WORD C@ - 2/ tab >IN ! [ ;
5: : r[ ( n) ( right justify in field "n" wide) >IN @ SWAP
6: ASCII ] WORD C@ - 0 MAX SKIP >IN ! [ ;
7: : load LOAD ;
8:
9:
10:
11:
12:
13:
14:
15:
Scr #6
0: \S QTF expansions 05DEC84KHM
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #7
0: \S QTF expansions 05DEC84KHM
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #8
0: \ Quick Text Formatter By Leo Brodie 06DEC84KHM
1: ( System dependent words)
2: DEFER PAGE DEFER CLR->LN
3: DEFER CLR->SCR DEFER XY
4:
5: : BOTTOM 0 20 XY CLR->LN ;
6: : .MODE 65 1 XY CLR->LN ;
7: 13 CONSTANT RETURN ( value KEY returns when <return> pressed)
8: \ : ', [COMPILE] ' , ; ( 79 Standard)
9: \ : ', [COMPILE] ' CFA , ; ( fig VERSION)
10: : ', ' , ; ( Starting FORTH)
11:
12: : T ( -- tf ) TRUE ;
13: : F ( -- ff ) FALSE ;
14:
15:
Scr #9
0: \ VARIABLES & CONSTANTS 12DEC84KHM
1: 78 CONSTANT WIDE 55 CONSTANT NEAR-RIGHT
2:
3: 2 CONSTANT ENTERING 4 CONSTANT REPLACING
4: 6 CONSTANT DELETING 8 CONSTANT COMMAND
5: VARIABLE MODE ( command, enter, replace or delete)
6: 4 2* CONSTANT #MODES ( number of modes, in bytes)
7: 32767 CONSTANT MOOT ( impossible # of shifts to accomodate)
8: VARIABLE XCUR VARIABLE YCUR
9: VARIABLE TALLY ( count of chars entered)
10: 19 CONSTANT #LINES
11: CREATE EDGES 4 #LINES 1+ * ALLOT ( table of right edges: )
12: ( xcursor-pos, r#, for each line. )
13:
14:
15:
Scr #10
0: \ VARIABLES & CONSTANTS 12DEC84KHM
1: CREATE xHOLDING 1026 ALLOT ( delete buffer: cell 0 = count )
2: VARIABLE #KEY ( latest key entered)
3: VARIABLE ?ESC ( true for escape from outer loop)
4: CREATE OLDPOS 6 ALLOT ( ycurs xcurs r#)
5: VARIABLE REALIGN ( true = need to realign in replace mode)
6: VARIABLE DONE ( true = stop REWRITE)
7: VARIABLE SHIFTS ( # to adjust table r#s in SET-REST)
8: VARIABLE LENGTH ( # of writable chars.)
9: VARIABLE RIGHT ( current right margin)
10:
11:
12:
13:
14:
15:
Scr #11
0: \ Precursors 12DEC84KHM
1: : BUFF ( -- adr: beg. of buffer) SCR @ BLOCK ;
2: : CHARACTER ( -- adr: current pos. in buffer) BUFF R# @ + ;
3: : AT XCUR @ YCUR @ 2+ XY ;
4: : .CHAR AT CHARACTER C@ EMIT ;
5: : ROOM ( --n) 1024 R# @ - ;
6: : !OLDPOS ( save current cursor position)
7: XCUR @ YCUR @ OLDPOS 2! R# @ OLDPOS 4 + ! ;
8: : @OLDPOS ( restore previous cursor position)
9: OLDPOS DUP 2@ YCUR ! XCUR ! 4 + @ R# ! ;
10: : COMMAND! .MODE ." Command mode " COMMAND MODE ! AT ;
11: : RET ( drop to beg. of next line; let RCHAR know)
12: AT CLR->LN 1 YCUR +! 0 XCUR ! T REALIGN ! ;
13:
14:
15:
Scr #12
0: \ Cursor movements 12DEC84KHM
1: : EDGE ( -- adr) YCUR @ 2* 2* EDGES + ;
2: ( These words conform to preset edge table:)
3: : FORWARD R# @ LENGTH @ < IF 1 XCUR +!
4: XCUR @ EDGE @ > IF RET THEN 1 R# +! THEN ;
5: : BACKWARD R# @ IF XCUR @ 0= IF -1 YCUR +!
6: EDGE @ XCUR ! ELSE -1 XCUR +! THEN
7: -1 R# +! THEN ;
8: : UP/DOWN ( n) YCUR +! EDGE 2@ ( r# x) XCUR @ - DUP
9: 0< IF DROP EDGE @ XCUR ! ELSE - THEN R# ! ;
10: : UP YCUR @ 0 > IF -1 UP/DOWN THEN ;
11: : DOWN EDGE 4 + @ IF 1 UP/DOWN THEN ;
12:
13:
14:
15:
Scr #13
0: \ Maintain table of right edges 12DEC84KHM
1: : SET ( set both edge markers for this line in table; and
2: flag REWRITE to stop if shifts have been accomodated)
3: R# @ 1- XCUR @ 1- DUP EDGE @ - SHIFTS +!
4: SHIFTS @ 0= DONE ! EDGE 2! ;
5: : FIT ( go to next line, if necessary)
6: RIGHT @ XCUR @ < IF SET RET THEN ;
7: : ECHO ( c) ( display c; break line on blank or end of line)
8: DUP AT EMIT 1 XCUR +! 1 R# +! BL = XCUR @ WIDE = OR
9: IF FIT THEN ;
10: : ADJUST ( adjust r#'s in edge-table after x's fo t's)
11: YCUR @ #LINES OVER DO I YCUR ! EDGE @ IF EDGE 2+ @
12: TALLY @ - 1024 MIN EDGE 2+ ! THEN LOOP YCUR ! ;
13:
14:
15:
Scr #14
0: \ Maintain table of right edges 12DEC84KHM
1: : NO-MORE ( zero-out edge table from next line on down)
2: YCUR @ #LINES OVER 1+ DO I YCUR !
3: 0 0 EDGE 2! LOOP YCUR ! ;
4: : PATCH ( fix remainder of edge table, after actual REWRITE)
5: DONE @ IF ADJUST ELSE R# @ XCUR @ EDGE 2!
6: NO-MORE CLR->SCR THEN ;
7: : CHANGE ( n) ( pos. or neg. change in # characters)
8: DUP TALLY ! DUP SHIFTS ! NEGATE
9: LENGTH @ + 1024 2DUP MIN LENGTH ! / MOOT * SHIFTS +! ;
10: ( if length exceeds 1024, shifts are "moot")
11:
12:
13:
14:
15:
Scr #15
0: \ REWRITE 12DEC84KHM
1: : REWRITE ( display remainder of text)
2: !OLDPOS F DONE ! LENGTH @ DUP IF R# @ - ?DUP IF
3: 0 DO NEAR-RIGHT XCUR @ - DUP 0> IF
4: LENGTH @ R# @ - MIN AT CHARACTER OVER TYPE
5: DUP XCUR +! DUP R# +!
6: ELSE DROP CHARACTER C@ ECHO 1 THEN DONE @
7: IF LEAVE THEN +LOOP THEN
8: ELSE DROP .CHAR THEN PATCH ;
9:
10:
11:
12:
13:
14:
15:
Scr #16
0: \ Various Modes Setup 12DEC84KHM
1: : REATTACH ( source-buffer-adr)
2: DUP @ IF .MODE AT DUP 2+ CHARACTER ROT @ ROOM MIN CMOVE
3: REWRITE @OLDPOS AT ELSE DROP THEN COMMAND! ;
4: : HOME 0 R# ! 0 XCUR ! 0 YCUR ! ;
5: : --- BEEP ( bell) .CHAR ;
6: : ESCAPE ( leave outer loop) T ?ESC ! ;
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #17
0: \ Delete Mode 12DEC84KHM
1: : XCHAR ( delete one char.)
2: R# @ LENGTH @ < IF AT ASCII X EMIT FORWARD THEN ;
3: : X-ING ( begin delete mode) !OLDPOS R# @ TALLY ! XCHAR
4: DELETING MODE ! .MODE ." DELETE MODE " ;
5: : CLOSE-UP CHARACTER DUP TALLY @ -
6: DUP xHOLDING 2+ TALLY @ DUP xHOLDING ! CMOVE
7: ( save deleted) ROOM CMOVE ( close gap) ;
8: : BLANK->END ROOM @OLDPOS CHARACTER + TALLY @ BL FILL ;
9: : xSTOP ( exit delete mode)
10: R# @ TALLY @ - CHANGE CLOSE-UP BLANK->END AT SPACE
11: REWRITE @OLDPOS COMMAND! ;
12: : x< ( delete mode backspace) TALLY @ R# @ - IF
13: BACKWARD .CHAR AT ELSE T DONE ! xSTOP BACKWARD THEN ;
14:
15:
Scr #18
0: \ Replace Mode 12DEC84KHM
1: : REPLACE ( go into replace mode) REPLACING MODE ! 0 TALLY !
2: F REALIGN ! .MODE ." REPLACE MODE " ;
3: : RCHAR ( replace one char.)
4: R# @ LENGTH @ < IF #KEY @ DUP CHARACTER C! ECHO
5: REALIGN @ IF REWRITE @OLDPOS AT F REALIGN ! THEN THEN ;
6: : r< ( replace-mode backspace) BACKWARD .CHAR ;
7: : rSTOP ( exit replace)
8: 0 SHIFTS ! REWRITE @OLDPOS COMMAND! ;
9:
10: ( paren out this arrow to load Burst I/O version)
11:
12: ( 37 Load ( Busrt I/O version)
13:
14:
15:
Scr #19
0: \ Enter mode CONTINUOUS I/O VERSION 05DEC84KHM
1: : ENTER ( go into Enter)
2: R# @ 1024 < IF ENTERING MODE ! .MODE ." ENTERING MODE"
3: 0 TALLY ! THEN ;
4: : PATIENT RIGHT @ 1+ 77 MIN RIGHT ! EDGE @ 75 =
5: XCUR @ NEAR-RIGHT 5 + = OR IF NEAR-RIGHT RIGHT ! THEN ;
6: : ICHAR ( insert one char.) R# @ 1024 < IF CHARACTER DUP 1+
7: LENGTH @ 1023 MIN R# @ - CMOVE> #KEY @ DUP CHARACTER C!
8: -1 CHANGE ECHO R# @ LENGTH @ - IF PATIENT REWRITE @OLDPOS
9: THEN THEN ;
10: : eSTOP NEAR-RIGHT RIGHT ! 0 CHANGE REWRITE @OLDPOS
11: COMMAND! ;
12: : e< ( backspace in Enter mode) RIGHT @ 1- NEAR-RIGHT MAX
13: RIGHT ! R# @ IF BACKWARD AT SPACE CHARACTER DUP 1+ SWAP
14: LENGTH @ R# @ - CMOVE 1 CHANGE REWRITE @OLDPOS THEN ;
15:
Scr #20
0: \ Misc. functions 05DEC84KHM
1: : TAKE ( spread radr. of block; restore xHOLDING)
2: CHARACTER ( source) DUP xHOLDING @ + ( dest)
3: ROOM xHOLDING @ - ( count) DUP 0> IF CMOVE> ( spread)
4: ELSE 2DROP DROP THEN
5: xHOLDING @ NEGATE CHANGE xHOLDING REATTACH ;
6: : -HOME ( move to last non-blank char.)
7: LENGTH @ DUP R# ! #LINES 0 DO I YCUR ! DUP EDGE 2+ @ = IF
8: LEAVE THEN LOOP DROP EDGE @ XCUR ! ;
9: : CUTOFF ( erase to end)
10: CHARACTER xHOLDING 2+ LENGTH @ R# @ - DUP xHOLDING !
11: CMOVE CHARACTER ROOM BL FILL CLR->SCR
12: COMMAND! R# @ DUP LENGTH ! XCUR @ EDGE 2! NO-MORE ;
13:
14:
15:
Scr #21
0: \ Multiple-operation keys: 12DEC84KHM
1: 4 CONSTANT MULTIPLE
2: : BACKS MULTIPLE 0 DO BACKWARD LOOP ;
3: : FORWARDS MULTIPLE 0 DO FORWARD LOOP ;
4: : XCHARS MULTIPLE 0 DO XCHAR LOOP ;
5: : NEXTSCR 1 SCR +! ESCAPE ;
6: : BACKSCR -1 SCR +! ESCAPE ;
7:
8:
9:
10:
11:
12:
13:
14:
15:
Scr #22
0: \ Function matrix 05DEC84KHM
1: CREATE FUNCTIONS
2: ( E-mode R-mode X-mode Command)
3: 101 ( e) , ', ICHAR ', RCHAR ', --- ', ENTER
4: 120 ( x) , ', ICHAR ', RCHAR ', XCHAR ', X-ING
5: 105 ( i) , ', ICHAR ', RCHAR ', --- ', UP
6: 109 ( m) , ', ICHAR ', RCHAR ', --- ', DOWN
7: 106 ( j) , ', ICHAR ', RCHAR ', --- ', BACKWARD
8: 107 ( k) , ', ICHAR ', RCHAR ', --- ', FORWARD
9: 114 ( r) , ', ICHAR ', RCHAR ', --- ', REPLACE
10: 3 ( ^c) , ', --- ', --- ', --- ', CUTOFF
11: 8 ( del) , ', e< ', r< ', x< ', BACKWARD
12: 97 ( a) , ', ICHAR ', RCHAR ', --- ', HOME
13: 122 ( z) , ', ICHAR ', RCHAR ', --- ', -HOME
14:
15:
Scr #23
0: \ Function matrix cont'd 12DEC84KHM
1: 74 ( J) , ', ICHAR ', RCHAR ', --- ', BACKS
2: 75 ( K) , ', ICHAR ', RCHAR ', --- ', FORWARDS
3: 110 ( n) , ', ICHAR ', RCHAR ', --- ', NEXTSCR
4: 98 ( b) , ', ICHAR ', RCHAR ', --- ', BACKSCR
5: 116 ( t) , ', ICHAR ', RCHAR ', --- ', TAKE
6: 88 ( X) , ', ICHAR ', RCHAR ', XCHARS ', X-ING
7: RETURN , ', eSTOP ', rSTOP ', xSTOP ', ESCAPE
8: ( other) 0 , ', ICHAR ', RCHAR ', --- ', ---
9: HERE CONSTANT FUNCTIONS> ( end of FUNCTION table)
10:
11:
12:
13:
14:
15:
Scr #24
0: \ QTF Editor 06DEC84KHM
1: #MODES 2+ CONSTANT GROUP ( bytes in FUNCTIONS for each command)
2: FUNCTIONS> GROUP - CONSTANT 'NOMATCH
3: : FUNCTION ( key) 'NOMATCH SWAP
4: FUNCTIONS> FUNCTIONS DO DUP I @ = IF 2DROP I 0 LEAVE
5: ( replace nomatch adr w/ match) THEN GROUP +LOOP DROP
6: ( adr in table --) MODE @ + @ EXECUTE ;
7: : INIT MOOT SHIFTS ! BUFF 1024 -TRAILING LENGTH ! DROP
8: HOME NEAR-RIGHT RIGHT ! COMMAND! ;
9: : STAGE ( scr) PAGE DUP . SCR ! INIT ;
10: ( 36 LOAD ( snapshot debugger)
11: : (WRITE) ( scr) STAGE REWRITE NO-MORE F ?ESC !
12: BEGIN 75 19 XY LENGTH @ 4 .R AT KEY DUP #KEY !
13: FUNCTION ( SNAP ) ?ESC @ UNTIL UPDATE BOTTOM CR ;
14:
15:
Scr #25
0: \ QTF Editor 12DEC84KHM
1: : write ( scr ) ( enter editor)
2: BEGIN DUP (WRITE) SCR @ - ( n or b) WHILE
3: SCR @ REPEAT ( ." Saving on disk " FLUSH ( OPTIONAL ) ;
4: : w ( reenter editor) SCR @ write ;
5: : n SCR @ 1+ write ;
6: : b SCR @ 1- write ;
7: ( : index INDEX ; )
8: VARIABLE loadblock
9: : lb SCR @ loadblock @ (WRITE) write ;
10: ( terminal-specific commands -- write your own)
11: EXIT
12: ( : catch ( scr ) DUP SCR ! INIT CUTOFF HOLDING 2+
13: SWAP BLOCK HOLDING @ CMOVE n ; )
14:
15:
Scr #26
0: \ QTF System dependant definitions 26DEC84KHM
1: CODE (PAGE) 2 # AX MOV 16 INT NEXT C;
2: CODE (XY) ( col row --)
3: AX POP DX POP AL DH MOV BH BH XOR
4: 2 # AH MOV 16 INT NEXT C;
5: CODE 'XY ( -- col row) 3 # AH MOV 16 INT DH AL MOV
6: DH DH XOR AH AH XOR 2PUSH C;
7: CODE (SPACES) ( n --) BX BX XOR CX POP 10 # AH MOV
8: 32 # AL MOV 16 INT NEXT C;
9: : (CLR->LN) 'XY OVER 80 SWAP - (SPACES) XY ;
10: : (CLR->SCR) 'XY 2DUP 24 SWAP - 80 * SWAP
11: 80 SWAP - + (SPACES) XY ;
12: ' (PAGE) IS PAGE
13: ' (XY) IS XY
14: ' (CLR->LN) IS CLR->LN
15: ' (CLR->SCR) IS CLR->SCR
Scr #27
0:
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15: