\ *** Block No. 0 Hexblock 0 
\ Full-Screen Editor                                  UH 02Nov86
                                                                
Dieses File enthaelt den Full-Screen Editor fuer die CP/M -     
volksFORTH-Version.                                             
                                                                
Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion  
sowie Unterstuetzung des Shadow-Screen-Konzepts, der view-      
Funktion und des sichtbaren Laden von Screens (showload).       
                                                                
Durch die integrierte Tastaturtabelle (keytable) laesst sich die
Kommandobelegung der Tasten auf einfache Art und Weise aendern. 
                                                                
Anregungen, Kritik und Verbesserungsvorschlaege bitte an:       
                       U. Hoffmann                              
                       Harmsstrasse 71                          
                       2300 Kiel                                
\ *** Block No. 1 Hexblock 1 
\ Load Screen for the Editor             UH 03Nov86   UH 27Nov87
                                                                
Onlyforth    cr                                                 
                                                                
 1 $1E  +thru                                                   
                                                                
Onlyforth                                                       
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 2 Hexblock 2 
\ String primitves                                       27Nov87
                                                                
: delete   ( buffer size count -- )                             
   over umin dup >r -  2dup  over r@ +  -rot cmove              
   +  r> bl fill ;                                              
                                                                
: insert   ( string length buffer size -- )                     
   rot over umin dup >r -                                       
   over dup r@ +  rot cmove>   r> cmove  ;                      
                                                                
: replace   ( string length buffer size -- )  rot umin cmove ;  
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 3 Hexblock 3 
\ usefull definitions and Editor vocabulary           UH 27Nov87
                                                                
: blank ( addr len -- )   bl fill ;                             
                                                                
: ?enough ( n --)  depth 1- > abort" Not enough Parameters" ;   
                                                                
