\ Article: 101906 of comp.lang.forth \ Path: tunews.univie.ac.at!aconews-feed.univie.ac.at!newsfeed.wu-wien.ac.at!newsfeed.utanet.at!news.cambrium.nl!news.cambrium.nl!news2.euro.net!216.196.110.149.MISMATCH!border2.nntp.ams.giganews.com!nntp.giganews.com!fr.ip.ndsoftware.net!proxad.net!freenix!sn-xit-02!sn-xit-06!sn-post-01!supernews.com!corp.supernews.com!not-for-mail \ From: Guy Macon \ Newsgroups: comp.lang.forth \ Subject: lf v0.0.12f.kforth by Leo Wong source code \ Date: Fri, 09 Jul 2004 01:44:40 -0700 \ Organization: http://www.guymacon.com \ Message-ID: <10esmnvmhifh9df@corp.supernews.com> \ MIME-Version: 1.0 \ Content-Type: Text/Plain; charset=US-ASCII \ X-Complaints-To: abuse@supernews.com \ Lines: 1786 \ Xref: tunews.univie.ac.at comp.lang.forth:101906 \ I am posting this so that anyone searching \ the Usenet archive will be able to find it. \ ****** Start of program listing ****** \ lf v0.0.12f.kforth 09 September 2002 + \ Note: Two versions of this program have been \ published with the same version number; \ ("lf v0.0.12f 06 August 2002 +"). I renamed \ the modified version to "lf v0.0.12f.kforth \ 09 September 2002 +" and added this note to \ both versions on 04 July 2004. \ - Guy Macon http://www.guymacon.com/ \ 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) \ : >NUMBER number? DROP D+ 0 0 ; \ ok to use here, but not ANS compliant \ ============== 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) 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 : 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 ptr (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 ptr TEXT \ start of text area 0 VALUE CMAX \ max # of characters 0 ptr 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 : 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 ptr (.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 ptr (?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 ptr (.LINE#) ' NOP ptr (.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 \ 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 : 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 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 : ( -- ) 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 ptr ?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-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 : ( -- 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 ptr (?BLOCK) : ?BLOCK (?BLOCK) EXECUTE ; \ start marking : +MARK ( -- ) way# DUP @ was ! 2 SWAP ! ['] MARK TO (?MARK) ['] TO (?BLOCK) BLOCK-IN bstart ! topline @ btop ! -1 top-old ! BANNER ; \ leave marking : -MARK ( -- ) .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 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 ; \ : ( 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 @ ; \ : bprinting ( n -- ) ; \ : (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 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 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 \ s****** End of program listing ****** \ -- \ Guy Macon \ http://www.guymacon.com/ \