z.fs

.( z: a durexForth block editor. ) cr
\ 25x40 screens vi-clone. yanks to pad.

require block
marker -- \ -z---
header edit \ [b-] edit block b
header z    \ [-] resume editing

.( scn )
\ [-] emit (w)y, ctl codes as '?'
: 1em  [ w lda,(y) $a1 cmp,#  10 bcs,
 $7f cmp,#  4 bcs,  bl cmp,#  2 bcs,
 '?' lda,#  iny,  $e716 jmp, ] ;
: 39em  [ lsb lda,x  msb ldy,x
 w sta,  w 1+ sty, 0  ldy,# ]
 1em [ 39 cpy,#  -7 bne, ] ;
: lines  1- 0 ?DO 39em 1em
 40 + LOOP 39em drop ; \ [au-]
\ [a-] toggle reverse on screen
: @rvs/  dup c@ $80 xor swap c! ;
: rvs-  146 emit ;   : bdr!  $d020 c! ;
: at-xy  xr ! yr ! $e50c sys ;
: done  0 bdr! 0 24 at-xy cr rvs- ;
: bzz  0 bdr! 999 0 DO LOOP ;
: ?exit  IF bzz r> drop THEN ;

.( vals )
0 value yankc \ pad ringbuf idx 39mod
2 value mode  \ border color 11c 6i 5r
1 value dirty \ redraw all lines?
0 value text  \ buffer base addr
0 value sol   \ start-of-line 0-960
0 value col   \ cursor column 0-39
: tsol text sol + ; : tnext tsol 40 + ;
: tcsr tsol col + ; : rest  39 col - ;
: csr/  sol col + $400 + @rvs/ ;
: */bl  updated? IF '*' ELSE bl THEN ;
: draw  sol 40 / >r dirty IF
 0  0 at-xy text 25 ELSE
 0 r@ at-xy tsol  1 THEN rvs- lines rvs
 33 0 at-xy scr @ dup */bl emit .
 0 r> at-xy mode bdr! 0 to dirty ;

.( file )
: d!  1 to dirty ;
: scr!  d! dup block to text scr ! ;
: next!  scr @ 2+    scr! ;
: prev!  scr @ 1- 1- scr! ;
: flip!  scr @ 1 xor scr! ;
: blank  bl fill ;
: wipe  d! text 1024 blank ;
: trunc  text 999 + 25 blank ;
: trup  trunc update ;
: save  d! trup save-buffers key drop ;
: run drop done trunc scr @ load quit ;
: quitz  2drop done quit ;

.( core ) \ -* [-]r *c [a-aa] *mv [aa-]
: -sol  col 1 < ?exit ; \ nb. tce!!
: -btm  sol 959 > ?exit ;
: 1c  dup 1+ ;      : 40c  dup 40 + ;
: $mv  rest move ;  : 39mv  39 move ;
: s-mv  sol - move d! ; \ [aau-]
: Gmv  960 s-mv ;   : jGmv  920 s-mv ;

.( edit ) \ [-] if not marked
: bl$  tcsr rest blank ;
: blip  bl tsol 39 + c! ;
: putc  dup tcsr c! blip ; \ [c-c]
: openc  tcsr 1c $mv blip ;
: indent tsol 1c 39mv blip bl tsol c! ;
: delc  blip tcsr 1c swap $mv ;
: outdent  blip tsol 1c swap 39mv ;
: yank  tsol pad 39mv ;
: put  pad tsol 39mv ;
: open  tsol 40c Gmv ;
: blot  text 960 + 40 blank ;
: del  yank tsol 40c swap Gmv blot ;
: split  -btm tnext 40c jGmv
 tnext 40 blank tcsr tnext $mv bl$ ;
: join  -btm tnext tcsr $mv
 tnext 40c swap jGmv blot ;

cr .( csr )
: +col  col + 0 max  39 min to col ;
: +sol  sol + 0 max 960 min to sol ;
: 5h! -5 +col ;    : 5k! -200 +sol ;
: h!  -1 +col ;    : k!   -40 +sol ;
: l!   1 +col ;    : j!    40 +sol ;
: 5l!  5 +col ;    : 5j!  200 +sol ;
: 0!   0 to col ;  : hi!   0 to sol ;
: zz! 18 to col ;  : md! 480 to sol ;
: $!  39 to col ;  : lo! 960 to sol ;

.( combo ) \ repc insc [c-c]
: repc  putc l! ;  : insc  openc repc ;
: ins  open put ;  : jins -btm j! ins ;
: 0j!  0! j! ;     : ret  split 0j! ;
: pady  yankc 39 mod pad + ;
: >y  yankc 1- to yankc pady c! ;
: y>  pady c@ yankc 1+ to yankc ;
: bsp  -sol h! tcsr c@ >y delc ;
: unbsp  y> insc drop ;

.( mode )
: rm!  5 to mode ; : cm!  11 to mode ;
: im!  6 to mode ;
: bim!  bl$ im! ;  : 0im!  0! im! ;
: 0bim!  0! bim! ; : obim! open 0bim! ;
: jobim!  -btm j! obim! ;

.( kb1 )
\ [cxaa-] scan keylist a2 to a1 for
\ cmd [-] or [c-c], or use default xt
: kdo  DO over i c@ = IF drop i 1+ @
 leave THEN 3 +LOOP execute drop ;
here 999 allot : -> c, ' , ; to here

header k:
 'q' -> quitz
 'w' -> save   ':' -> trup
header k5
 'h' -> 5h!    'k' -> 5k!
 'l' -> 5l!    'j' -> 5j!
header kd
 'd' -> del    '%' -> wipe
header kb1
: :?  key ['] bzz ['] k5 ['] k: kdo ;
: 5?  key ['] bzz ['] kd ['] k5 kdo ;
: d?  key ['] bzz ['] kb1 ['] kd kdo ;
: r?  key putc drop ;

.( kb2 )
header krep
 $14 -> h!     $94 -> l!  \ (s-)del
 $0d -> 0j!    $8d -> k!  \ (s-)ret
header kcmd
 $0d -> split  $8d -> join
header kins
 $9d -> h!     $1d -> l!  \ csr
 $91 -> k!     $11 -> j!
 $14 -> bsp    $94 -> unbsp
 $0d -> ret
 $5f -> cm!    $1b -> cm! \ <- c-[
header khjk
 'h' -> h!     'k' -> k!
 'l' -> l!     'j' -> j!
 '0' -> 0!     'H' -> hi!
 'z' -> zz!    'M' -> md!
 '$' -> $!     'L' -> lo!
 '5' -> 5?
 ':' -> :?     'y' -> yank
 'r' -> r?     'R' -> rm!
 'd' -> d?     'D' -> bl$
 'x' -> delc   'X' -> bsp
 '>' -> indent '<' -> outdent
 'i' -> im!    'I' -> 0im!
 'C' -> bim!   'S' -> 0bim!
 'O' -> obim!  'o' -> jobim!
 'P' -> ins    'p' -> jins
 '[' -> prev!  ']' -> next!
 '\' -> flip!  $a9 -> d! \ s-\
 $88 -> run \ f7
header kb2

.( main )
define edit  scr! 0 +col 0 +sol cm!
 $80 $28a ( allkeys repeat ) c! BEGIN
 depth >r draw csr/ key csr/ mode CASE
 6 OF ['] insc ['] khjk ['] kins ENDOF
 5 OF ['] repc ['] khjk ['] krep ENDOF
 drop ['] bzz  ['] kb2  ['] kcmd 0
 ENDCASE kdo depth r> <> abort" dep"
 AGAIN ;

define z  scr @ edit ;
\ parse-name z find-name to latest
cr .( words: edit z ) cr