: ?abort( ( f -- )                                              
    IF [compile] .(  true abort" !" THEN  [compile] ( ;         
                                                                
Vocabulary Editor                                               
                                                                
' Forth  | Alias F: immediate                                   
' Editor | Alias E: immediate                                   
                                                                
Editor also definitions                                         
                                                                
\ *** Block No. 4 Hexblock 4 
\ move cursor with position-checking                     23Nov86
                                                                
| : c  ( n --)   \ checks the cursor position                   
      r# @ +  dup 0 b/blk uwithin not                           
       Abort" There is a border!"  r# ! ;                       
                                                                
\\                                                              
                                                                
: c  ( n --)   \ goes thru the screens                          
   r# @ +  dup b/blk 1- >  IF  1 scr +!  THEN                   
   dup 0< IF  -1 scr +!  THEN  b/blk mod  r# ! ;                
                                                                
: c  ( n --)   \ moves cyclic thru the screen                   
   r# @ +  b/blk mod  r# ! ;                                    
                                                                
                                                                
\ *** Block No. 5 Hexblock 5 
\ calculate addresses                                 UH 31Oct86
                                                                
| Code *line ( l -- adr )                                       
    H pop   H dad   H dad   H dad                               
    H dad   H dad   H dad   Hpush jmp   end-code                
                                                                
| Code /line ( n -- c l )                                       
   H pop   L A mov   $3F ani  A E mov  0 D mvi                  
   L A mov   ral   A L mov   H A mov   ral   A H mov            
   L A mov   ral   A L mov   H A mov   ral   A H mov            
   L A mov   ral   3 ani     H L mov   A H mov                  
   dpush jmp   end-code                                         
                                                                
\\                                                              
| : *line      ( l -- adr )  c/l * ;                            
| : /line      ( n -- c l )  c/l /mod ;                         
\ *** Block No. 6 Hexblock 6 
\ calculate addresses                                 UH 01Nov86
                                                                
| : top        ( --     )  r# off ;                             
| : cursor     ( -- n   )  r# @ ;                               
| : 'start     ( -- adr )  scr @ block ;                        
| : 'end       ( -- adr )  'start  b/blk + ;                    
| : 'cursor    ( -- adr )  'start  cursor  + ;                  
| : position   ( -- c l )  cursor  /line ;                      
| : line#      ( -- l   )  position nip ;                       
| : col#       ( -- c   )  position drop ;                      
| : 'line      ( -- adr )  'start  line#  *line + ;             
| : 'line-end  ( -- adr )  'line c/l + 1- ;                     
| : #after     ( -- n   )  c/l col# - ;                         
| : #remaining ( -- n   )  b/blk cursor - ;                     
| : #end       ( -- n   )  b/blk line# *line - ;                
                                                                
\ *** Block No. 7 Hexblock 7 
\ move cursor directed                                UH 01Nov86
                                                                
| : curup      c/l negate c ;                                   
| : curdown    c/l c ;                                          
| : curleft    -1 c ;                                           
| : curright   1 c ;                                            
                                                                
| : +tab  \ 1/4 line forth                                      
      cursor  $10 / 1+ $10 * cursor - c ;                       
                                                                
| : -tab  \ 1/8 line back                                       
      cursor  8 mod  negate  dup 0=  8 * +  c ;                 
                                                                
| : >""end   'start b/blk -trailing nip  b/blk 1- min  r# ! ;   
| : <cr>   #after c ;                                           
                                                                
\ *** Block No. 8 Hexblock 8 
\ show border                                         UH 27Nov87
&15 | Constant dx       1 | Constant dy                         
                                                                
| : horizontal ( row -- row' )                                  
     dup dx 1- at   c/l 2+  0 DO Ascii - emit LOOP 1+ ;         
                                                                
| : vertical ( row -- row' )                                    
     l/s 0 DO dup dx 1-    at Ascii | emit                      
              row dx c/l + at Ascii | emit    1+   LOOP ;       
                                                                
| : border  dy 1- horizontal vertical horizontal drop ;         
                                                                
| : edit-at ( -- )   position swap dy dx d+ at ;                
                                                                
Forth definitions                                               
: updated?  ( -- f)   scr @ block  2- @  0< ;                   
\ *** Block No. 9 Hexblock 9 
\ display screen                         UH 02Nov86   UH 27Nouho
Editor definitions  | Variable isfile'        | Variable imode  
                                                                
| : .updated ( -- )  7 0 at                                     
      updated? IF 4 spaces ELSE ." not " THEN ." updated" ;     
                                                                
| : redisplay   ( line# -- )                                    
     dup dy +  dx at   *line 'start +  c/l type ;               
                                                                
| : .file ( 'file -- ) [ Dos ] .file  &14 col - 0 max spaces ;  
| : .title   1 0 at isfile@ .file    3 0 at isfile' @ .file     
      5 0 at ." Scr# " scr @ 4 .r  .updated  &10 0 at           
      imode @ IF ." insert   " exit THEN ." overwrite" ;        
                                                                
| : .screen  l/s 0 DO I redisplay LOOP ;                        
| : .all   .title .screen ;                                     
\ *** Block No. 10 Hexblock A 
\ check errors                                        UH 02Nov86
                                                                
| : ?bottom  ( -- )  'end  c/l -  c/l -trailing nip             
                      Abort" You would lose a line" ;           
                                                                
| : ?fit ( n -- )  'line c/l -trailing  nip + c/l >             
     IF line# redisplay                                         
        true Abort" You would lose a char" THEN ;               
                                                                
| : ?end    1 ?fit ;                                            
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 11 Hexblock B 
\ programmer's id                                     UH 02Nov86
                                                                
$12 | Constant id-len                                           
Create id   id-len allot   id id-len erase                      
                                                                
| : stamp  ( -- )                                               
     id 1+ count  'start c/l + over - swap  cmove ;             
                                                                
| : ?stamp   ( -- )   updated? IF stamp THEN  ;                 
                                                                
| : get-id   ( -- )                                             
   id c@ ?exit  id on                                           
   cr ." Enter your ID : "  at?  $10 0 DO Ascii . emit LOOP  at 
   id id-len 2 /string expect  rvsoff  span @ id 1+ c! ;        
                                                                
                                                                
\ *** Block No. 12 Hexblock C 
\ update screen-display                               UH 02Dec86
                                                                
| : emptybuf    prev @  2+ dup on  4+ off ;                     
                                                                
| : undo  emptybuf  .all ;                                      
                                                                
| : modified   updated? ?exit  update .updated ;                
                                                                
| : linemodified   modified  line# redisplay ;                  
                                                                
| : screenmodified    modified                                  
     l/s line# ?DO I redisplay LOOP ;                           
                                                                
| : .modified ( -- )  dy l/s + 4+ 0 at  scr @ .                 
      updated? not IF  ." un"  THEN  ." modified"  ?stamp ;     
                                                                
\ *** Block No. 13 Hexblock D 
\ leave editor                           UH 02Dec86   UH 23Feb88
| Variable (pad   (pad off                                      
| : memtop  ( -- adr)   sp@ $100 - ;                            
                                                                
| Create char  1 allot                                          
                                                                
( | Variable imode ) imode off                                  
| : setimode   imode on  .title ;                               
| : clrimode   imode off .title ;                               
| : flipimode ( -- )  imode @ 0= imode !  .title ;              
                                                                
| : done ( -- )                                                 
     ['] (quit is 'quit  ['] (error errorhandler !  quit ;      
                                                                
| : update-exit  ( -- )  .modified  done ;                      
| : flushed-exit ( -- )  .modified  save-buffers  done ;        
\ *** Block No. 14 Hexblock E 
\ handle lines                                        UH 01Nov86
                                                                
| : (clear-line   'line c/l blank ;                             
| : clear-line   (clear-line linemodified ;                     
                                                                
| : clear>   'cursor #after blank  linemodified ;               
                                                                
| : delete-line   'line #end c/l  delete screenmodified ;       
                                                                
| : backline   curup delete-line ;                              
                                                                
| : (insert-line                                                
      ?bottom  'line c/l over #end insert (clear-line ;         
                                                                
| : insert-line   (insert-line  screenmodified ;                
                                                                
\ *** Block No. 15 Hexblock F 
\ handle characters                                   UH 01Nov86
                                                                
| : delete-char   'cursor #after 1 delete  linemodified ;       
                                                                
| : backspace   curleft  delete-char ;                          
                                                                
| : (insert-char   ?end  'cursor 1 over #after insert ;         
                                                                
                                                                
| : insert-char   (insert-char  bl 'cursor c! linemodified ;    
                                                                
| : putchar  ( --)  char c@                                     
    imode @ IF (insert-char THEN                                
    'cursor c!  linemodified  curright ;                        
                                                                
                                                                
\ *** Block No. 16 Hexblock 10 
\ stack lines                                         UH 31Oct86
                                                                
| Create lines 4 allot    \  { 2+pointer | 2base }              
| : 'lines  ( -- adr)   lines 2@ + ;                            
                                                                
| : @line   'lines  memtop u> Abort" line buffer full"          
   'line 'lines c/l cmove  c/l lines +! ;                       
                                                                
| : copyline   @line curdown ;                                  
| : line>buf   @line delete-line ;                              
                                                                
| : !line   c/l negate lines +!  'lines 'line c/l cmove ;       
                                                                
| : buf>line   lines @ 0= Abort" line buffer empty"             
     ?bottom    (insert-line  !line   screenmodified ;          
                                                                
\ *** Block No. 17 Hexblock 11 
\ stack characters                                    UH 01Nov86
                                                                
| Create chars 4 allot    \  { 2+pointer | 2base }              
| : 'chars  ( -- adr)   chars 2@ + ;                            
                                                                
| : @char   'chars 1-  lines 2+ @  u> Abort" char buffer full"  
     'cursor c@ 'chars c!  1 chars +! ;                         
                                                                
| : copychar   @char curright ;                                 
| : char>buf   @char delete-char ;                              
                                                                
| : !char   -1 chars +!  'chars c@  'cursor c! ;                
                                                                
| : buf>char   chars @ 0= Abort" char buffer empty"             
     ?end  (insert-char  !char  linemodified ;                  
                                                                
\ *** Block No. 18 Hexblock 12 
\ switch screens                         UH 03Nov86   UH 27Nov87
                                                                
| Variable r#'             r#'  off                             
| Variable scr'            scr' off                             
( | Variable isfile' )     isfile@  isfile' !                   
                                                                
| : associate \ switch to alternate screen                      
     isfile' @ isfile@   isfile' ! isfile !                     
     scr' @ scr @ scr' ! scr !   r#' @ r# @ r#' ! r# ! ;        
                                                                
| : mark   isfile@ isfile' !  scr @ scr' !  r# @ r#' ! .title ; 
| : n   ?stamp  1 scr +! .all ;                                 
| : b   ?stamp -1 scr +! .all ;                                 
| : a   ?stamp associate .all ;                                 
                                                                
                                                                
\ *** Block No. 19 Hexblock 13 
\ shadow screens                                      UH 03Nov86
                                                                
Variable shadow   shadow off                                    
                                                                
| : (shadow   isfile@ IF capacity 2/ exit THEN  shadow @ ;      
                                                                
| : >shadow  ?stamp   \ switch to shadow screen                 
      (shadow dup  scr @  u> not IF negate THEN scr +! .all ;   
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 20 Hexblock 14 
\ load and show screens                               UH 06Mar88
                                                                
' name >body &10 + | Constant 'name                             
                                                                
| : showoff  ['] exit 'name ! curoff rvsoff  ;                  
                                                                
| : show ( -- )  blk @ 0= IF showoff exit THEN                  
     >in @ 1- r# !  curoff edit-at curon                        
     stop? IF showoff true Abort" Break! " THEN                 
     blk @  scr @ -                                             
     IF  blk @  scr ! rvsoff curoff .all rvson curon THEN ;     
                                                                
| : showload  ( -- )    ?stamp save-buffers                     
     ['] show 'name !  curon rvson                              
     ['] .status >body push  ['] noop is .status                
     scr @  scr push  scr off  r# push  r# @  (load  showoff ;  
\ *** Block No. 21 Hexblock 15 
\ find strings                                        UH 01Nov86
                                                                
| Variable insert-buffer                                        
| Variable find-buffer                                          
| : 'insert ( -- addr )  insert-buffer @ ;                      
| : 'find   ( -- addr )  find-buffer @ ;                        
                                                                
| : .buf ( addr -- )   count type ." |"  &80 col - spaces  ;    
                                                                
| : get ( addr -- )  >r at?  r@ .buf                            
    2dup at  r@ 1+ c/l expect  span @ ?dup IF r@ c! THEN        
    at r> .buf ;                                                
                                                                
| : get-buffers    dy l/s + 2+  dx 1-  2dup  at                 
       ." find:    |"  'find   get     swap 1+ swap 2- at       
     ." ? replace: |"  'insert get ;                            
\ *** Block No. 22 Hexblock 16 
\ search for string                      UH 02Nov86   UH 27Nov87
                                                                
| : skip ( addr -- addr' )  'find c@ + ;                        
                                                                
| : find?  ( -- addr T | F )                                    
     'find count 'cursor #remaining "search ;                   
                                                                
| : "find ( -- r# scr )                                         
    find?  IF skip 'start -  scr @ exit THEN  ?stamp            
    capacity   scr @ 1+                                         
    ?DO 'find count                                             
         I   dup 5 5 at 4 .r   block  b/blk "search             
       IF skip I block -  I endloop exit THEN                   
       stop? Abort" Break! "                                    
    LOOP  true Abort" not found!" ;                             
                                                                
\ *** Block No. 23 Hexblock 17 
\ replace strings                        UH 03Nov86   UH 27Nov87
| : replace? ( -- f )  dy l/s + 3+ dx 3 - at                    
      key dup #cr = IF line# redisplay true Abort" Break!" THEN 
      capital Ascii R = ;                                       
                                                                
| : "mark ( -- )   r# push                                      
     'find count dup negate c  edit-at  rvson type rvsoff ;     
                                                                
| : (replace  'insert c@  'find c@ - ?fit                       
      'find c@ negate c   'cursor #after  'find c@ delete       
      'insert count   'cursor #after  insert                    
      'insert c@ c   modified ;                                 
                                                                
| : "replace   get-buffers                                      
      BEGIN  "find  dup scr @ - swap scr ! IF .all THEN  r# !   
        "mark replace? IF (replace THEN line# redisplay REPEAT ;
\ *** Block No. 24 Hexblock 18 
\ Control-Characters  'normal' CP/M                uho 08May2005
                                                                
Forth definitions                                               
                                                                
: Ctrl ( -- c )                                                 
   name 1+ c@  $1F and   state @ IF [compile] Literal THEN ;    
immediate                                                       
                                                                
$7F Constant #del                                               
                                                                
Editor definitions                                              
                                                                
\ | : flipimode    imode @ 0= imode ! ;                         
                                                                
                                                                
                                                                
\ *** Block No. 25 Hexblock 19 
\ Try a Screen-Editor 'normal' CP/M                   UH 29Nov86
                                                                
Create keytable                                                 
Ctrl E c,       Ctrl S c,       Ctrl X c,       Ctrl D c,       
Ctrl I c,       Ctrl J c,       Ctrl O c,       Ctrl K c,       
                                Ctrl P c,       Ctrl L c,       
Ctrl H c,       Ctrl H c,         #del c,       Ctrl G c,       
Ctrl T c,                       Ctrl Y c,       Ctrl N c,       
Ctrl V c,                                       Ctrl Z c,       
   #cr c,       Ctrl F c,       Ctrl A c,                       
                                Ctrl \ c,       Ctrl U c,       
Ctrl Q c,         #esc c,                       Ctrl W c,       
Ctrl C c,       Ctrl R c,       Ctrl ] c,       Ctrl B c,       
                                                                
                                                                
here keytable -  Constant #keys                                 
\ *** Block No. 26 Hexblock 1A 
\ Try a screen Editor                                 UH 29Nov86
                                                                
Create: actiontable                                             
curup           curleft         curdown         curright        
line>buf        char>buf        buf>line        buf>char        
                                copyline        copychar        
backspace       backspace       backspace       delete-char     
insert-char                     delete-line     insert-line     
flipimode                      ( clear-line )   clear>          
<cr>            +tab            -tab                            
( top             >""end  )     "replace        undo            
update-exit     flushed-exit  ( showload )      >shadow         
n               b               a               mark ;          
                                                                
                                                                
here actiontable -  2/ 1-   #keys -  ?abort( # of actions)      
\ *** Block No. 27 Hexblock 1B 
\ find keys                                           UH 01Nov86
                                                                
| Code findkey ( key -- addr/default )                          
     H pop   L A mov   keytable H lxi   #keys $100 * D lxi      
     [[ M cmp 0=                                                
        ?[ actiontable H lxi  0 D mvi   D dad   D dad           
           M E mov   H inx   M D mov   D push   next ]?         
        H inx   E inr   D dcr   0= ?]                           
     ' putchar H lxi   hpush jmp                                
  end-code                                                      
                                                                
\\                                                              
| : findkey  ( key -- adr/default )                             
  #keys 0 DO  dup  keytable F: I + c@ =                         
     IF drop   E: actiontable  F: I 2* + @ endloop exit THEN    
  LOOP drop ['] putchar ;                                       
\ *** Block No. 28 Hexblock 1C 
\ allocate buffers                                    UH 01Nov86
                                                                
c/l 2* | Constant cstack-size                                   
                                                                
| : nextbuf ( adr -- adr' )   cstack-size + ;                   
                                                                
| : ?clearbuffer   pad (pad @ = ?exit                           
      pad     dup (pad !                                        
      nextbuf dup find-buffer   !   'find off                   
      nextbuf dup insert-buffer !   'insert off                 
      nextbuf dup 0 chars 2!                                    
      nextbuf     0 lines 2! ;                                  
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 29 Hexblock 1D 
\ enter and exit the editor, editor's loop            UH 02Nov86
| Variable jingle  jingle on    | : bell  07 con! jingle off ;  
                                                                
| : clear-error                                                 
     jingle @ ?exit  dy l/s + 1+ dx  at c/l spaces jingle on ;  
                                                                
| : fullquit    BEGIN  ?clearbuffer edit-at  key dup char c!    
      findkey execute  clear-error REPEAT ;                     
                                                                
| : fullerror  ( string --) jingle @ IF bell THEN               
      dy l/s + 1+ dx $16 + at  rvson count type rvsoff          
      &80 col - spaces  scr @ capacity 1- min 0 max scr !       
      .title quit ;                                             
                                                                
| : install   ( -- )                                            
     ['] fullquit Is 'quit  ['] fullerror errorhandler !  ;     
\ *** Block No. 30 Hexblock 1E 
\ enter and exit the Editor                           UH 02Nov86
                                                                
Forth definitions                                               
                                                                
: v   ( -- )   E: 'start drop  get-id  install  ?clearbuffer    
               page curoff  border .all  quit ;                 
                                                                
: l   ( scr -- )   1 ?enough scr !  E: top  F: v ;              
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ *** Block No. 31 Hexblock 1F 
\ savesystem                                       uho 09May2uho
                                                                
: savesystem    \ save image                                    
    E: id off  (pad off   savesystem ;                          
                                                                
| : >find  ?clearbuffer  >in push                               
      bl word count  'find 1+ place                             
      bl   'find 1+   dup >r   count   dup >r   + c!            
      r> 2+ 'find c!   bl r> c! ;                               
| : %view  ( -- )  >find ' >name 4- @  (view                    
   ?dup 0= Abort" hand made"  scr !                             
   E: top curdown find? 0=                                      
   IF ." From Scr # " scr @ u. true Abort" wrong file" THEN     
   skip 'start - 1- r# ! ;                                      
: view ( -- ) %view scr @ list ;                                
: fix ( -- ) %view v ;                                          
