a drawing program for the terminal in gForth.

kvet.4

: legend
." Escape or Q to quit" cr
." Z to paint" cr
." L to load from a file" cr
." S to save to a file" cr
." P to see the text" cr
." R to enter the text" cr
." B to see in braille" cr
." Delete to clear" cr ;

32 constant width width 1+ constant width+1
32 constant height
width+1 height 1+ * constant length
create canvas length chars allot
char . constant dot
variable x variable y
: tile width+1 * + chars canvas + ;
: this x @ y @ tile ;
: dot? c@ bl <> ;
: newlines height 0 do #lf width i tile c! loop ;
: clear canvas length bl fill newlines ;
: home 0 0 at-xy ;
: >xy swap 2* 1+ swap 1+ at-xy ;
: cross ." +" ;
: bar cross width 2* 0 do ." -" loop cross cr ;
: side ." |" ;
: rows height 0 do side width 2* spaces side cr loop ;
: base page bar rows bar legend ;
: pixel dot? if ." []" else ."   " then ;
: >cursor x @ y @ >xy ;
: .cursor >cursor this dot? if ." ##" else ." ::" then home ;
: +mod >r swap over @ + r> mod swap ! ;
: move >cursor this pixel y height +mod x width +mod .cursor ;
: pixels width 0 do dup pixel char+ loop drop ;
: paint this dup dot? if bl else dot then swap c! .cursor ;
: row 1 over 1+ at-xy 0 swap tile pixels ;
: .canvas base height 0 do i row loop .cursor ;

: okay key drop .canvas ;
: bye page bye ;
0 value file
256 constant nlen
create name nlen 1+ chars allot
: rname home ." file name: " name dup nlen accept ;
: open execute throw to file ;
: package >r >r rname r> r> open canvas length file ;
: close file close-file throw .canvas ;
: load r/o ['] open-file package read-file throw drop close ;
: write w/o ['] create-file package write-file throw close ;
: load ['] load catch if home ." failed to load" okay then ;
: write ['] write catch if home ." failed to write" okay then ;
: print page canvas length type okay ;
: read page ." paste all 32 lines" cr
height 0 do 0 i tile width accept drop cr loop .canvas ;
: punch swap 1 lshift swap dot? 1 and or ;
: column 0 swap dup width+1 - swap width+1 2* + do i punch width+1 -loop ;
: sextet dup column swap 1+ column 3 lshift or 10240 + xemit ;
: row width 0 do i over tile sextet 2 +loop drop cr ;
: braille page height 0 do i row 3 +loop okay ;
: | char postpone literal postpone of ' compile, postpone endof ; immediate
: regular toupper case
#esc of bye endof
| Q bye | Z paint | L load | W write
| P print | R read | B braille endcase ;
: special case
k-up of 0 -1 move endof
k-down of 0 1 move endof
k-left of -1 0 move endof
k-right of 1 0 move endof
k-delete of clear .canvas endof
endcase ;
: special ekey>fkey if special else drop then ;
: key ekey ekey>xchar if regular else special then ;
: repl .canvas begin key again ;
width 2/ x ! height 2/ y !
clear repl