\ TED.F
\
\ TED - A Tiny Text Editor for DX-Forth
\
\ Based on the HT-68K editor by J.Bartel
\
\ The HELP screen is only compiled for the
\ turnkey version
\
\ ^E Up cursor ^R Prev page
\ ^X Down cursor ^C Next page
\ ^D Right cursor ^G Del next char
\ ^S Left cursor ^H Del prev char
\ ^L Restore line ^M New line
\ ^T Erase to EOL ^Y Delete line
\ ^U Exit editor ^Z Function
\ ^ZC Clear text ^ZH Help
\ ^ZR Read file ^ZW Write file
\
\ Revision
\ 2016-09-25 es updated for DX-Forth
\ 2015-06-03 es specify a filename
\ 2015-12-09 es join lines with ^G or DEL
\ 2017-01-25 es replace EXIT THEN with END
forth definitions decimal
0 \ true for turnkey
( *) dup [if] application [then]
cr .( loading TED Text Editor )
\ Running DX-Forth for CP/M or DOS ?
: CPM? ( -- f ) $111 @ $4683 = ;
[undefined] ZCOUNT [if]
: ZCOUNT ( a -- a u ) dup -1 0 scan drop over - ;
[then]
[undefined] ZPLACE [if]
: ZPLACE ( a -- a u ) 2dup + >r swap cmove 0 r> c! ;
[then]
[undefined] PACK [if]
: PACK ( a u a2 -- a2 ) dup >r place r> ;
[then]
[undefined] TOKEN [if]
: TOKEN ( "name" -- c-addr u ) bl word count ;
[then]
\ Video terminal specific
79 value XMAX \ #columns - 1
24 value YMAX \ #rows - 1
\ INSERT-LINE ( -- ) insert blank line at cursor;
\ remaining rows scroll down
\ DELETE-LINE ( -- ) delete line at cursor;
\ remaining rows scroll up
\ CLEAR-LINE ( -- ) blank from cursor to end of line
\ pointer operations
: 1+! ( a -- ) 1 swap +! ;
: 1-! ( a -- ) -1 swap +! ;
: C@+ ( a -- c ) dup @ c@ swap 1+! ;
: C!+ ( c a -- ) tuck @ c! 1+! ;
: -C@ ( a -- c ) dup 1-! @ c@ ;
: -C! ( c a -- ) dup 1-! @ c! ;
\ max line length
132 constant COLS
0 value YBOT \ edit bottom row
0 value BUF \ edit buffer addr
0 value BUFE \ edit buffer end + 1
0 value TBUF \ text buffer addr
0 value LINES \ line count
0 value MEM \ top of memory
0 value FNAM \ filename buffer addr
0 value FID \ file handle
variable COL \ current column#
variable LIN \ current line#
variable LADR \ current line addr
variable LTOP \ absolute line# at top of screen
variable LPOS \ current line# relative to top of screen
variable BPOS \ address of char in edit buffer
variable NXT \ next free addr in text (contains 0)
variable UPD \ edit buffer change flag
variable XF \ quit flag
: UKEY ( -- c ) key upcase ;
: LMAX ( -- n ) lines 1- 0 max ;
: GOXY ( x y -- ) 1+ at-xy ;
: CXY ( -- ) col @ XMAX min lpos @ goxy ;
: MSG ( -- ) 0 0 at-xy clear-line ;
: CHGD ( -- ) upd on ;
: CONT ( -- ) xf off
." Press a key to continue " key drop ;
: .FIL ( -- ) fnam count 20 min type ;
: .POS ( -- )
13 0 at-xy lin @ 1+ u.
22 0 at-xy col @ 1+ u. cxy ;
: .HD ( -- ) msg 10 0 at-xy
[ dup ] [if]
." Ln Cl ^ZH Help File "
[else]
." Ln Cl File "
[then]
.fil .pos ;
: .ERR ( a u -- ) msg .fil space space type cont .hd ;
: SURE? ( a u -- f )
msg type ." Are you sure? " ukey [char] Y = ;
: LINE ( -- a u ) ladr @ zcount ;
: .LINE ( -- ) line XMAX 1+ min type ;
: .RT ( -- ) \ display string right of cursor
bpos @ bufe over - XMAX 1+ bpos @ buf - - min type ;
: ROOM? ( -- f ) bufe 1- c@ bl = ;
: LINE@ ( -- lin adr ) lin @ ladr @ ;
: LINE! ( lin adr -- ) ladr ! lin ! ;
: GOTOP ( -- ) tbuf ladr ! lin off ;
: CURTOP ( -- )
gotop ltop off col off lpos off ;
\ clear text, filename, reset cursor
: -TXT ( -- ) tbuf dup 1- 3 erase ( nulls )
1+ nxt ! 1 to lines 0 fnam c! curtop ;
: SETUP ( -- )
[ cpm? ] [if]
$168 c@ 1- to XMAX
$169 c@ 1- dup to YMAX 2- to YBOT
[else]
get-window ( x1 y1 x2 y2 )
rot - dup to YMAX 2- to YBOT
swap - to XMAX
[then]
application here unused + to mem pad 80 +
dup to fnam 80 + dup to buf COLS + dup to bufe
2+ dup to tbuf mem u> abort" no space" -txt ;
: INSC ( c -- ) \ insert char in buf
bpos @ dup 1+ bufe over - 1+ cmove>
bpos c!+ ;
: LU ( -- ) \ go up one line in text
lin 1-!
ladr dup 1-! begin dup -c@ 0= until 1+! ;
: LD ( -- ) \ go down one line in text
lin 1+! ladr begin dup c@+ 0= until drop ;
: SETLIN ( n -- ) \ setup for line n
tbuf over 0 ?do zcount + 1+ loop
ladr ! lin ! ;
: LINES+ ( -- ) lines 1+ to lines ;
: LINES- ( -- ) lines 1- to lines ;
: ?MEM ( -- )
nxt @ mem u< not if s" no space" .err then ;
: REPL ( a u -- ) \ replace line in text
>r line r@ over - >r
over + dup r@ + nxt @ 1+ dup >r
2 pick - move 2r> + dup off nxt !
r> cmove ?mem ;
: BSTR ( -- a u ) \ string in buffer
buf bufe over - -trailing ;
: LEAV ( -- ) \ leave the line we are on
upd @ if bstr repl then upd off ;
: ENTER ( -- ) \ start changes on this line
line buf dup COLS blank swap cmove
buf col @ + bpos ! upd off ;
: .ALL ( -- ) \ update screen
leav enter
page line@
ltop @ dup setlin
lmax swap - YBOT min
1+ 0 ?do 0 i goxy .line ld loop
line! .hd cxy ;
: SLN ( ltop lin -- )
>r 0 max lmax min dup r> max lmax min
dup setlin over - lpos ! ltop ! .all ;
: PU ( -- ) \ ^R page up
lin @ if
leav ltop @ YBOT - lin @ YBOT - sln
then ;
: PD ( -- ) \ ^C page dn
lin @ lines < if
leav ltop @ YBOT + lin @ YBOT + sln
then ;
: SU ( -- ) \ scroll up, new line at bottom
0 0 goxy delete-line 0 YBOT dup lpos ! goxy ;
: SD ( -- ) \ scroll down, new line at top
0 0 goxy insert-line lpos off ;
-? : UP ( -- ) \ ^E line up
lin @ if
leav lu
lin @ ltop @ 1- = if
sd .line ltop 1-!
else
lpos 1-!
then
enter .pos
then ;
: DN ( -- ) \ ^X line dn
lin @ lines < if
leav ld
lin @ ltop @ YBOT 1+ + = if
su .line ltop 1+!
else
lpos 1+!
then
enter .pos
then ;
: RT ( -- ) \ ^D right
col @ XMAX < if
col 1+! bpos 1+! .pos
then ;
: LFT ( -- ) \ ^S left
col @ if
bpos 1-! col 1-! .pos
then ;
: TAB ( -- ) \ ^I tab
4 col @ over mod - 0 do rt loop ;
: NLN ( -- ) \ ^M new line
room? if
13 insc chgd leav
ladr begin dup c@+ 13 = until 0 over -c! 1+!
lines+ lin 1+!
clear-line col off enter
lpos @ YBOT = if
su ltop 1+!
else
lpos 1+! insert-line cxy
then
.all
then ;
: DEL ( -- ) \ ^G del next
bpos @ bstr + < if ( del char)
bpos @ dup 1+ swap bufe bl over c! over - 1+ cmove
.rt cxy chgd
else ( join line)
chgd leav line COLS over - >r
+ dup 1+ zcount r> min rot zplace .all
then ;
: BS ( -- ) \ ^H del prev
col @ if lft del then ;
: DLN ( -- ) \ ^Y del line
lin @ lines < if
ladr @
ld enter 13 ladr -c!
ladr !
chgd leav enter
lines- lin 1-!
delete-line
ltop @ YBOT + lines < if
line@
ltop @ YBOT + setlin 0 YBOT goxy .line
line!
then
.pos
then ;
: RST ( -- ) \ ^L restore line
0 lpos @ goxy clear-line .line cxy
enter ;
: DEOL ( -- ) \ ^T delete to EOL
bufe bpos @ - blank
clear-line cxy chgd ;
: CHAROK ( c -- )
dup bl 126 between room? and if
dup insc dup emit col 1+! .rt
.pos chgd
then drop ;
: CLR ( -- ) \ ^ZC
s" *** Clear text: " sure? if leav -txt then
.all ;
: GETN ( -- a u ) msg ." Filename: "
pad dup XMAX 10 - accept ;
: STNAM ( a u -- a u )
2dup fnam pack count upper 0 to fid ;
: CLOSF ( -- ) fid ?dup if close-file drop then ;
: CLN ( a u -- ) \ ctl chars to spaces
over + swap ?do i c@ bl max i c! loop ;
: (RD) ( a u -- )
stnam r/w open-file throw to fid
0 to lines tbuf dup off dup 1+ nxt !
( a) begin
dup COLS 2dup + mem u> throw
fid read-line throw ( a u' f )
while
2dup cln + 0 over c! ( null)
1+ dup nxt ! lines+
repeat 2drop nxt @ off ;
: RD ( a u -- )
s" F" +ext ( append .F extension if none )
leav ['] (rd) catch if
2drop s" load/size error" .err -txt
then closf curtop .all ;
: (WR) ( a u -- )
stnam r/w create-file throw to fid
tbuf begin ( a)
dup nxt @ u<
while
zcount 2dup fid write-line drop + 1+
repeat drop ;
: WR ( a u -- )
leav ['] (wr) catch if
2drop s" save error" .err
then closf .all ;
: ZRD ( -- ) \ ^ZR read file into text buffer
getn rd .hd ;
: ZWR ( -- ) \ ^ZW write text to file
getn wr .hd ;
: SAV ( -- )
fnam count dup 0= if 2drop getn then wr ;
dup [if]
: HLP ( -- ) \ ^ZH help
leav page 14 spaces ." Help Menu"
cr ." ^E Up cursor ^R Prev page"
cr ." ^X Down cursor ^C Next page"
cr ." ^D Right cursor ^G Del next char"
cr ." ^S Left cursor ^H Del prev char"
cr ." ^L Restore line ^M New line"
cr ." ^T Erase to EOL ^Y Delete line"
cr ." ^U Exit editor ^Z Function"
cr ." ^ZC Clear text ^ZH Help"
cr ." ^ZR Read file ^ZW Write file"
cr cr cont .all ;
[then]
: FN ( -- ) \ ^Z function
[ dup ] [if]
msg ." *** (R)ead, (W)rite, (C)lear, (H)elp ? " ukey
[char] H of hlp end \ ^ZH help
[else]
msg ." *** (R)ead, (W)rite, (C)lear ? " ukey
[then]
[char] C of clr end \ ^ZC clear
[char] R of zrd end \ ^ZR read
[char] W of zwr end \ ^ZW write
drop .hd ;
: DONE ( -- ) \ ^U Quit editor
msg ." *** Exit: (S)ave, (Q)uit ? " ukey
[char] Q of xf on end
[char] S of sav xf on end
drop .hd ;
: KMAP ( c1 -- c2 ) \ map in arrow keys etc
[ cpm? ] [if]
$14F c@ of 5 end $150 c@ of 24 end
$151 c@ of 4 end $152 c@ of 19 end
127 of 7 end
[else]
200 of 5 end 208 of 24 end
205 of 4 end 203 of 19 end
211 of 7 end
210 of 22 end 201 of 18 end
209 of 3 end 199 of 17 end
[then] ;
: CMD ( -- ) key kmap
3 of pd ( ^C) end 4 of rt ( ^D) end
5 of up ( ^E) end 7 of del ( ^G) end
8 of bs ( ^H) end 9 of tab ( ^I) end
12 of rst ( ^L) end 13 of nln ( ^M) end
18 of pu ( ^R) end 19 of lft ( ^S) end
20 of deol ( ^T) end 21 of done ( ^U) end
24 of dn ( ^X) end 25 of dln ( ^Y) end
26 of fn ( ^Z) end
charok ;
\ Load & edit textfile addr len. If len=0 don't load.
: (TED) ( line addr len -- )
setup page .hd
?dup if
rd ( line ) 1- dup 7 - swap sln
else 2drop then
enter xf off begin cmd xf @ until
0 YMAX at-xy cr cr ;
( *) [if]
\ Turnkey version
-? : TED ( -- ) 1 cmdtail (ted) ; turnkey ted ted bye
[else]
\ Resident version
-? : TED ( "filename[.F]" -- ) token dup if 1 -rot
else 2drop loadline @ lastfile then (ted) ;
\ aka TED EDIT
behead cpm? cmd
[then]
forth definitions application
Top Home Forth
Page updated: 2017-01-25