1765 lines
46 KiB
Forth
Executable File
1765 lines
46 KiB
Forth
Executable File
\ lf v0.0.12f 06 August 2002 +
|
|
\ Leo Wong
|
|
\ hello@albany.net
|
|
\ http://www.albany.net/~hello/
|
|
|
|
\ I thank Wil Baden, Anton Ertl, Marcel Hendrix,
|
|
\ Benjamin Hoyt, Chris Jakeman, Bruce R. McFarling,
|
|
\ Barrie Stott, and Jonah Thomas for their help.
|
|
|
|
\ I am grateful to Chris Jakeman for pointing out
|
|
\ and correcting several mistakes.
|
|
|
|
\ LF is an NPBP (not pretty but portable) ANS Forth
|
|
\ word processor.
|
|
|
|
\ Portable means: designed to work in any ANS Forth
|
|
\ ("Standard") system that implements, can define, or can
|
|
\ provide the functionality of the ANS Forth words that LF
|
|
\ uses (see below for a list of these words). LF has a few
|
|
\ environmental dependencies that could be gotten rid of.
|
|
|
|
\ See also below the CONSTANTs that may need to be changed
|
|
\ for LF to work optimally on your system.
|
|
|
|
\ I have tested the NP part of LF. LF could easily become
|
|
\ quite comely though still austere. I await word on the BP
|
|
\ part. Please tell me if LF works or doesn't work on your
|
|
\ ANS Forth system.
|
|
|
|
\ I would also appreciate being notified of any bugs you find.
|
|
|
|
|
|
\ To start LF, load a Standard System, then enter:
|
|
\
|
|
\ INCLUDE LF.4TH ( S" LF.F" INCLUDED)
|
|
\
|
|
\ Enter a filename. You are now in text-entry mode. Enter
|
|
\ some text or press:
|
|
\
|
|
\ ``
|
|
\
|
|
\ that is, two single opening quotations marks, or glottal
|
|
\ stops, or left hands clapping to enter Command Mode. In
|
|
\ Command Mode, press:
|
|
\
|
|
\ q
|
|
\
|
|
\ to query the help screen.
|
|
\
|
|
\ The Enter, Backspace, and Tab keys work in both text-entry
|
|
\ and command modes.
|
|
|
|
\ I have not provided a printing function, not knowing how to
|
|
\ do so portably. I've provided some words to try if you can
|
|
\ teach your ANS Forth to print.
|
|
|
|
|
|
\ ANS Forth Documentation
|
|
\
|
|
\ LF uses ANS Forth words from the Core word set.
|
|
\
|
|
\ LF also uses words from other word sets. Though "required"
|
|
\ by LF, many of these words don't need to be in your Forth
|
|
\ system: they can be easily defined or their functionality
|
|
\ can be provided by other words. I believe that the only
|
|
\ real requirements are the Core word set and the abilities to
|
|
\ position the cursor and to read and write to mass storage.
|
|
\
|
|
\ Having said this, I say that:
|
|
\
|
|
\ LF is an ANS Forth Program
|
|
\
|
|
\ With environmental dependencies:
|
|
\ will respond to control characters 8, 9, and 13 though
|
|
\ the ability to receive control characters is not required
|
|
\ may be configured to send control character 7.
|
|
\ uses flags as arithmetic operands (I think it does)
|
|
\ uses two's complement arithmetic (maybe - I hope not)
|
|
\
|
|
\ Requiring from the Core Extensions word set:
|
|
\ 2>R 2R> <> ?DO CASE ENDCASE ENDOF ERASE FALSE MARKER
|
|
\ NIP OF PAD TO TRUE TUCK U.R UNUSED VALUE WITHIN \
|
|
\
|
|
\ Requiring from the Facility word set:
|
|
\ AT-XY PAGE
|
|
\
|
|
\ Requiring from the File-Access word set:
|
|
\ ( BIN CREATE-FILE FILE-SIZE INCLUDED OPEN-FILE
|
|
\ R/O READ-FILE S" W/O WRITE-FILE
|
|
\
|
|
\ Requiring from the String word set:
|
|
\ -TRAILING BLANK CMOVE CMOVE> SEARCH
|
|
\
|
|
\ Requiring the Memory-Allocation word set (if ALLOCATEing):
|
|
\ ALLOCATE FREE
|
|
\
|
|
\
|
|
\ LF requires keyboard input, the ability to position
|
|
\ the cursor, and access to mass storage in the form of
|
|
\ files.
|
|
\
|
|
\
|
|
\ A Standard System exists after LF is loaded.
|
|
|
|
\ ===================================================
|
|
\ Notes (by Krishna Myneni, 2002-09-06):
|
|
\
|
|
\ -- Line numbering may be turned off/on by setting the
|
|
\ constant LINE#-SPACE. Here, line numbers are turned off
|
|
\ by default.
|
|
\
|
|
\ -- The page length may be changed by setting the constant
|
|
\ MAX-Y. Here it is set to the original default of 23,
|
|
\ but I prefer to use a full page length (54 for MAX-Y).
|
|
\ Longer page lengths may be used in ANSI consoles with
|
|
\ a sufficient number of rows, for example a BASH shell
|
|
\ under X-Windows that has been resized to accomodate
|
|
\ the full text display. The cursor position will be
|
|
\ incorrect if the console does not support enough output
|
|
\ lines. MAX-Y of 23 should work on any console.
|
|
\
|
|
\ -- The constant 'CR has been changed from decimal 13 to 10,
|
|
\ since the LF character represents an end of line under
|
|
\ UNIX systems.
|
|
\
|
|
\ -- The constant EDIT-BUF-SIZE is 1 MB, suitable for most
|
|
\ day to day usage. Increase/decrease as desired.
|
|
\
|
|
\ ===================================================
|
|
\ Code modifications for the kForth version (KM 2002-08-13):
|
|
\
|
|
\ 1. Changed >FILE to BUF>FILE and FILE> to FILE>BUF.
|
|
\ 2. Modified BUF>FILE test for WRITE-FILE result.
|
|
\ 3. Recoded -TRAILING<> to remove WHILE ... THEN structure.
|
|
\ 4. Changed READ to READ-DOC and ?READ to ?READ-DOC.
|
|
\ 5. Changed CALL to CALL-WAY.
|
|
\ 6. VALUEs which are addresses have been changed to "ptr"s
|
|
\ 7. Remove use of HERE and "," and replace with equivalent code.
|
|
\ 8. Replaced ?DE-ALLOCATE and DO-ALLOCATE with dummy definitions.
|
|
\ 9. TEXT buffer is CREATEd and ALLOTed initially.
|
|
\
|
|
\ =============== kForth requires ===================
|
|
\ include ans-words
|
|
\ include strings
|
|
\ include ansi
|
|
\ include files \ include filesw under Windows
|
|
|
|
\ : ptr CREATE 1 CELLS ?ALLOT ! DOES> a@ ;
|
|
\ : BIN ;
|
|
\ ANS compliant defn of >NUMBER is now part of ans-words.4th (km 2003-3-9)
|
|
|
|
\ ============== end of kForth requires ============
|
|
|
|
|
|
\ Here begins the source code for LF:
|
|
|
|
1024 1024 * CONSTANT EDIT-BUF-SIZE
|
|
CREATE EDIT-BUF EDIT-BUF-SIZE ALLOT
|
|
|
|
( MARKER TASK )
|
|
|
|
|
|
: K* ( n1 -- n2 ) 1024 * ;
|
|
|
|
|
|
\ adjust constants as needed
|
|
|
|
\ filename delimiters
|
|
CHAR / CONSTANT PATH-DELIMITER
|
|
CHAR : CONSTANT DRIVE-DELIMITER
|
|
|
|
\ using ALLOCATE ?
|
|
FALSE CONSTANT ALLOCATING
|
|
128 CONSTANT DEFAULT-ALLOCATE \ in K
|
|
|
|
\ beeps?
|
|
TRUE CONSTANT BEEPS
|
|
|
|
\ tab, linewidth
|
|
5 CONSTANT TABWIDTH
|
|
12 CONSTANT TABS/LINE
|
|
TABWIDTH TABS/LINE * CONSTANT LINEWIDTH \ multiple makes easy
|
|
2 CONSTANT LEDGE \ room for spaces beyond linewidth
|
|
LINEWIDTH LEDGE + CONSTANT PLANK
|
|
|
|
\ a cut or copy goes to memory if it fits,
|
|
\ otherwise to a file
|
|
2 K* CONSTANT POCKET-SIZE
|
|
|
|
\ left margin holds line number
|
|
\ the start of a page is shown to the right of the line
|
|
( 6) 0 CONSTANT LINE#-SPACE \ 0 if not displaying
|
|
5 CONSTANT PAGE#-SPACE \ 0 if not displaying
|
|
|
|
\ screen display
|
|
LINEWIDTH
|
|
LINE#-SPACE +
|
|
PAGE#-SPACE LEDGE MAX +
|
|
CONSTANT MAX-X \ # of columns
|
|
( 23) ( 54) 40 CONSTANT MAX-Y \ # of rows
|
|
MAX-X 16 - CONSTANT MAX-INPUT \ reserves space for a prompt
|
|
|
|
\ screen/page
|
|
0 CONSTANT BANNER-LINE
|
|
2 CONSTANT TOP \ line 1 has a ruler
|
|
MAX-Y 1- CONSTANT STATUS-LINE \ display status below text
|
|
STATUS-LINE TOP - 1- CONSTANT LMAX/SCREEN \ text lines to show
|
|
TOP LMAX/SCREEN + 1- CONSTANT BOTTOM \ last line to show text
|
|
|
|
\ displayable characters are implementation defined
|
|
126 CONSTANT LAST-DISPLAYABLE
|
|
\ this from Marcel Hendrix
|
|
\ TRUE PAD ! PAD C@ CONSTANT LAST-DISPLAYABLE
|
|
|
|
\ characters for displaying "invisibles"
|
|
CHAR _ CONSTANT .BL \ BL
|
|
CHAR | CONSTANT .CR \ CR
|
|
CHAR ^ CONSTANT .OTHER \ e.g. LF !
|
|
|
|
\ keyboard entry
|
|
|
|
\ ASCII characters used in command mode
|
|
\ command mode provides all the functions
|
|
\ that LF implements
|
|
|
|
\ two of these start, one ends command mode
|
|
\ consider using ESCape once if it's available
|
|
\ Bruce R. McFarling recommends having a character for
|
|
\ starting and a different character for ending command mode
|
|
CHAR ` CONSTANT ^COMMAND
|
|
|
|
\ command keys
|
|
CHAR F CONSTANT ^Find-string
|
|
CHAR G CONSTANT ^find-aGain
|
|
CHAR R CONSTANT ^Replace
|
|
CHAR T CONSTANT ^replace-Too
|
|
|
|
CHAR " CONSTANT ^(un)mark(1)
|
|
CHAR ' CONSTANT ^(un)mark(2)
|
|
|
|
CHAR C CONSTANT ^Copy
|
|
CHAR D CONSTANT ^Delete
|
|
CHAR E CONSTANT ^Embed
|
|
CHAR W CONSTANT ^Wedge
|
|
|
|
CHAR V CONSTANT ^inVest
|
|
|
|
CHAR Q CONSTANT ^Query
|
|
CHAR A CONSTANT ^Alter-input
|
|
CHAR Z CONSTANT ^Show
|
|
|
|
CHAR X CONSTANT ^change-name
|
|
|
|
CHAR S CONSTANT ^Save
|
|
|
|
CHAR B CONSTANT ^good-Bye
|
|
|
|
\ next 6 aren't shown in the help screen
|
|
\ I don't expect them to be used but they would
|
|
\ eliminate the environmental dependency on the use of
|
|
\ control codes (if you silence BEEP)
|
|
CHAR | CONSTANT -Enter-key(1)
|
|
CHAR \ CONSTANT -Enter-key(2)
|
|
CHAR _ CONSTANT -Backspace-key(1)
|
|
CHAR - CONSTANT -Backspace-key(2)
|
|
CHAR @ CONSTANT -Tab-key(1)
|
|
CHAR 2 CONSTANT -Tab-key(2)
|
|
|
|
\ cursor keys
|
|
CHAR L CONSTANT ^right
|
|
CHAR J CONSTANT ^left
|
|
CHAR I CONSTANT ^up
|
|
CHAR K CONSTANT ^down(1)
|
|
CHAR < CONSTANT ^down(2)
|
|
CHAR , CONSTANT ^down(3)
|
|
CHAR H CONSTANT ^1st-col
|
|
CHAR : CONSTANT ^last-col(1)
|
|
CHAR ; CONSTANT ^last-col(2)
|
|
CHAR O CONSTANT ^page-up
|
|
CHAR > CONSTANT ^page-down(1)
|
|
CHAR . CONSTANT ^page-down(2)
|
|
CHAR U CONSTANT ^BOF
|
|
CHAR M CONSTANT ^EOF
|
|
CHAR P CONSTANT ^TOP
|
|
CHAR ? CONSTANT ^BOP(1)
|
|
CHAR / CONSTANT ^BOP(2)
|
|
|
|
\ ASCII control characters
|
|
\ use of control characters is an environmental dependency
|
|
7 CONSTANT BEL \ bell
|
|
\ 8 CONSTANT BS \ backspace
|
|
127 CONSTANT BS \ backspace on Linux/KDE system
|
|
9 CONSTANT HT \ horizontal tab
|
|
\ 10 CONSTANT LF \ LF doesn't know LF
|
|
\ 12 CONSTANT FF \ formfeed for printing
|
|
\ 13 CONSTANT 'CR \ Enter (also marks end of a paragraph)
|
|
10 CONSTANT 'CR \ use LF for EOL on Unix systems
|
|
|
|
\ in-key
|
|
\ would be nice to have DEFER and IS
|
|
\ 0 ptr (IN-KEY) \ changed from VALUE to ptr -- km 8-11-02
|
|
0 VALUE (IN-KEY)
|
|
: IN-KEY ( -- u flag ) (IN-KEY) EXECUTE ;
|
|
|
|
\ Jonah Thomas:
|
|
\ Here is something that should work on standard systems:
|
|
\
|
|
\ : NO-GOOD ." bad DEFERed word" ABORT ;
|
|
\ : DEFER
|
|
\ CREATE ['] NO-GOOD ,
|
|
\ DOES> @ EXECUTE ;
|
|
\
|
|
\ : (IS) ( xt -- )
|
|
\ ' >BODY ! ;
|
|
\ : [IS] ( -- )
|
|
\ ' >BODY POSTPONE LITERAL POSTPONE ! ; IMMEDIATE
|
|
\ : IS ( S: xt -- ) ( C: -- )
|
|
\ STATE @ IF POSTPONE [IS] ELSE (IS) THEN ; IMMEDIATE
|
|
|
|
\ KEY is a Core word
|
|
: KEY-CHAR ( -- char true) KEY TRUE ;
|
|
|
|
' KEY-CHAR TO (IN-KEY)
|
|
|
|
\ if your system supports it, and you want to, add
|
|
\ more keys (such as actual cursor keys) and use
|
|
\ EKEY instead of KEY :
|
|
\ : EVENT ( -- u flag ) EKEY EKEY>CHAR ;
|
|
\
|
|
\ ' EVENT TO (IN-KEY)
|
|
|
|
|
|
\ PAD space
|
|
84 CONSTANT PAD-SPACE \ region guaranteed by PAD
|
|
|
|
\ search pad
|
|
\ LF uses PAD
|
|
PAD-SPACE CONSTANT GULP \ #characters in search space
|
|
: SEARCH-PAD ( -- ) PAD ;
|
|
|
|
\ constants for printing +
|
|
|
|
50 CONSTANT LINES/PAGE \ printed page
|
|
\ 11 CONSTANT PMARGIN \ left margin for printing
|
|
|
|
|
|
\ tools
|
|
\ some of these may already exist in your ANS Forth
|
|
|
|
\ do nothing
|
|
: NOP ;
|
|
|
|
\ number of cells/characters in n1 address units
|
|
1 CELLS CONSTANT /CELL
|
|
1 CHARS CONSTANT /CHAR
|
|
|
|
\ stack manipulation
|
|
\ : -ROT ( x1 x2 x3 -- x3 x1 x2 ) ROT ROT ;
|
|
|
|
\ unsigned max and min
|
|
: UMAX ( u1 u2 -- u1|u2 ) 2DUP U< IF NIP ELSE DROP THEN ;
|
|
: UMIN ( u1 u2 -- u1|u2 ) 2DUP U< IF DROP ELSE NIP THEN ;
|
|
|
|
\ increment/decrement variable
|
|
: INCR ( a -- ) 1 SWAP +! ;
|
|
: DECR ( a -- ) -1 SWAP +! ;
|
|
|
|
\ add stack items
|
|
: UNDER+ ( n1 n2 n3 -- n1+n3 n2 ) ROT + SWAP ;
|
|
|
|
\ unsigned division
|
|
: U/MOD ( u1 u2 -- r q) >R 1 UM* R> UM/MOD ;
|
|
: U/ ( u1 u2 -- q ) U/MOD NIP ;
|
|
|
|
\ fences
|
|
: BETWEEN ( n1 n2 n3 -- f) 1+ WITHIN ;
|
|
: CLAMP ( n1 lo hi - n2) ROT MIN MAX ;
|
|
|
|
\ warnings
|
|
' NOP VALUE (BEEP)
|
|
: ?BEEP ( -- ) (BEEP) EXECUTE ;
|
|
: BEEP ( -- ) BEL EMIT ;
|
|
: DEEP ( n) DROP ?BEEP ;
|
|
: ?BEEPS ( -- )
|
|
BEEPS
|
|
IF ['] BEEP
|
|
ELSE ['] NOP
|
|
THEN TO (BEEP) ;
|
|
: WAIT ( -- ) ." Press a key to continue." IN-KEY 2DROP ;
|
|
|
|
\ string words
|
|
|
|
\ Is character between A and Z?
|
|
: UPPER? ( c -- ? ) [CHAR] A - 26 U< ;
|
|
|
|
\ Is character between a and z?
|
|
: lower? ( c -- ? ) [CHAR] a - 26 U< ;
|
|
|
|
\ make a character lower/upper case
|
|
: >lower ( C -- c) DUP UPPER? BL AND XOR ;
|
|
: >UPPER ( c -- C) DUP lower? BL AND XOR ;
|
|
|
|
\ make a string lower case
|
|
: lcase ( a u -- )
|
|
0 ?DO DUP C@ >lower OVER C! CHAR+ LOOP DROP ;
|
|
|
|
\ string less the number of trailing characters <> c
|
|
|
|
: -TRAILING<> \ a u1 c -- a u2
|
|
>R
|
|
BEGIN DUP
|
|
IF 1- 2DUP CHARS + C@ R@ = ELSE 1- TRUE THEN
|
|
UNTIL 1+
|
|
R> DROP ;
|
|
|
|
|
|
\ string after last character = c
|
|
: TRAILING<> ( a1 u1 c -- a2 u2 )
|
|
OVER >R -TRAILING<>
|
|
R> SWAP /STRING ;
|
|
|
|
\ leading characters = c
|
|
: LEADING= ( a u1 c -- a u2 )
|
|
>R 2DUP
|
|
BEGIN OVER C@ R@ = OVER AND
|
|
WHILE 1 /STRING
|
|
REPEAT
|
|
R> DROP
|
|
NIP - ;
|
|
|
|
\ string less leading characters <> c
|
|
: -LEADING<> ( a1 u1 c -- a2 u2 )
|
|
>R BEGIN OVER C@ R@ <> OVER AND
|
|
WHILE 1 /STRING
|
|
REPEAT
|
|
R> DROP ;
|
|
|
|
\ string arithmetic
|
|
: C+! ( n a -- ) DUP C@ UNDER+ C! ;
|
|
: S+! ( a u s -- )
|
|
2DUP 2>R
|
|
COUNT CHARS + SWAP CMOVE
|
|
2R> C+! ;
|
|
|
|
\ move a counted string
|
|
: SMOVE ( s1 s2 -- ) OVER C@ 1+ CMOVE ;
|
|
|
|
\ vectored execution +
|
|
VARIABLE way#
|
|
: CALL-WAY ( a n -- ? ) CELLS + a@ EXECUTE ;
|
|
: WAYS
|
|
CREATE ( n -- ) DUP CELLS ?allot SWAP
|
|
0 DO DUP ' SWAP ! /CELL + LOOP DROP
|
|
DOES> way# @ CALL-WAY ;
|
|
|
|
\ at most one file is open at a time
|
|
\ some error recovery could be introduced here
|
|
0 VALUE FILE-ID
|
|
|
|
\ create a file for writing
|
|
: CREATE-WRITE ( a u -- )
|
|
W/O BIN CREATE-FILE
|
|
ABORT" CREATE-FILE problem" TO FILE-ID ;
|
|
|
|
\ open a file for reading only
|
|
: OPEN-READ ( a u - fileid flag )
|
|
R/O BIN OPEN-FILE ;
|
|
|
|
\ close an opened file
|
|
: FCLOSE ( -- )
|
|
FILE-ID CLOSE-FILE
|
|
ABORT" CLOSE-FILE problem" ;
|
|
|
|
\ write u characters starting at a , then close the file
|
|
: BUF>FILE ( a u -- )
|
|
FILE-ID WRITE-FILE
|
|
0< ABORT" WRITE-FILE problem"
|
|
FCLOSE ;
|
|
|
|
\ read u chars to a , then close the file
|
|
: FILE>BUF ( a u -- ) FILE-ID READ-FILE
|
|
ABORT" READ-FILE problem" DROP
|
|
FCLOSE ;
|
|
|
|
|
|
\ data structures +
|
|
\ chars and lines
|
|
\ actual values determined later
|
|
0 VALUE TEXT \ start of text area
|
|
0 VALUE CMAX \ max # of characters
|
|
0 VALUE LINES \ start of lines data
|
|
0 VALUE LMAX \ max # of lines
|
|
|
|
CREATE POCKET POCKET-SIZE CHARS ALLOT \ cut/copy buffer
|
|
CREATE FILENAME$ MAX-INPUT 6 + CHARS ALLOT \ filename string
|
|
|
|
CREATE CURSOR> 2 CELLS ?ALLOT 0 0 ROT 2! ( 0 , 0 ,) \ cursor position
|
|
|
|
|
|
\ document
|
|
VARIABLE doc-size \ size of document
|
|
VARIABLE last-line \ last line of document
|
|
VARIABLE last-old \ previous last line
|
|
VARIABLE char-now \ current character #
|
|
VARIABLE topline \ current top screen line
|
|
VARIABLE top-old \ previous top screen line
|
|
VARIABLE line-now \ current line
|
|
VARIABLE line-old \ previous current line
|
|
VARIABLE col# \ current column
|
|
|
|
\ before the last character?
|
|
: -DOC-END ( -- f) char-now @ doc-size @ U< ;
|
|
|
|
\ room to add u characters?
|
|
: ROOM? ( u -- f) doc-size @ + CMAX 1+ U< ;
|
|
|
|
|
|
\ lines
|
|
|
|
\ address of nth element of line array
|
|
: LINE ( l# - a) CELLS LINES + ;
|
|
|
|
\ starting character # and length of a line
|
|
: LINESPEC ( l# - c# u) LINE 2@ TUCK - ;
|
|
|
|
\ number of characters in a line
|
|
: LINELENGTH ( l# - u) LINESPEC NIP ;
|
|
|
|
\ zero line data between line#1 and line#2
|
|
: 0LINES ( l#1 l#2)
|
|
OVER - 1+ 0 MAX >R LINE R> CELLS ERASE ;
|
|
|
|
\ zero all line information
|
|
: 0>LMAX ( -- ) 0 LMAX 0LINES ;
|
|
|
|
\ add u to lines between current line and last line
|
|
: LINES+! ( u -- )
|
|
line-now @ 1+ DUP LINE SWAP
|
|
last-line @ SWAP - 1+ 0 MAX
|
|
0 ?DO 2DUP +! CELL+ LOOP 2DROP ;
|
|
|
|
\ move lines data starting with l# forward one cell
|
|
: LINES> ( l# -- )
|
|
DUP LINE DUP CELL+
|
|
ROT last-line @ 1+ DUP last-line !
|
|
SWAP - CELLS 0 MAX MOVE ;
|
|
|
|
\ move lines data starting with l#+1 back one cell
|
|
: <LINES ( l# -- )
|
|
1+ DUP LINE DUP CELL+ SWAP
|
|
ROT last-line @ SWAP - CELLS 0 MAX MOVE
|
|
last-line DECR ;
|
|
|
|
\ starting from a line, find the line a character is in
|
|
: C>L ( c# l#1 -- l#2 )
|
|
OVER doc-size @ U< 0=
|
|
IF 2DROP last-line @
|
|
ELSE OVER
|
|
IF 1- LINE
|
|
BEGIN CELL+ 2DUP @ U< UNTIL
|
|
NIP LINES - /CELL / 1-
|
|
ELSE DROP
|
|
THEN
|
|
THEN ;
|
|
|
|
\ find screen row of line
|
|
: >Y ( l# -- row#) topline @ - TOP + ;
|
|
|
|
\ find bottom line of screen
|
|
: BOTTOMLINE ( -- u ) topline @ LMAX/SCREEN + 1- ;
|
|
|
|
|
|
\ allocate / allot memory
|
|
|
|
\ allocate memory
|
|
0 VALUE ALLOCATED
|
|
|
|
\ GET-NUMBER from Woehr, Forth: the New Model
|
|
: GET-NUMBER ( -- ud f )
|
|
0 0
|
|
PAD 84 BLANK
|
|
PAD 84 ACCEPT
|
|
PAD SWAP -TRAILING
|
|
>NUMBER NIP 0= ;
|
|
|
|
\ get a number
|
|
: GET-INTEGER ( -- u )
|
|
GET-NUMBER DROP D>S ;
|
|
|
|
( =============================================================
|
|
|
|
\ release previously allocated memory
|
|
: ?DE-ALLOCATE \ --
|
|
ALLOCATED
|
|
IF LINES FREE ABORT" FREE problem" 0 TO ALLOCATED THEN ;
|
|
|
|
\ allocate memory from user input
|
|
|
|
: DO-ALLOCATE \ --
|
|
PAGE 10 10 AT-XY
|
|
." Reserve space for how many characters [K]:"
|
|
GET-INTEGER
|
|
?DUP 0= IF DEFAULT-ALLOCATE THEN
|
|
K* DUP LINEWIDTH 2/ U/ 1+
|
|
2DUP CELLS DUP
|
|
ROT CHARS +
|
|
DUP ALLOCATE
|
|
ABORT" ALLOCATE problem. Not enough memory?"
|
|
DUP TO LINES
|
|
ROT + TO TEXT
|
|
TO ALLOCATED
|
|
1- TO LMAX
|
|
TO CMAX ;
|
|
|
|
\ allot memory
|
|
: DO-ALLOT
|
|
CMAX 0=
|
|
IF UNUSED
|
|
4 K* CELLS - \ breathing room - could be less?
|
|
LINEWIDTH 2/ CHARS /CELL + U/
|
|
DUP 1- TO LMAX
|
|
DUP HERE TO LINES CELLS ALLOT \ allot cells first
|
|
LINEWIDTH 2/ *
|
|
DUP TO CMAX HERE TO TEXT CHARS ALLOT
|
|
THEN ;
|
|
=========================================================== )
|
|
|
|
: ?DE-ALLOCATE ;
|
|
: DO-ALLOCATE ;
|
|
|
|
: DO-ALLOT
|
|
CMAX 0=
|
|
IF EDIT-BUF-SIZE
|
|
4 K* CELLS - \ breathing room - could be less?
|
|
LINEWIDTH 2/ CHARS /CELL + U/
|
|
DUP 1- TO LMAX
|
|
EDIT-BUF TO LINES \ allot cells first
|
|
DUP EDIT-BUF + TO TEXT
|
|
LINEWIDTH 2/ *
|
|
TO CMAX
|
|
THEN ;
|
|
|
|
\ character<-->memory
|
|
: SPOT ( -- a ) TEXT char-now @ CHARS + ;
|
|
: T>MEM ( c# u -- a u ) >R CHARS TEXT + R> ;
|
|
|
|
|
|
\ screen display
|
|
|
|
\ blank a screen line
|
|
: RUB ( row -- )
|
|
0 SWAP
|
|
2DUP AT-XY MAX-X LEDGE + SPACES AT-XY ;
|
|
|
|
\ display a tab section in a ruler line
|
|
: .TAB ( -- )
|
|
TABWIDTH 1- 0 MAX 0 ?DO [CHAR] - EMIT LOOP
|
|
[CHAR] | EMIT ;
|
|
|
|
\ display a ruler line
|
|
: .RULER ( row -- )
|
|
0 SWAP AT-XY
|
|
LINE#-SPACE IF ." Line " THEN
|
|
[CHAR] | EMIT LINEWIDTH TABWIDTH / 0 ?DO .TAB LOOP
|
|
PAGE#-SPACE IF ." Page" THEN ;
|
|
|
|
\ display top and bottom rulers
|
|
: .RULERS ( -- )
|
|
TOP 1- DUP RUB .RULER
|
|
BOTTOM 1+ DUP RUB .RULER ;
|
|
|
|
\ display current way of input
|
|
: .INSERT ( -- ) ." INSERT " ;
|
|
: .OVERWRITE ( -- ) ." OVERWRITE " ;
|
|
: .MARKING ( -- ) ." MARKING " ;
|
|
|
|
' NOP VALUE (.WAY)
|
|
: .WAY ( -- ) (.WAY) EXECUTE ;
|
|
|
|
FALSE VALUE COMMANDING \ false = text entry mode
|
|
|
|
\ delete path from filename
|
|
: -PATH ( a1 u1 -- a2 u2 )
|
|
PATH-DELIMITER TRAILING<> DRIVE-DELIMITER TRAILING<> ;
|
|
|
|
\ display filename
|
|
: .FILENAME ( -- )
|
|
FILENAME$ COUNT -PATH TYPE SPACE ;
|
|
|
|
\ display filename, way, mode
|
|
: .HEADLINE ( a u -- )
|
|
BANNER-LINE RUB
|
|
.FILENAME .WAY 2 SPACES
|
|
TYPE 2 SPACES ;
|
|
|
|
\ headline when entering text
|
|
: .TEXT-ENTRY ( -- )
|
|
S" TEXT ENTRY" .HEADLINE
|
|
^COMMAND DUP EMIT EMIT SPACE ^Query EMIT SPACE
|
|
." for help" ;
|
|
|
|
\ headline when commanding
|
|
: .COMMANDING ( -- )
|
|
S" COMMANDING" .HEADLINE
|
|
^Query EMIT SPACE ." to query help" ;
|
|
|
|
\ display the headline
|
|
: BANNER ( -- )
|
|
COMMANDING
|
|
IF .COMMANDING ELSE .TEXT-ENTRY THEN ;
|
|
|
|
\ display screen before displaying the document
|
|
: .SCREEN ( -- )
|
|
PAGE
|
|
BANNER .RULERS LINE#-SPACE TOP AT-XY ;
|
|
|
|
|
|
\ document display
|
|
BL VALUE "bl" \ to EMIT BL
|
|
BL VALUE "cr" \ to EMIT 'CR
|
|
BL VALUE "other" \ to EMIT other "invisible" character
|
|
|
|
\ 32 displays as "bl" , 13 displays as "cr"
|
|
: "INVISIBLE" ( c1 -- c2 )
|
|
CASE
|
|
BL OF "bl" ENDOF
|
|
'CR OF "cr" ENDOF
|
|
"other"
|
|
SWAP
|
|
ENDCASE ;
|
|
: ?DISPLAY ( c1 -- c2)
|
|
DUP BL 1+ <
|
|
IF "INVISIBLE" THEN ;
|
|
|
|
\ toggle visible and invisible "bl" AND "cr"
|
|
: ~DISPLAY ( -- )
|
|
"cr" BL <>
|
|
IF BL TO "bl" BL TO "cr" BL TO "other"
|
|
ELSE .BL TO "bl" .CR TO "cr" .OTHER TO "other"
|
|
THEN
|
|
-1 top-old ! ;
|
|
|
|
\ "highlighting"
|
|
' NOP VALUE (?MARK)
|
|
: ?MARK ( c1 -- c2 ) (?MARK) EXECUTE ;
|
|
|
|
\ erasers
|
|
\ keep current line in screen within n lines of top
|
|
: AIM ( c# n -- )
|
|
>R 0 C>L DUP line-now !
|
|
R> - 0 MAX topline ! ;
|
|
|
|
\ erase to end of line
|
|
: EraseEOL ( col -- )
|
|
PLANK SWAP - SPACES ;
|
|
|
|
\ erase to end of text area
|
|
: EraseEOS ( -- )
|
|
BOTTOM last-line @ >Y - 0 MAX
|
|
0 ?DO MAX-X SPACES CR LOOP ;
|
|
|
|
\ display text line
|
|
: LTYPE ( c# u -- )
|
|
TUCK T>MEM
|
|
0 ?DO COUNT ?DISPLAY ?MARK EMIT LOOP DROP
|
|
EraseEOL ;
|
|
|
|
\ much faster ltype by Marcel Hendrix:
|
|
\ LINEWIDTH LEDGE + CONSTANT C/L
|
|
\ 0 VALUE cnt
|
|
\ CREATE lbuff 128 CHARS ALLOT
|
|
\ : LTYPE ( c# u -- )
|
|
\ 0 TO cnt
|
|
\ TUCK T>MEM
|
|
\ 0 ?DO
|
|
\ COUNT ?DISPLAY ?MARK
|
|
\ lbuff cnt + C! 1 +TO cnt ( or: cnt 1+ TO cnt )
|
|
\ LOOP DROP ( u)
|
|
\ lbuff cnt C/L 1- MIN TYPE
|
|
\ ( u) EraseEOL ;
|
|
|
|
\ line and page numbers
|
|
' NOP VALUE (.LINE#)
|
|
' NOP VALUE (.PAGE#)
|
|
: ?LINE# ( -- ) (.LINE#) EXECUTE ;
|
|
: ?PAGE# ( -- ) (.PAGE#) EXECUTE ;
|
|
|
|
\ display line number
|
|
: <.LINE#> ( l# -- l#) DUP 1+ 5 U.R SPACE ;
|
|
|
|
\ calculate page number
|
|
: PAGE-LINE ( l# -- p# n ) LINES/PAGE /MOD 1+ SWAP ;
|
|
|
|
\ if first line of a page, display the page number
|
|
: <.PAGE#> ( l# -- l# )
|
|
DUP PAGE-LINE
|
|
IF DROP 3 SPACES ELSE 3 U.R THEN ;
|
|
|
|
\ display line and page numbers?
|
|
: ?MARGIN ( -- )
|
|
LINE#-SPACE IF ['] <.LINE#> TO (.LINE#) THEN
|
|
PAGE#-SPACE IF ['] <.PAGE#> TO (.PAGE#) THEN ;
|
|
|
|
\ display line#, line, page#
|
|
: .TLINE ( l# l# -- l# )
|
|
?LINE#
|
|
LINESPEC LTYPE
|
|
?PAGE#
|
|
CR ;
|
|
|
|
\ which lines to display
|
|
VARIABLE .start \ first
|
|
VARIABLE .end \ last
|
|
VARIABLE .mend \ override .end
|
|
|
|
\ display some lines of text
|
|
: .TLINES ( -- )
|
|
.start @ topline @ MAX 0 OVER >Y AT-XY
|
|
.end @ .mend @ MAX last-line @ MIN BOTTOMLINE MIN
|
|
OVER - 1+
|
|
0 ?DO DUP .TLINE 1+ LOOP DROP
|
|
top-old @ topline @ U< last-line @ last-old @ U< OR
|
|
last-line @ BOTTOMLINE U< AND
|
|
IF 0 last-line @ topline @ - 1+ TOP + AT-XY
|
|
EraseEOS
|
|
THEN ;
|
|
|
|
|
|
\ formatting
|
|
FALSE VALUE FORMAT-ALL \ true = format the entire document
|
|
FALSE VALUE SAME \ true if line data hasn't changed
|
|
VARIABLE line# \ line being formatted
|
|
|
|
\ 'CR a special case
|
|
: CReturn ( a -- )
|
|
line# @ TUCK 1+ LINE @ 2DUP <>
|
|
IF U< IF LINES> ELSE <LINES THEN last-line @ .mend !
|
|
ELSE 2DROP DROP THEN ;
|
|
|
|
\ formatting old ground?
|
|
: ?SAME ( c# 'line -- )
|
|
FORMAT-ALL
|
|
IF 2DROP
|
|
ELSE @ =
|
|
IF line# @ line-now @ OVER U<
|
|
OVER LINELENGTH LINEWIDTH U< AND AND ?DUP
|
|
IF 1- .end ! TRUE TO SAME THEN
|
|
THEN
|
|
THEN ;
|
|
|
|
\ store a character position in the next line
|
|
: LINE! ( c# -- ) line# DUP INCR @ LINE 2DUP ?SAME ! ;
|
|
|
|
\ word wrap
|
|
\ lines are wrapped by priority:
|
|
\ 1. first CR up to LINEWIDTH+1
|
|
\ 2. last BL up to LINEWIDTH+1, allowing
|
|
\ for LEDGE BLs beyond LINEWIDTH
|
|
\ 3. at LINEWIDTH
|
|
LINEWIDTH 1+ CONSTANT LINEWIDTH+
|
|
: WRAP ( c#1 a u -- c#2 )
|
|
2DUP LINEWIDTH+ MIN \ allow 1+ column for CR
|
|
'CR -LEADING<> \ look for first CR
|
|
IF NIP SWAP - 1+ +
|
|
DUP CReturn DUP LINE! \ end of paragraph
|
|
ELSE DROP DUP LINEWIDTH > \ else need to wrap?
|
|
IF OVER LINEWIDTH+ \ allow 1+ column for BL
|
|
BL -TRAILING<> ?DUP \ break on last BL
|
|
IF DUP LINEWIDTH+ = \ at extra column?
|
|
IF 2SWAP \ ( c# a u2 a u1 )
|
|
LINEWIDTH+ /STRING \ rest of LEDGE
|
|
BL LEADING= NIP + \ add its leading BLs
|
|
ELSE 2SWAP 2DROP \ else dump plank
|
|
THEN NIP \ ( c# u )
|
|
ELSE DROP 2DROP LINEWIDTH \ no BLs
|
|
THEN + DUP LINE! \ ( c# )
|
|
ELSE NIP + \ no need to wrap
|
|
THEN
|
|
THEN ;
|
|
|
|
\ clean-up after formatting
|
|
: DEJA? ( -- )
|
|
SAME
|
|
IF last-line DUP @ line# @ 1- MAX SWAP !
|
|
doc-size @ last-line @ 1+ LINE !
|
|
ELSE last-line @ 1+ line# @ DUP last-line ! DUP .end !
|
|
1+ doc-size @ OVER LINE ! 1+ SWAP 0LINES
|
|
THEN ;
|
|
|
|
\ the f word
|
|
: FORMAT ( -- )
|
|
FALSE TO SAME line-now @ 1- 0 MAX DUP line# !
|
|
LINE @
|
|
BEGIN DUP DUP PLANK + doc-size @ UMIN
|
|
OVER - T>MEM WRAP
|
|
DUP doc-size @ = SAME OR
|
|
UNTIL DROP DEJA? ;
|
|
|
|
|
|
\ moving around in the document
|
|
|
|
\ cursor right
|
|
: RIGHT ( -- )
|
|
-DOC-END
|
|
IF char-now INCR ELSE ?BEEP THEN ;
|
|
|
|
\ cursor left
|
|
: LEFT ( -- )
|
|
char-now @
|
|
IF char-now DECR ELSE ?BEEP THEN ;
|
|
|
|
\ calculate the column of the current character
|
|
: CPLACE ( -- col# ) char-now @ line-now @ LINE @ - ;
|
|
|
|
\ calculate where to place the cursor in a line
|
|
: >char-now ( cplace l# -- )
|
|
LINESPEC ROT 2DUP U<
|
|
IF DROP 1- 0 MAX ELSE NIP THEN + char-now ! ;
|
|
|
|
\ cursor up
|
|
: UP ( -- )
|
|
line-now @
|
|
IF CPLACE line-now DUP DECR @ >char-now
|
|
ELSE ?BEEP THEN ;
|
|
|
|
\ cursor down
|
|
: DOWN ( -- )
|
|
line-now @ last-line @ U<
|
|
IF CPLACE line-now DUP INCR @ >char-now
|
|
ELSE ?BEEP THEN ;
|
|
|
|
|
|
\ text pushes and pulls
|
|
|
|
\ number of characters to the end of the document
|
|
: #>END ( a -- u ) TEXT - /CHAR U/ doc-size @ SWAP - ;
|
|
|
|
\ suture text separated by u chars
|
|
: JOIN ( u -- ) CHARS SPOT DUP UNDER+ OVER #>END CMOVE ;
|
|
|
|
\ prepare to delete u characters
|
|
: <#SLIDE ( u -- )
|
|
doc-size @
|
|
IF DUP JOIN NEGATE doc-size +! ELSE DEEP THEN ;
|
|
|
|
\ prepare to delete character
|
|
: <SLIDE ( -- ) 1 <#SLIDE -1 LINES+! ;
|
|
|
|
\ make room for u characters
|
|
: SPLIT ( u -- ) CHARS SPOT TUCK + OVER #>END CMOVE> ;
|
|
|
|
\ prepare to insert u characters
|
|
: #SLIDE> ( u -- )
|
|
DUP ROOM?
|
|
IF DUP SPLIT doc-size +! ELSE DEEP THEN ;
|
|
|
|
\ prepare to insert character
|
|
: SLIDE> ( -- ) 1 #SLIDE> 1 LINES+! ;
|
|
|
|
|
|
\ text input
|
|
|
|
0 VALUE PREVIOUS-KEY \ two keys need to enter command mode
|
|
0 VALUE VANQUISHED \ text character overwritten by ^command character
|
|
|
|
\ put character into the document
|
|
: OVERWRITE ( c -- )
|
|
char-now @ CMAX U< line-now @ LMAX U< AND
|
|
IF
|
|
SPOT C@ -DOC-END AND
|
|
PREVIOUS-KEY ^COMMAND <> AND TO VANQUISHED
|
|
SPOT C! doc-size DUP @ char-now DUP INCR @ UMAX SWAP !
|
|
FORMAT
|
|
ELSE DEEP THEN ;
|
|
|
|
\ insert character into the document
|
|
: INSERT ( c -- )
|
|
1 ROOM? last-line @ LMAX U< AND
|
|
line-now @ LMAX 1- U< AND
|
|
IF -DOC-END IF SLIDE> THEN OVERWRITE
|
|
ELSE DEEP THEN ;
|
|
|
|
\ delete character
|
|
: DELETE ( -- )
|
|
-DOC-END
|
|
IF <SLIDE FORMAT ELSE ?BEEP THEN ;
|
|
|
|
\ delete the previous character
|
|
: <DELETE ( -- )
|
|
char-now @
|
|
IF LEFT DELETE ELSE ?BEEP THEN ;
|
|
|
|
|
|
\ Enter key
|
|
|
|
\ inserting: put in a paragraph end
|
|
: PARAGRAPH ( -- )
|
|
last-line @ LMAX 1- U<
|
|
IF 'CR INSERT ELSE ?BEEP THEN ;
|
|
|
|
\ overwriting: if not at document's end go to the next
|
|
\ line, else insert a paragraph end
|
|
: RETURN ( -- )
|
|
-DOC-END
|
|
IF line-now @ LINE @ char-now ! DOWN
|
|
ELSE way# @ 2 <> IF PARAGRAPH ELSE ?BEEP THEN THEN ;
|
|
|
|
|
|
\ Tab
|
|
CREATE TAB$ TABWIDTH DUP CHARS ?ALLOT SWAP BLANK
|
|
|
|
\ #cols to next tab mark
|
|
: NEXT-TAB ( -- n )
|
|
TABWIDTH col# @ TABWIDTH MOD - ;
|
|
|
|
\ tab while inserting
|
|
\ will sometimes fall short of the first tab mark but
|
|
\ but will go to it with the next tab
|
|
: NUDGE ( -- )
|
|
NEXT-TAB
|
|
DUP ROOM?
|
|
IF DUP >R #SLIDE> TAB$ SPOT R@ CMOVE
|
|
R> DUP LINES+! char-now +! FORMAT
|
|
ELSE DEEP THEN ;
|
|
|
|
\ tab while overwriting
|
|
: HOP ( -- )
|
|
-DOC-END
|
|
IF NEXT-TAB
|
|
char-now @ +
|
|
line-now @ 1+ LINE @ MIN
|
|
doc-size @ 1+ UMIN char-now !
|
|
ELSE NUDGE THEN ;
|
|
|
|
|
|
\ jumps
|
|
|
|
\ keep jumped to line within document
|
|
: CONFINE ( l1 -- l2 ) 0 last-line @ CLAMP ;
|
|
|
|
\ jump n lines
|
|
: JUMP ( n -- )
|
|
DUP topline @ + CONFINE topline !
|
|
CPLACE SWAP line-now @ + CONFINE
|
|
DUP line-now ! >char-now ;
|
|
|
|
\ jump down
|
|
: +JUMP ( u -- )
|
|
line-now @ last-line @ =
|
|
IF DEEP ELSE JUMP THEN ;
|
|
|
|
\ jump up
|
|
: -JUMP ( u -- )
|
|
line-now @ 0=
|
|
IF DEEP ELSE NEGATE JUMP THEN ;
|
|
|
|
\ jump to the beginning of the line
|
|
: <LEFT ( -- ) line-now @ LINE @ char-now ! ;
|
|
|
|
\ jump to the end of the line
|
|
: RIGHT> ( -- )
|
|
line-now @
|
|
DUP 1+ LINE @ 1-
|
|
SWAP last-line @ = 1 AND + char-now ! ;
|
|
|
|
\ jump up one screen
|
|
: PAGE-UP ( -- ) LMAX/SCREEN -JUMP ;
|
|
|
|
\ jump down one screen
|
|
: PAGE-DOWN ( -- ) LMAX/SCREEN +JUMP ;
|
|
|
|
\ jump to the start of the document
|
|
: >BOF ( -- ) 0 char-now ! 0 line-now ! 0 topline ! ;
|
|
|
|
\ jump to the end of the document
|
|
: >EOF ( -- )
|
|
doc-size @ char-now !
|
|
last-line @ DUP line-now ! DUP .end !
|
|
DUP topline @ LMAX/SCREEN + 1- >
|
|
IF 6 - DUP .start ! topline !
|
|
ELSE DROP THEN ;
|
|
|
|
\ jump to current top screen line
|
|
: >TOP ( -- )
|
|
topline @ line-now @ U<
|
|
IF CPLACE topline @ DUP line-now ! >char-now
|
|
ELSE ?BEEP THEN ;
|
|
|
|
\ jump to current bottom screen line
|
|
: >BOTTOM ( -- )
|
|
line-now @ DUP last-line @ U< SWAP BOTTOMLINE U< AND
|
|
IF CPLACE last-line @ BOTTOMLINE MIN
|
|
DUP line-now ! >char-now
|
|
ELSE ?BEEP THEN ;
|
|
|
|
|
|
\ ~insert
|
|
\ toggle insert/overwrite
|
|
: ~INSERT ( -- ) way# DUP @ 1 XOR SWAP ! BANNER ;
|
|
|
|
|
|
\ find/replace
|
|
CREATE S$ MAX-INPUT CHARS ALLOT \ search string
|
|
CREATE R$ MAX-INPUT CHARS ALLOT \ replace string
|
|
FALSE VALUE FOUND \ has search string been found?
|
|
VARIABLE found-char \ where?
|
|
VARIABLE slen \ length of search string
|
|
VARIABLE spad> \ offset in PAD of found string
|
|
VARIABLE rlen \ length of replace string
|
|
|
|
\ does the string have an uppercase character?
|
|
: UC? ( a u -- f )
|
|
0 ?DO COUNT UPPER? IF DROP TRUE UNLOOP EXIT THEN
|
|
LOOP DROP FALSE ;
|
|
|
|
\ does the string have a lowercase character?
|
|
: lc? ( a u -- f )
|
|
0 ?DO COUNT lower? IF DROP TRUE UNLOOP EXIT THEN
|
|
LOOP DROP FALSE ;
|
|
|
|
\ does the string have both upper- and lower-case characters?
|
|
: MIXED? ( a u -- f ) 2DUP UC? >R lc? R> AND ;
|
|
|
|
' 2DROP VALUE ?lcase \ "deferred" ?lcase
|
|
|
|
|
|
\ make string lower case if NOT mixed
|
|
: ?MIXED ( a u -- )
|
|
2DUP MIXED?
|
|
IF ['] 2DROP ELSE ['] lcase THEN TO ?lcase
|
|
?lcase EXECUTE ;
|
|
|
|
\ look for searched string in search pad
|
|
: LOOKING ( a u -- )
|
|
2DUP ?lcase EXECUTE S$ slen @ SEARCH
|
|
NIP ?DUP IF TO FOUND SEARCH-PAD - spad> !
|
|
ELSE DROP THEN ;
|
|
|
|
\ you can't go home again (i.e. you can go home once)
|
|
TRUE VALUE OK-TO-GO-HOME \ ok to loop back to BOF?
|
|
VARIABLE snow \ char# now at SEARCH-PAD
|
|
|
|
\ move some text to the search pad
|
|
: T>SPAD ( a u -- spad u )
|
|
T>MEM >R
|
|
SEARCH-PAD R@ CMOVE
|
|
SEARCH-PAD R> ;
|
|
|
|
\ search text for a string, if it isn't found,
|
|
\ continue to look from the beginning of the document
|
|
: SWEEP ( -- )
|
|
TRUE TO OK-TO-GO-HOME
|
|
doc-size @ >R
|
|
char-now @ 1+ DUP R@ 1+ slen @ - U< AND
|
|
BEGIN DUP snow ! DUP DUP GULP + R@ UMIN DUP >R
|
|
OVER - T>SPAD LOOKING
|
|
R> R@ = OK-TO-GO-HOME AND
|
|
IF DROP 0 FALSE TO OK-TO-GO-HOME
|
|
ELSE GULP slen @ 1- - + THEN
|
|
DUP char-now @ 1+ U< OK-TO-GO-HOME OR 0= FOUND OR
|
|
UNTIL R> 2DROP ;
|
|
|
|
\ if the string found identify the starting character
|
|
\ if necessary ensure that it can be displayed
|
|
: ?FOUND ( -- )
|
|
FOUND
|
|
IF snow @ spad> @ +
|
|
DUP char-now ! DUP found-char !
|
|
6 AIM
|
|
ELSE ?BEEP THEN ;
|
|
|
|
\ the seek word
|
|
: SEEK ( -- )
|
|
FALSE TO FOUND
|
|
slen @ ?DUP
|
|
IF doc-size @ 1+ U<
|
|
IF S$ slen @ ?MIXED SWEEP THEN THEN
|
|
?FOUND ;
|
|
|
|
\ seek with prompt
|
|
\ empty string seeks the previous string
|
|
: SEEK? ( -- )
|
|
BANNER-LINE RUB ." Find:" S$ MAX-INPUT ACCEPT ?DUP
|
|
IF slen ! THEN SEEK BANNER ;
|
|
|
|
\ was something found here?
|
|
: POINT? ( -- f ) FOUND char-now @ found-char @ = AND ;
|
|
|
|
\ adjust for difference between sought and replace lengths
|
|
: SLIDE ( n -- )
|
|
DUP 0<
|
|
IF NEGATE <#SLIDE ELSE #SLIDE> THEN ;
|
|
|
|
\ replace
|
|
: PUT ( -- )
|
|
POINT?
|
|
rlen @ DUP >R AND R@ slen @ - TUCK 0 MAX ROOM? AND
|
|
IF ?DUP IF DUP SLIDE LINES+! THEN
|
|
R$ SPOT R@ CMOVE FORMAT
|
|
ELSE DEEP THEN
|
|
R> DROP FALSE TO FOUND ;
|
|
|
|
\ replace with prompt
|
|
\ empty string subsitutes the previous string
|
|
: PUT? ( -- )
|
|
POINT?
|
|
IF BANNER-LINE RUB ." Replace with:" R$ MAX-INPUT ACCEPT
|
|
?DUP IF rlen ! THEN PUT BANNER
|
|
ELSE ?BEEP THEN ;
|
|
|
|
|
|
\ insert text from the command line
|
|
: STUFF ( -- )
|
|
BANNER-LINE RUB ." Wedge in:" PAD MAX-INPUT ACCEPT
|
|
DUP ?DUP ROOM? AND
|
|
IF DUP SLIDE DUP LINES+!
|
|
DUP PAD SPOT ROT CMOVE FORMAT
|
|
char-now +! THEN BANNER ;
|
|
|
|
|
|
\ marking a block
|
|
VARIABLE was \ way# before marking
|
|
VARIABLE bstart \ where marking originated
|
|
VARIABLE .bstart \ beginning of marked text
|
|
VARIABLE .bend \ end of marked text
|
|
VARIABLE blength \ number of characters in the block
|
|
VARIABLE btop \ top block line to display
|
|
|
|
\ keeping the block within the document, give the block's size
|
|
: BLOCK-IN ( -- n )
|
|
char-now
|
|
DUP @ doc-size @ 1- UMIN TUCK SWAP ! ;
|
|
|
|
\ if marking, define marked area
|
|
: <BLOCK> ( -- )
|
|
BLOCK-IN bstart @
|
|
2DUP UMIN .bstart ! UMAX .bend !
|
|
line-old @ line-now @ 2DUP MIN .start ! MAX .end ! ;
|
|
|
|
\ starting character and length of the block
|
|
: MARKED ( -- c# u )
|
|
.bstart @ .bend @ OVER - 1+ ;
|
|
|
|
\ start and end lines of the block
|
|
: <LL> ( -- l1 l2 ) .bstart @ 0 C>L .bend @ OVER C>L ;
|
|
|
|
\ would like a Standard way to highlight: GLOW ?
|
|
: MARK ( a c -- a c )
|
|
OVER 1- .bstart @ CHARS TEXT + .bend @ CHARS TEXT + BETWEEN
|
|
IF >UPPER THEN ;
|
|
|
|
' NOP VALUE (?BLOCK)
|
|
: ?BLOCK (?BLOCK) EXECUTE ;
|
|
|
|
\ start marking
|
|
: +MARK ( -- )
|
|
way# DUP @ was ! 2 SWAP !
|
|
['] MARK TO (?MARK) ['] <BLOCK> TO (?BLOCK)
|
|
BLOCK-IN bstart ! topline @ btop !
|
|
-1 top-old ! BANNER ;
|
|
|
|
\ leave marking
|
|
: -MARK ( -- )
|
|
<LL> .end ! .start ! was @ way# !
|
|
['] NOP DUP TO (?MARK) TO (?BLOCK) BANNER ;
|
|
|
|
\ copy, cut, embed
|
|
|
|
\ fits into allotted space?
|
|
: SMALL? ( u -- flag ) POCKET-SIZE 1+ U< ;
|
|
|
|
\ write larger block to a temporary file
|
|
: >PURSE ( a u -- )
|
|
S" temp.wnk" CREATE-WRITE BUF>FILE ;
|
|
|
|
\ copy marked
|
|
: APE ( -- )
|
|
MARKED DUP blength ! T>MEM
|
|
DUP SMALL?
|
|
IF POCKET SWAP CMOVE
|
|
ELSE >PURSE THEN
|
|
-MARK ;
|
|
|
|
\ copy and delete
|
|
: CUT ( -- )
|
|
APE
|
|
.bend @ .bstart @
|
|
DUP 0 C>L DUP .start ! line-now ! DUP char-now !
|
|
- 1+ DUP <#SLIDE NEGATE LINES+! FORMAT
|
|
btop @ topline @ U<
|
|
IF btop @ topline ! THEN
|
|
last-line @ .end ! ;
|
|
|
|
\ read large cut block
|
|
: PURSE> ( u -- )
|
|
S" temp.wnk" OPEN-READ
|
|
ABORT" OPEN-FILE problem" TO FILE-ID
|
|
SPOT SWAP FILE>BUF ;
|
|
|
|
\ paste copied or cut block
|
|
: PASTE ( -- )
|
|
blength @ DUP DUP ROOM? AND
|
|
<LL> SWAP - last-line @ + LMAX U< AND
|
|
IF DUP >R #SLIDE>
|
|
R@ SMALL?
|
|
IF POCKET SPOT R@ CMOVE
|
|
ELSE R@ PURSE> THEN
|
|
R@ LINES+! FORMAT
|
|
R> char-now +!
|
|
char-now @ LMAX/SCREEN 2/ AIM
|
|
ELSE DEEP THEN ;
|
|
|
|
|
|
\ print
|
|
\ some code to try if you can invoke printing
|
|
\ not tested with LF
|
|
\ VARIABLE spacing
|
|
\ VARIABLE pline
|
|
\ define >PRN and PRN> according to your system
|
|
\ : >PRN ... ; \ enable printing
|
|
\ : PRN> ... ; \ return from printing
|
|
\ : SPACED ( u) spacing ! ;
|
|
\ : CRs ( n) 0 ?DO CR LOOP ;
|
|
\ : FF 12 EMIT ;
|
|
\ : .PAGE ( n -- ) PMARGIN LINEWIDTH + SPACES 1+ . ;
|
|
\ : NEWPAGE ( n -- ) FF 3 CRs .PAGE 3 CRs ;
|
|
\ : ?NEWPAGE ( -- )
|
|
\ pline @ ?DUP
|
|
\ IF LINES/PAGE spacing @ / /MOD SWAP 0=
|
|
\ IF NEWPAGE ELSE DROP THEN
|
|
\ ELSE 6 CRs THEN ;
|
|
\ : TPRINT ( a u -- )
|
|
\ T>MEM
|
|
\ 0 ?DO COUNT DUP 'CR > AND EMIT LOOP
|
|
\ DROP ;
|
|
\ : <print> ( start end -- )
|
|
\ >PRN
|
|
\ 0 pline ! OVER - 1+ 0
|
|
\ ?DO ?NEWPAGE PMARGIN SPACES
|
|
\ DUP LINESPEC TPRINT spacing @ CRs pline INCR 1+
|
|
\ LOOP DROP FF
|
|
\ PRN> ;
|
|
\ : printing ( n -- ) 0 last-line @ <print> ;
|
|
\ : bprinting ( n -- ) <LL> <print> ;
|
|
\ : (PRINT) ( -- ) 1 SPACED printing ;
|
|
\ : BPRINT ( -- ) 1 SPACED bprinting ;
|
|
\ : (2PRINT) ( -- ) 2 SPACED printing ;
|
|
\ : 2BPRINT ( -- ) 2 SPACED bprinting ;
|
|
|
|
|
|
\ file i/o
|
|
|
|
\ request filename
|
|
\ a u1 is the prompt, u2 is the number of characters entered
|
|
: FILENAME ( a u1 -- u2 )
|
|
BANNER-LINE RUB TYPE
|
|
PAD 1+ MAX-INPUT ACCEPT DUP PAD C! ;
|
|
|
|
\ number of chars to dot
|
|
: >DOT ( s -- n ) COUNT [CHAR] . -TRAILING<> NIP ;
|
|
|
|
\ add extension?
|
|
: ?+WNK ( s -- )
|
|
DUP >DOT 0=
|
|
IF S" .wnk" ROT S+! ELSE DROP THEN ;
|
|
|
|
\ move name to filename
|
|
: PAD$>FILENAME$ ( -- ) PAD FILENAME$ SMOVE ;
|
|
|
|
\ file?
|
|
: GET-FILENAME ( -- a u)
|
|
S" Filename: " FILENAME
|
|
IF PAD$>FILENAME$
|
|
ELSE ?DE-ALLOCATE QUIT THEN
|
|
FILENAME$ ?+WNK FILENAME$ COUNT ;
|
|
|
|
\ save file
|
|
: FSAVE ( s -- )
|
|
COUNT CREATE-WRITE TEXT doc-size @ BUF>FILE ;
|
|
|
|
\ save the document
|
|
: SAVE-DOC ( -- ) FILENAME$ FSAVE ;
|
|
|
|
\ save a marked block
|
|
: SAVE-MARKED ( -- )
|
|
S" Save marked to:" FILENAME
|
|
IF PAD ?+WNK PAD COUNT CREATE-WRITE
|
|
MARKED T>MEM BUF>FILE
|
|
THEN BANNER ;
|
|
|
|
\ read in the document from a file
|
|
: READ-DOC ( -- )
|
|
FILE-ID
|
|
FILE-SIZE ABORT" FILE-SIZE problem"
|
|
OVER CMAX U< 0= OR
|
|
ABORT" FILE TOO BIG" doc-size !
|
|
TEXT doc-size @ FILE>BUF ;
|
|
|
|
\ if there's a file read it, else create a file
|
|
: ?READ-DOC ( a u -- )
|
|
2DUP R/O BIN OPEN-FILE
|
|
IF DROP CREATE-WRITE FCLOSE
|
|
ELSE TO FILE-ID 2DROP READ-DOC THEN ;
|
|
|
|
\ prompt for a filename, try to read the file
|
|
: GET-DOCUMENT ( -- ) GET-FILENAME ?READ-DOC ;
|
|
|
|
\ inVest file
|
|
: FROM> ( -- )
|
|
S" Read from:" FILENAME
|
|
IF PAD ?+WNK PAD COUNT OPEN-READ
|
|
IF DROP BANNER-LINE RUB
|
|
PAD COUNT TYPE 2 SPACES ." ?? " WAIT
|
|
ELSE TO FILE-ID BANNER-LINE RUB
|
|
FILE-ID FILE-SIZE ABORT" FILE-SIZE problem"
|
|
OVER ROOM? 0= OR
|
|
IF ." NOT ENOUGH ROOM " DROP WAIT
|
|
ELSE DUP #SLIDE> SPOT OVER FILE>BUF
|
|
TRUE TO FORMAT-ALL FORMAT FALSE TO FORMAT-ALL
|
|
char-now +!
|
|
char-now @ LMAX/SCREEN 2/ AIM
|
|
THEN
|
|
THEN
|
|
THEN BANNER ;
|
|
|
|
\ do a backup
|
|
: BACKUP ( -- )
|
|
PAD PAD-SPACE BLANK
|
|
FILENAME$ PAD SMOVE PAD >DOT ?DUP
|
|
IF 1- PAD C! THEN S" .bak" PAD S+! PAD FSAVE ;
|
|
|
|
\ if the file has some data, back it up
|
|
: ?BACKUP ( -- ) doc-size @ IF BACKUP THEN ;
|
|
|
|
\ change filename
|
|
: ~NAME ( -- )
|
|
S" Change filename to:" FILENAME
|
|
IF PAD$>FILENAME$ FILENAME$ ?+WNK FILENAME$ FSAVE THEN
|
|
BANNER ;
|
|
|
|
|
|
\ scrolling
|
|
|
|
\ scroll up one line
|
|
: SCRUP ( -- ) topline DUP INCR @ .start ! last-line @ .end ! ;
|
|
|
|
\ scroll down one line
|
|
: SCROWN ( -- ) topline DUP DECR @ .start ! last-line @ .end ! ;
|
|
|
|
\ do I need to scroll?
|
|
: SCROLL? ( row#1 -- row#2 )
|
|
DUP BOTTOM > IF SCRUP DROP BOTTOM topline @ top-old ! ELSE
|
|
DUP TOP < IF SCROWN 1+ topline @ top-old ! THEN THEN ;
|
|
|
|
\ where to put the cursor
|
|
: CURSOR! ( -- )
|
|
char-now @
|
|
DUP line-now @ 1- 0 MAX C>L DUP line-now !
|
|
DUP >Y SCROLL? -ROT LINE @ - DUP col# ! LINE#-SPACE +
|
|
SWAP CURSOR> 2! ;
|
|
|
|
\ should I redisplay the entire text area?
|
|
: ?FRAME ( -- )
|
|
topline @ top-old @ <>
|
|
IF topline @ .start ! last-line @ .end ! THEN ;
|
|
|
|
|
|
\ .status
|
|
|
|
\ display of and the statistic
|
|
: .OF ( n -- ) [CHAR] / EMIT U. ;
|
|
|
|
\ display max
|
|
: .MAX ( n -- )
|
|
[CHAR] m EMIT U. SPACE ;
|
|
|
|
\ display status line
|
|
: .STATUS ( -- )
|
|
STATUS-LINE RUB
|
|
[CHAR] C EMIT SPACE char-now @ 1+ U. doc-size @ 1+ .OF CMAX .MAX
|
|
last-line @ line-now @
|
|
PAGE#-SPACE IF 2DUP THEN
|
|
[CHAR] L EMIT SPACE 1+ U. 1+ .OF LMAX .MAX
|
|
PAGE#-SPACE
|
|
IF [CHAR] P EMIT SPACE PAGE-LINE DROP U.
|
|
PAGE-LINE DROP .OF THEN
|
|
." Col " col# @ 1+ U.
|
|
;
|
|
|
|
|
|
\ .result
|
|
: .RESULT ( -- )
|
|
CURSOR! ?FRAME .TLINES .STATUS
|
|
CURSOR> 2@ AT-XY ;
|
|
|
|
|
|
\ begin and end
|
|
|
|
\ virgin mother
|
|
\ reserve memory for text and lines data
|
|
: MOTHER ( -- )
|
|
ALLOCATING
|
|
IF DO-ALLOCATE ELSE DO-ALLOT THEN
|
|
0>LMAX ;
|
|
|
|
: VIRGIN ( -- )
|
|
MOTHER
|
|
0 doc-size ! 0 last-line !
|
|
0 char-now ! 0 line-now !
|
|
0 topline ! 0 way# !
|
|
BL TO "bl" BL TO "cr" BL TO "other"
|
|
FALSE TO FOUND
|
|
['] NOP DUP TO (?MARK) TO (?BLOCK) ;
|
|
|
|
\ yes, I wrote most of this
|
|
: (c) ( -- )
|
|
PAGE 13 12 AT-XY ." LF v1.0 "
|
|
." Copyright 1997 Leo Wong. All rights reserved." ;
|
|
|
|
\ our story begins
|
|
: START ( -- )
|
|
VIRGIN
|
|
?BEEPS (c)
|
|
?MARGIN GET-DOCUMENT .SCREEN FORMAT .RESULT
|
|
?BACKUP ;
|
|
|
|
\ finish
|
|
FALSE VALUE DONE \ true if leaving LF
|
|
|
|
\ offer to save before leaving
|
|
: FINISH ( -- )
|
|
BANNER-LINE RUB ." Save " .FILENAME ." (Y/n)?" IN-KEY
|
|
AND BL OR [CHAR] n <> IF SAVE-DOC THEN TRUE TO DONE ;
|
|
|
|
|
|
\ help - designed for 25 lines
|
|
|
|
\ leave help
|
|
: BACK-TO-TEXT ( -- )
|
|
.SCREEN topline @ .start ! last-line @ .end !
|
|
.RESULT BANNER ;
|
|
|
|
\ show help
|
|
: HELP ( -- )
|
|
PAGE
|
|
4 0 AT-XY ." when in TEXT ENTRY:"
|
|
0 1 AT-XY ^COMMAND DUP EMIT EMIT ." enter COMMANDs"
|
|
|
|
4 3 AT-XY ." when COMMANDing:"
|
|
0 4 AT-XY ^COMMAND EMIT ." return to TEXT ENTRY"
|
|
|
|
0 6 AT-XY ^Find-string EMIT ." Find"
|
|
0 7 AT-XY ^find-aGain EMIT ." find aGain"
|
|
0 8 AT-XY ^Replace EMIT ." Replace"
|
|
0 9 AT-XY ^replace-Too EMIT ." replace Too"
|
|
|
|
0 11 AT-XY ^(un)mark(1) EMIT ." mark<->unmark"
|
|
0 12 AT-XY ^Copy EMIT ." Copy marked"
|
|
0 13 AT-XY ^Delete EMIT ." Delete char / cut marked"
|
|
0 14 AT-XY ^Embed EMIT ." Embed (paste) copied/cut"
|
|
|
|
0 16 AT-XY ^inVest EMIT ." inVest (insert) a file"
|
|
0 17 AT-XY ^Wedge EMIT ." Wedge in text"
|
|
|
|
0 19 AT-XY ^Alter-input EMIT ." insert<->overwrite"
|
|
0 20 AT-XY ^Show EMIT ." show<->hide spaces/CRs"
|
|
|
|
0 22 AT-XY ^change-name EMIT ." change filename"
|
|
|
|
38 0 AT-XY ." when COMMANDing:"
|
|
|
|
34 2 AT-XY ." cursor moves:"
|
|
|
|
34 4 AT-XY ^right EMIT ." right"
|
|
34 5 AT-XY ^left EMIT ." left"
|
|
34 6 AT-XY ^up EMIT ." up"
|
|
34 7 AT-XY ^down(1) EMIT ." or "
|
|
^down(2) EMIT ." down"
|
|
|
|
34 9 AT-XY ^1st-col EMIT ." first column"
|
|
34 10 AT-XY ^last-col(1) EMIT ." last column"
|
|
|
|
34 12 AT-XY ^page-up EMIT ." page up"
|
|
34 13 AT-XY ^page-down(1) EMIT ." page down"
|
|
|
|
34 15 AT-XY ^TOP EMIT ." top of page"
|
|
34 16 AT-XY ^BOP(1) EMIT ." bottom of page"
|
|
|
|
34 18 AT-XY ^BOF EMIT ." beginning of document"
|
|
34 19 AT-XY ^EOF EMIT ." end of document"
|
|
|
|
34 21 AT-XY ^Save EMIT ." Save document"
|
|
|
|
34 22 AT-XY ^good-Bye EMIT ." Bye to LF"
|
|
|
|
14 24 AT-XY ." Press a key to leave this screen"
|
|
|
|
IN-KEY 2DROP BACK-TO-TEXT ;
|
|
|
|
|
|
\ most commands depend on whether you're inserting,
|
|
\ overwriting, or marking text
|
|
\ Insert Overwrite Marking
|
|
3 WAYS <.WAY> .INSERT .OVERWRITE .MARKING
|
|
3 WAYS CHARACTER INSERT OVERWRITE DEEP
|
|
3 WAYS ENTER PARAGRAPH RETURN RETURN
|
|
3 WAYS BACKSPACE <DELETE <DELETE ?BEEP
|
|
3 WAYS TABITHA NUDGE HOP ?BEEP
|
|
3 WAYS FIND-1ST SEEK? SEEK? ?BEEP
|
|
3 WAYS FIND-AGAIN SEEK SEEK ?BEEP
|
|
3 WAYS REPLACE PUT? PUT? ?BEEP
|
|
3 WAYS REPLACE-TOO PUT PUT ?BEEP
|
|
3 WAYS ~MARK +MARK +MARK -MARK
|
|
3 WAYS COPY ?BEEP ?BEEP APE
|
|
3 WAYS EMBED PASTE PASTE ?BEEP
|
|
3 WAYS DELE DELETE DELETE CUT
|
|
3 WAYS WEDGE STUFF STUFF ?BEEP
|
|
3 WAYS QUERY-HELP HELP HELP HELP
|
|
3 WAYS ~INPUT ~INSERT ~INSERT ?BEEP
|
|
3 WAYS ~SHOW ~DISPLAY ~DISPLAY ~DISPLAY
|
|
3 WAYS SAVING SAVE-DOC SAVE-DOC SAVE-MARKED
|
|
3 WAYS INVEST FROM> FROM> ?BEEP
|
|
\ 3 WAYS PRINT (PRINT) (PRINT) BPRINT
|
|
\ 3 WAYS 2PRINT (2PRINT) (2PRINT) 2BPRINT
|
|
|
|
\ there had to be a (.WAY)
|
|
' <.WAY> TO (.WAY)
|
|
|
|
|
|
\ control keys
|
|
\ control-key handler
|
|
: CONTROL-KEY? ( u -- )
|
|
CASE
|
|
'CR OF ENTER ENDOF
|
|
BS OF BACKSPACE ENDOF
|
|
HT OF TABITHA ENDOF
|
|
?BEEP
|
|
ENDCASE ;
|
|
|
|
|
|
\ command mode
|
|
|
|
\ toggle text-entry and command modes
|
|
: ~COMMANDING ( -- )
|
|
COMMANDING 0= DUP TO COMMANDING
|
|
IF BACKSPACE
|
|
way# @ 1 = VANQUISHED AND ?DUP IF INSERT LEFT THEN
|
|
ELSE way# @ 2 = IF -MARK THEN THEN
|
|
BANNER .RESULT ;
|
|
|
|
\ am I commanding?
|
|
: COMMAND-MODE? ( c -- f )
|
|
^COMMAND = ^COMMAND PREVIOUS-KEY = AND COMMANDING OR ;
|
|
|
|
\ so that the space bar can be used in command mode
|
|
: SPACE-BAR ( -- ) BL CHARACTER ;
|
|
|
|
\ command-mode key handler
|
|
: COMMAND-MODE ( c1 -- c2 )
|
|
>UPPER
|
|
CASE
|
|
|
|
\ cursor keys
|
|
^left OF LEFT ENDOF
|
|
^right OF RIGHT ENDOF
|
|
^up OF UP ENDOF
|
|
^down(1) OF DOWN ENDOF
|
|
^down(2) OF DOWN ENDOF
|
|
^down(3) OF DOWN ENDOF
|
|
^1st-col OF <LEFT ENDOF
|
|
^last-col(1) OF RIGHT> ENDOF
|
|
^last-col(2) OF RIGHT> ENDOF
|
|
^page-up OF PAGE-UP ENDOF
|
|
^page-down(1) OF PAGE-DOWN ENDOF
|
|
^page-down(2) OF PAGE-DOWN ENDOF
|
|
^BOF OF >BOF ENDOF
|
|
^EOF OF >EOF ENDOF
|
|
^TOP OF >TOP ENDOF
|
|
^BOP(1) OF >BOTTOM ENDOF
|
|
^BOP(2) OF >BOTTOM ENDOF
|
|
|
|
\ function keys
|
|
^Find-string OF FIND-1ST ENDOF
|
|
^find-aGain OF FIND-AGAIN ENDOF
|
|
^Replace OF REPLACE ENDOF
|
|
^replace-Too OF REPLACE-TOO ENDOF
|
|
|
|
^(un)mark(1) OF ~MARK ENDOF
|
|
^(un)mark(2) OF ~MARK ENDOF
|
|
|
|
^Delete OF DELE ENDOF
|
|
^Wedge OF WEDGE ENDOF
|
|
^inVest OF INVEST ENDOF
|
|
|
|
^Copy OF COPY ENDOF
|
|
^Embed OF EMBED ENDOF
|
|
|
|
^COMMAND OF ~COMMANDING ENDOF
|
|
|
|
^Query OF QUERY-HELP ENDOF
|
|
|
|
^Alter-input OF ~INPUT ENDOF
|
|
^Show OF ~SHOW ENDOF
|
|
^change-name OF ~NAME ENDOF
|
|
|
|
^Save OF SAVING ENDOF
|
|
^good-Bye OF FINISH ENDOF
|
|
|
|
\ -control-keys
|
|
|
|
-Enter-key(1) OF ENTER ENDOF
|
|
-Enter-key(2) OF ENTER ENDOF
|
|
-Backspace-key(1) OF BACKSPACE ENDOF
|
|
-Backspace-key(2) OF BACKSPACE ENDOF
|
|
-Tab-key(1) OF TABITHA ENDOF
|
|
-Tab-key(2) OF TABITHA ENDOF
|
|
|
|
\ space in command mode
|
|
BL OF SPACE-BAR ENDOF
|
|
|
|
DUP CONTROL-KEY?
|
|
|
|
ENDCASE 0 ;
|
|
|
|
|
|
\ process
|
|
|
|
\ get ready to process a keyboard event
|
|
: PROCESS> ( -- )
|
|
line-now @ DUP line-old ! 1-
|
|
topline @ DUP top-old !
|
|
last-line @ DUP last-old ! CLAMP
|
|
DUP .start ! 1- DUP .end ! .mend ! ;
|
|
|
|
\ process a character
|
|
: KEYBOARD-CHARACTER ( c -- )
|
|
DUP COMMAND-MODE? IF COMMAND-MODE ELSE
|
|
DUP BL LAST-DISPLAYABLE BETWEEN IF DUP CHARACTER ELSE
|
|
DUP CONTROL-KEY?
|
|
THEN THEN
|
|
DROP ;
|
|
|
|
\ process other keyboard event (such as a cursor key)
|
|
\ if using ekey
|
|
: OTHER-KEYBOARD-EVENT ( u -- ) DEEP ;
|
|
|
|
\ handle a keyboard event
|
|
: PROCESS-KEY ( c flag -- )
|
|
PROCESS>
|
|
2DUP AND COMMANDING OR >R \ if commanding, hide key
|
|
IF KEYBOARD-CHARACTER
|
|
ELSE OTHER-KEYBOARD-EVENT THEN
|
|
R> TO PREVIOUS-KEY ;
|
|
|
|
|
|
\ LF, an NPBP ANS Forth word processor
|
|
: LF ( -- )
|
|
FALSE TO COMMANDING FALSE TO DONE START
|
|
BEGIN IN-KEY
|
|
PROCESS-KEY ?BLOCK .RESULT
|
|
DONE UNTIL ?DE-ALLOCATE PAGE ;
|
|
|
|
|
|
LF \ start LF
|