\ Block editor


vocabulary editor also editor definitions
                                                                
variable row        variable column                             
variable findbuf    variable findbuf#                           
variable insertbuf  variable insertbuf#                         
variable relist                                                 
                                                                
: lines  ( n1 -- n2 ) 64 * ;                                    
: >line  ( -- ) scr @ block row @ lines + ;                     
: eotib?  ( -- f ) >limit @ >in @ < ;                           
                                                                
: .line  ( -- ) relist @ 0= eotib? 0= or if exit then           
  cr row @ .row >line 64 type cr column @ 3 + spaces [char] ^   
  emit cr ;                                                     
                                                                
: #tib  ( -- n ) >limit @ >in @ - ;                             
: emptytib  ( -- ) >limit @ 1+ >in ! ;                          
: >loc  ( -- a ) >line column @ + ;                             
                                                                
: insertbuf!  ( | ... -- ) eotib? if exit then                  
  source >in @ + insertbuf @ #tib dup insertbuf# ! cmove        
  emptytib ;                                                    
                                                                
: findbuf!  ( | ... -- ) eotib? if exit then                    
  source >in @ + findbuf @ #tib dup findbuf# ! cmove            
  emptytib ;                                                    
                                                                
: l  ( -- ) page scr @ list .line ;                             
: n  ( -- ) 1 scr +! row off column off l ;                     
: b  ( -- ) -1 scr +! row off column off l ;                    
: t  ( n -- ) row ! column off .line ;                          
                                                                
: p  ( | ... -- ) >line 64 blank insertbuf! insertbuf @ >line   
  insertbuf# @ cmove column off .line update ;                  
                                                                
: insert  ( | ... -- ) insertbuf! >loc dup                           
  insertbuf# @ + 64 column @ - insertbuf# @ - 0 max cmove>      
  insertbuf @ >line column @ + insertbuf# @ cmove update        
  .line ;                                                       
                                                                
: e  ( -- ) >loc dup findbuf# @ dup >r - 64 column @            
  - cmove >line 64 + r@ - r@ blank r> negate column +! .line    
  update ;                                                      
                                                                
: f  ( | ... -- ) findbuf! >line 64 findbuf @ findbuf# @        
  search if drop >line - findbuf# @ + column ! .line else 2drop 
  then ;                                                        
                                                                
: copydown  ( n -- ) row @ 15 = if drop exit then >r >line      
  dup r> lines + 15 row @ - lines cmove> ;                      
                                                                
: u  ( | ... -- ) row @ 15 = abort" end of block"               
  1 copydown 1 row +! p  ;                                      
                                                                
: x  ( -- ) >line insertbuf @ 64 cmove 64 insertbuf# ! row      
  @ 15 = if >line 64 blank else >line 64 + >line 16 row @ - 1-  
  lines cmove scr @ block 15 lines + 64 blank then .line        
  update ;                                                      
                                                                
: d  ( | ... -- ) relist off f relist on e ;                    
: r  ( | ... -- ) relist off e relist on insert ;                    
                                                                
: copy  ( n1 n2 -- ) block update swap block swap 1024 cmove ;  
: addr>pos  ( a -- ) scr @ block - 64 /mod row ! column ! ;     
                                                                
: s-scr  ( -- f) >loc 1024 row @ lines - column @ - findbuf     
  @ findbuf# @ search if drop findbuf# @ + addr>pos true else   
  2drop false then ;                                            
                                                                
: s  ( n | ... -- n ) findbuf! s-scr if l exit then             
  max-blocks @ min 1+ scr                                       
  @ 1+ do i block 1024 findbuf @ findbuf# @ search if drop i    
  scr ! addr>pos l unloop exit else 2drop then loop ;           
                                                                
: g  ( n1 n2 -- ) 1 copydown lines swap block + insertbuf !     
  64 insertbuf# ! p ;                                           
                                                                
: bring  ( n1 n2 n3 -- ) relist off over - 1+ 0 do 2dup i +     
  g 1 row +! loop 2drop relist on .line ;                       
                                                                
: k  ( -- ) findbuf @ >r insertbuf @ findbuf ! r> insertbuf !   
  findbuf# @ >r insertbuf# @ findbuf# ! r> insertbuf# ! ;       
                                                                
: till  ( | ... -- ) findbuf! >line 64 findbuf @ findbuf# @     
  search if >r >loc r@ cmove >line 64 + r@ - r> blank update    
  .line else 2drop then ;                                       
                                                                
: cut  ( -- ) >loc 64 column @ - blank update .line ;           
                                                                
: show  ( n1 n2 -- ) 1+ swap do i list loop ;                   
                                                                
: index  ( n1 n2 -- ) 1+ swap do [char] # emit i . i block      
  64 type cr loop ;                                             
                                                                
: wipe  ( -- ) scr @ block 1024 blank update ;                  

: i  ( | ... -- ) insert ;


\ initialization                                 
                                                                
buffers-base @                                                  
dup 1024 - findbuf !  2048 - insertbuf !                        
relist on                                                       
:noname ['] n is next-screen ['] b is previous-screen ; execute

only definitions