\ More commands added 2006-06-26 -- Joshua I. Grams
\
\ VIBE Release 2.1
\ Copyright (c) 2001-2003 Samuel A. Falvo II
\ All Rights Reserved.
\
\
\ Highly portable block editor -- works under nearly every ANS Forth
\ I can think of, and with only a single screenful of words, will
\ work under Pygmy and FS/Forth too.
\
\ USAGE: vibe ( n -- ) Edits block 'n'.  Sets SCR variable to 'n'.
\        ed ( -- ) From Pygmy.  Re-edits last edited block.
\
\ I use CREATE instead of VARIABLE because I can statically initialize
\ the variables at load-time with no overhead.  Stole this idea from a7r
\ in the #Forth IRC channel.
\
\ 2.1 -- Fixed stack overflow bugs; forgot to DROP in the non-default
\        key handlers.
\

( Editor Constants )

CHAR c CONSTANT 'c
CHAR i CONSTANT 'i
CHAR r CONSTANT 'r

CHAR y CONSTANT 'y
CHAR n CONSTANT 'n

CHAR A CONSTANT 'A
CHAR Z CONSTANT 'Z
CHAR $ CONSTANT '$

( Editor State )

 0 CREATE x ,     \ Cursor X position 0..63
 0 CREATE y ,     \ Cursor Y position 0..15
'c CREATE mode ,  \ Command/Insert/Replace
 0 CREATE #reps , \ Number of times to repeat a command
 0 CREATE arg ,   \ For commands which take a parameter
 0 CREATE quit? , \ Quit flag

CREATE wordname 5 C, '$ C, '$ C, 0 C, 0 C, 0 C,

( Editor Repeat Handling )

: +digit ( char n -- ) 10 * swap [CHAR] 0 - + #reps ! ;
: times #reps @  #reps off ;
: char-param arg @ 0= IF KEY arg ! THEN arg @ ;
: reps 1 MAX 0 ;
: REP POSTPONE reps POSTPONE DO ; IMMEDIATE

( Editor Display )

: mode. 63 0 AT-XY mode @ EMIT ;
: scr. 0 0 AT-XY ." Block: " scr @ . ."      " ;
: header scr. mode. ;
: 8-s ." --------" ;
: 64-s 8-s 8-s 8-s 8-s 8-s 8-s 8-s 8-s ;
: border SPACE 64-s CR ;
: row DUP 64 TYPE 64 + ;
: line ." |" row ." |" CR ;
: 4lines line line line line ;
: 16lines scr @ BLOCK 4lines 4lines 4lines 4lines DROP ;
: card 0 1 AT-XY border 16lines border ;
: cursor x @ 1+ y @ 2 + AT-XY ;
: screen header card cursor ;

( Editor State Control )

: cmd 'c mode ! ;
: insert 'i mode ! ;
: replace 'r mode ! ;

: bounds scr @ 0 MAX 65535 MIN scr ! ;
: prevblock -2 scr +! bounds ;
: nextblock  2 scr +! bounds ;
: toggleshadow 1 scr @ XOR scr ! ;

( Editor Cursor Control )

: flushLeft 0 x ! ;
: boundX x @ 0 MAX 63 MIN x ! ;
: boundY y @ 0 MAX 15 MIN y ! ;
: bounds boundX boundY ;
: left -1 x +! bounds ;
: right 1 x +! bounds ;
: up -1 y +! bounds ;
: down 1 y +! bounds ;
: nextline y @ 15 < IF flushLeft down THEN ;
: next x @ 63 = IF nextline EXIT THEN right ;

( Editor Insert/Replace Text )

: #chrs scr @ BLOCK 1024 + swap - ;
: 64* 6 LSHIFT ;
: where 64* + scr @ BLOCK + ;
: 64/mod DUP 6 RSHIFT SWAP 63 AND ;
: >where scr @ BLOCK - DUP 64/mod x ! y ! ;
: wh x @ y @ where ;
: sol 0 y @ where ;
: eol 63 y @ where ;
: sob 0 0 where ;
: eob 63 15 where ;
: place wh C! UPDATE next ;
: -eol? x @ 63 < ;
: openr wh DUP 1+ 63 x @ - MOVE ;
: openRight -eol? IF openr THEN ;
: inserting? mode @ 'i = ;

( Editor Searching )

: -count ( c-addr -- c-addr' ch ) 1- DUP C@ ;
: word> ( -- )
   wh BEGIN DUP eob < WHILE COUNT BL = UNTIL THEN
   BEGIN DUP eob < WHILE COUNT BL <> UNTIL 1- THEN
   >where ;
: word<
   wh BEGIN DUP sob > WHILE -count BL <> UNTIL THEN
   BEGIN DUP sob > WHILE -count BL = UNTIL 1+ THEN
   >where ;
: find> ( char times -- )
   #reps ! >R wh 1+ BEGIN
      DUP eol < WHILE COUNT r@ = IF -1 #reps +! THEN
   #reps @ 0= UNTIL 1- >where THEN R> 2DROP ;
: find< ( char times -- ) 
   #reps ! >R wh BEGIN
      DUP sol >= WHILE -count r@ = IF -1 #reps +! THEN
   #reps @ 0= UNTIL >where THEN R> 2DROP ;

( Editor Backspace/Delete )

: padding 32 eol C! UPDATE ;
: del wh DUP 1+ SWAP 63 x @ - MOVE ;
: delete -eol? IF del THEN padding ;
: bs left delete ;
: backspace x @ 0 > IF bs THEN ;

( Editor Carriage Return )

: nextln eol 1+ ;
: copydown y @ 14 < IF nextln DUP 64 + sol #chrs MOVE THEN ;
: blankdown nextln 64 BL FILL UPDATE ;
: splitdown wh nextln 2DUP SWAP - MOVE ;
: blankrest wh nextln OVER - 32 FILL ;
: opendown copydown blankdown ;
: splitline opendown splitdown blankrest ;
: retrn inserting? IF splitline THEN flushleft nextline ;
: return y @ 15 < IF retrn THEN ;

( Editor Delete Line )

: blankline sol 64 BL FILL UPDATE ;
: rmline nextln sol over #chrs MOVE UPDATE ;
: deleteline y @ 15 < IF rmline ELSE blankline THEN ;

( Editor Wipe Block )

: msg 0 20 AT-XY ." Are you sure? (Y/N) " ;
: valid? DUP 'n = OVER 'y = OR ;
: uppercase? DUP 'A 'Z 1+ WITHIN ;
: lowercase DUP uppercase? IF $20 XOR THEN ;
: validkey BEGIN KEY lowercase valid? UNTIL ;
: clrmsg 0 20 AT-XY 64 SPACES ;
: no? msg validkey clrmsg 'n = ;
: ?confirm no? IF R> DROP THEN ;
: wipe ?confirm scr @ BLOCK 1024 32 FILL UPDATE 0 x ! 0 y ! ;

\ Word name key: $ $ _ _ _
\                    | | |
\ c = command mode --+ | |
\ i = ins/repl mode    | |
\                      | |
\ Key code (hex#) -----+-+
\
\ Called with ( char times -- )
\ where CHAR is the ASCII key code
\ and TIMES is the repeat count.

( Editor Movement Commands )

: $$c68 REP left LOOP DROP ;         \ h
: $$c7a REP down LOOP DROP ;         \ j
: $$c6b REP up LOOP DROP ;           \ k
: $$c6c REP right LOOP DROP ;        \ l
: $$c74 REP down LOOP DROP ;         \ t (dvorak arrow key)
: $$c63 REP up LOOP DROP ;           \ c (dvorak arrow key)
: $$c6E REP right LOOP DROP ;        \ n (dvorak arrow key)
: $$c7c 2DROP flushLeft ;            \ |
: $$c24 DROP sol 63 -TRAILING x ! 2DROP ; \ $
: $$c66 DROP char-param find> ;      \ f
: $$c46 DROP char-param find< ;      \ F
: $$c77 REP word> LOOP DROP ;        \ w
: $$c62 REP word< LOOP DROP ;        \ b
: $$c67 2DROP 0 y ! flushLeft ;      \ g
: $$c47 2DROP scr @ BLOCK 1024 -TRAILING + >where flushLeft ; \ G
: $$c5B REP prevblock LOOP DROP ;    \ [
: $$c5C 2DROP toggleshadow ;         \ \
: $$c5D REP nextblock LOOP DROP ;    \ ]

( Editor Mode Commands )

: $$c51 2DROP quit? on ;             \ Q
: $$i1B 2DROP cmd ;                  \ (escape)
: $$c69 2DROP insert ;               \ i
: $$c61 2DROP right insert ;         \ a
: $$c49 2DROP flushLeft insert ;     \ I
: $$c41 DROP $$c24 insert ;          \ A
: $$c52 2DROP replace ;              \ R
: $$c6F $$c49 opendown down ;        \ o
: $$c4F $$c49 splitline ;            \ O
\ default actions for both modes
: beep 2DROP 7 EMIT ;
: chr DROP inserting? IF openRight THEN place ;

( Editor Deletion Commands )

: $$i04 REP delete LOOP DROP ;       \ CTRL-D
: $$i08 REP backspace LOOP DROP ;    \ (bs)
: $$i7F REP backspace LOOP DROP ;    \ DEL -- for Unix
: $$i0D REP return LOOP DROP ;       \ (cr)
: $$c78 REP delete LOOP DROP ;       \ x
: $$c5A 2DROP wipe ;                 \ Z
: $$c64 REP deleteline LOOP DROP ;   \ d
: $$c44 REP blankrest LOOP DROP ;    \ D

( Editor Repeat Counts )

: $$c30 DUP IF +digit ELSE $$c7c THEN ;
: $$c31 +digit ;
: $$c32 +digit ;
: $$c33 +digit ;
: $$c34 +digit ;
: $$c35 +digit ;
: $$c36 +digit ;
: $$c37 +digit ;
: $$c38 +digit ;
: $$c39 +digit ;

( Editor Keyboard Handler )

: cmd? mode @ 'c = ;
: ins? mode @ DUP 'i = SWAP 'r = OR ;
: mode! ins? 'i AND cmd? 'c AND OR wordname 3 + C! ;
: >hex DUP 9 > 7 AND + [CHAR] 0 + ;
: h! $F0 AND 2/ 2/ 2/ 2/ >hex wordname 4 + C! ;
: l! $0F AND >hex wordname 5 + C! ;
: name! mode! DUP h! l! ;
: nomapping DROP ['] beep cmd? AND ['] chr ins? AND OR ;
: handlerword name! wordname FIND 0= IF nomapping THEN ;
: handler times OVER handlerword EXECUTE ;
: editor quit? off BEGIN KEY handler screen quit? @ UNTIL ;
: ed page screen editor 0 20 AT-XY ;
: vibe scr ! ed ;

( Block Copy )

CREATE tmp 1024 ALLOT
: copy  SWAP BLOCK tmp 1024 MOVE  tmp SWAP BLOCK 1024 MOVE  ;