\ ************* A-Nib *************
\      The Agon Game Toolkit
\           Version  1.0
\       James Hofmann, 2026
\   License found in license.txt

\ Nib Tools - Commonly reused words

\ ************* Debug *************
\ Debug definitions that will stop you from blowing up the system

0 value dbg/write$
0 value dbg/read$
: dbg/! ( x a-addr -- )
\G write as in ! and record the address to dbg/write$; if the address is below 8192 stop the program with an error.
to dbg/write$ 8192 dbg/write$ < if dbg/write$ ! else ." Write too low" cr quit then ;
: dbg/@ ( a-addr -- )
\G read as in @ and record the address to dbg/read$; if the address is below 8192 stop the program with an error.
to dbg/read$ 8192 dbg/read$ < if dbg/read$ @ else ." Read too low" cr quit then ;

-1024 value dbg/expect$
: dbg/enter ( -- )
\G Set a watermark for stack depth based on our entry point
    dbg/expect$ -1024 <> if cr ." dbg/expect$ was already set" cr quit then
    depth to dbg/expect$
;

: dbg/leave ( n -- )
\G Check to see if we leave with a stack depth of dbg/expect$ + n.
    dbg/expect$ -1024 = if cr ." dbg/expect$ was unset" cr quit then
    ?stack dbg/expect$ + to dbg/expect$
    depth dbg/expect$ <> if
        cr ." depth:" depth .
        cr ." expected:" dbg/expect$ .
        -1024 to dbg/expect$
        cr ." depth mismatch" cr quit then
    -1024 to dbg/expect$
;

\ ************* Fast TYPE *************

CODE FASTTYPE ( c-addr1 u --- )
\G Use MOS v1.03 RST 18h to rapidly print the string at c-addr1 and length u.
    LD C, E
    LD B, D
    POP DE
    EX DE, HL
    \ testing without this \ LD A, 0 \ required to trigger length mode
    RST .LIS $18
    POP DE
    NEXT
END-CODE

\ ************* Sysvars *************

: sys/shift?
  6 sysvars@ 2 and 2 =
;

\ ************* VDP *************
\ The VDP code is built around the idiosyncracies of each group of VDP commands.
\ All commands will output to either vdp/emit-xt$ or vdp/type-xt$, enabling the usage of long command sequences with stored buffers.
\ Simple command words will take one or no parameters and pass to emit directly.
\ Commands with a lot of irregularity like the buffer commands instead use one word to set bufferid,
\ another word to take parameters and emit the command, and zero or more words for additional parameters.

' fasttype value vdp/type-xt$ \ indirection for (address, length) emission
' emit value vdp/emit-xt$ \ indirection for single byte emission

: vdp/t. vdp/type-xt$ execute ;
: vdp/e. vdp/emit-xt$ execute ;

: vdp/null. 0 vdp/e. ;
: vdp/printer. 1 vdp/e. ;
: vdp/printer-enable. 2 vdp/e. ;
: vdp/printer-disable. 3 vdp/e. ;
: vdp/text-at-text. 4 vdp/e. ;
: vdp/text-at-graphics. 5 vdp/e. ;
: vdp/enable-screen. 6 vdp/e. ;
: vdp/bel. 7 vdp/e. ; \ an excellent way to test code when graphics aren't available
: vdp/cursor-back. 8 vdp/e. ;
: vdp/cursor-fore. 9 vdp/e. ;
: vdp/cursor-down. 10 vdp/e. ;
: vdp/cursor-up. 11 vdp/e. ;
: vdp/cls. 12 vdp/e. ;
: vdp/cr. 13 vdp/e. ;
: vdp/clg. 16 vdp/e. ;
: vdp/fg. ( c -- ) 17 vdp/e. vdp/e. ;
: vdp/bg. ( c -- ) 17 vdp/e. 128 + vdp/e. ;
: vdp/gcol. ( col mode -- ) 18 vdp/e. vdp/e. vdp/e. ;
: vdp/paged-on. 14 vdp/e. ;
: vdp/paged-off. 15 vdp/e. ;
: vdp/reset-modes. 20 vdp/e. ;
: vdp/screen-mode. ( mode -- ) 22 vdp/e. vdp/e. ;
: vdp/disable-screen. 21 vdp/e. ;
: vdp/cursor-ctrl. ( n -- ) 23 vdp/e. 1 vdp/e. vdp/e. ;
: vdp/cursor-movement.  ( mask setting -- ) 23 vdp/e. 16 vdp/e. vdp/e. vdp/e. ;
: vdp/reset-viewports. 26 vdp/e. ;
: vdp/home. 30 vdp/e. ;
: vdp/textcursor-abs. ( y x -- ) 31 vdp/e. vdp/e. vdp/e. ;
: vdp/bs. 127 vdp/e. ;

create vdp:sys 23 c, 0 c, 0 c, 16 allot
: vdp/sys-u. ( u cmd -- ) [ vdp:sys 2 + literal ] c! vdp:sys swap vdp/t. ;
: vdp/sys/bufprint. ( bufid -- )
  [ vdp:sys 3 + literal ] h! 5 155 vdp/sys-u.
;
: vdp/sys/vsync. 3 $c3 vdp/sys-u. ;
: vdp/sys/flush. 3 $ca vdp/sys-u. ;
: vdp/sys/bmp>char. ( char bitmapid -- ) [ vdp:sys 4 + literal ] h! [ vdp:sys 3 + literal ] c! 6 $92 vdp/sys-u. ;
: vdp/sys/pixrel-cursor. ( x y -- ) [ vdp:sys 5 + literal ] h! [ vdp:sys 3 + literal ] h! 7 $8c vdp/sys-u. ;
: vdp/sys/logical-scale. ( t -- ) [ vdp:sys 3 + literal ] c! 4 $c0 vdp/sys-u. ;
: vdp/sys/legacy. ( t -- ) [ vdp:sys 3 + literal ] c! 4 $c1 vdp/sys-u. ;
: vdp/sys/control-keys. ( t -- ) [ vdp:sys 3 + literal ] c! 4 $98 vdp/sys-u. ;

create vdp:buf 23 c, 0 c, $a0 c, 16 allot
\ internal API:
: vdp/_buf/adjust! ( v -- ) ;
: vdp/_buf-6. ( cmd -- ) [ vdp:buf 5 + literal ] c! vdp:buf 6 vdp/t. ;
: vdp/_buf-8. ( cmd -- ) [ vdp:buf 5 + literal ] c! vdp:buf 8 vdp/t. ;
: vdp/_buf-u. ( u cmd -- ) [ vdp:buf 5 + literal ] c! vdp:buf swap vdp/t. ;

: vdp/buf/bufid! vdp:buf 3 + h! ;
: vdp/buf/bufid@ vdp:buf 3 + h@ ;
: vdp/buf/write. ( addr len -- )
  tuck [ vdp:buf 6 + literal ] h! swap 0 vdp/_buf-8.
  vdp/t. ;
: vdp/buf/clear. 2 vdp/_buf-6. ;
: vdp/buf/call. 1 vdp/_buf-6. ;
: vdp/buf/consolidate. 14 vdp/_buf-6. ;
: vdp/buf/empty. ( len -- ) [ vdp:buf 6 + literal ] h! 3 vdp/_buf-8. ;
: vdp/buf/fill/offset! [ vdp:buf 7 + literal ] h! ;
: vdp/buf/fill/length! [ vdp:buf 9 + literal ] h! ;
: vdp/buf/fill/v! [ vdp:buf 11 + literal ] c! ;
: vdp/buf/fill. 66 [ vdp:buf 6 + literal ] c! 12 5 vdp/_buf-u. ;
: vdp/buf/clear-fill. ( v len -- )
  vdp/buf/clear. dup vdp/buf/empty. 0 vdp/buf/fill/offset! vdp/buf/fill/length! vdp/buf/fill/v! vdp/buf/fill. ;
\ TODO other adjustments
: vdp/buf/debug. 128 vdp/_buf-6. ;

: rawtype ( addr len --- )
\G Use VDP buffer 1 as a temporary buffer to print out the data as raw text.
  1 vdp/buf/bufid! vdp/buf/clear. vdp/buf/write. 1 vdp/sys/bufprint.
;

: vdp/ctx/reset. ( flags -- )
  23 vdp/e. 0 vdp/e. $c8 vdp/e. 2 vdp/e. vdp/e.
;

create vdp:bmp 23 c, 27 c, 0 c, 16 allot
: vdp/bmp-u. ( u cmd -- ) [ vdp:bmp 2 + literal ] c! vdp:bmp swap vdp/t. ;
: vdp/bmp/select. ( bufid -- ) [ vdp:bmp 3 + literal ] h! 5 $20 vdp/bmp-u. ;
: vdp/bmp/create. ( w h format -- )
  [ vdp:bmp 7 + literal ] c!
  [ vdp:bmp 5 + literal ] h!
  [ vdp:bmp 3 + literal ] h!
  8 $21 vdp/bmp-u. ;
: vdp/spr/select. ( idx -- ) [ vdp:bmp 3 + literal ] c! 4 4 vdp/bmp-u. ;
: vdp/spr/clear. ( -- ) 3 5 vdp/bmp-u. ;
: vdp/spr/activate. ( n -- ) [ vdp:bmp 3 + literal ] c! 4 7 vdp/bmp-u. ;
: vdp/spr/next. ( -- ) 3 8 vdp/bmp-u. ;
: vdp/spr/prev. ( -- ) 3 9 vdp/bmp-u. ;
: vdp/spr/frame. ( -- ) [ vdp:bmp 3 + literal ] c! 4 10 vdp/bmp-u. ;
: vdp/spr/show. ( -- ) 3 11 vdp/bmp-u. ;
: vdp/spr/hide. ( -- ) 3 12 vdp/bmp-u. ;
: vdp/spr/move-abs. ( x y -- ) [ vdp:bmp 5 + literal ] h! [ vdp:bmp 3 + literal ] h! 7 13 vdp/bmp-u. ;
: vdp/spr/move-rel. ( x y -- ) [ vdp:bmp 5 + literal ] h! [ vdp:bmp 3 + literal ] h! 7 14 vdp/bmp-u. ;
: vdp/spr/update. ( -- ) 3 15 vdp/bmp-u. ;
: vdp/bmp/reset. ( -- ) 3 16 vdp/bmp-u. ;
: vdp/spr/reset. ( -- ) 3 17 vdp/bmp-u. ;
: vdp/spr/hw. ( -- ) 3 19 vdp/bmp-u. ;
: vdp/spr/sw. ( -- ) 3 20 vdp/bmp-u. ;
: vdp/spr/add-frame. ( bmpid -- ) [ vdp:bmp 3 + literal ] h! 5 $26 vdp/bmp-u. ;
: vdp/spr/rpl-frame. ( bmpid -- ) [ vdp:bmp 3 + literal ] h! 5 $35 vdp/bmp-u. ;

create vdp:plot 25 c, 0 c, 0 c, 0 c, 0 c, 0 c,
: vdp/plot/bitmap-abs 237 [ vdp:plot 1+ literal ] c! ;
\ TODO other plot codes
: vdp/plot. ( x y -- ) [ vdp:plot 4 + literal ] h! [ vdp:plot 2+ literal ] h! vdp:plot 6 vdp/t. ;

create vdp:font 23 c, 0 c, $95 c, 16 allot
8 value vdp/font/char-w$
8 value vdp/font/char-h$
0 value vdp/font/char-id$
: vdp/font-u. ( u cmd -- ) [ vdp:font 3 + literal ] c! vdp:font swap vdp/t. ;
: vdp/font/bufid! ( bufid -- ) [ vdp:font 4 + literal ] c! ;
: vdp/font/select. ( flags -- ) [ vdp:font 6 + literal ] c! 7 0 vdp/font-u. ;
: vdp/font/sysfont. 6 5 vdp/font-u. ;

: vdp/sys/set-var. ( varid val -- )
    23 vdp/e. 0 vdp/e. $f8 vdp/e. swap split vdp/e. vdp/e. split vdp/e. vdp/e.
;

: vdp/argb2222-upload. ( addr w h bufid -- )
  vdp/buf/bufid! vdp/buf/clear. 2dup >r >r * vdp/buf/write. vdp/buf/bufid@ vdp/bmp/select. r> r> 1 vdp/bmp/create.
;

: vdp/bmp/create-solid-2222. ( v w h -- )
\G creates a new RGBA2222 bitmap at vdp/buf/bufid$ with width and height w h, color v.
  2dup >r >r * vdp/buf/clear-fill. r> r>
  vdp/buf/bufid@ vdp/bmp/select.
  ( w h ) 1 vdp/bmp/create.
;

\  create fakebitmap
\  255 c, 255 c, 218 c,
\  255 c, 0   c, 218 c,
\  255 c, 255 c, 218 c,
\
\  10 constant fakebitmap/bmp-id
\
\  : fbtest
\    fakebitmap 3 3 fakebitmap/bmp-id vdp/argb2222-upload.
\    vdp/sys/flush.
\    vdp/plot/bitmap-abs 80 50 vdp/plot.
\    vdp/sys/vsync.
\  ;

\ **************** Software stack ****************
\ This is a generic ascending low to high stack that relies on a single pointer.
\ The header of the stack contains the pointer to the top;
\ the pointer is manipulated or compared to get every other behavior.

: st/create ( size name -- ) create here cell+ , ( size ) allot ;
: st/push ( st v -- ) over @ ! dup @ cell+ swap ! ;
: st/pop ( st -- ) dup @ cell-
    2dup = abort" Softstack underflow"
    dup rot ! @ ;
: st/tos ( st -- ) @ cell- @ ;
: st/reset ( st -- ) dup cell+ swap ! ;
: st/len ( st -- ) dup @ swap - 3 / 1- ;
: st. ( st -- ) dup st/len 0
    2dup = if ." Empty " else
    do cell+ dup @ . loop then drop ;

\ ************* >NAME-timeout *************

: >NAME-timeout ( addr1 -- addr2 )
\G modification of >NAME to walk at most 128 bytes from the starting position before giving up
  128 0 do
    1- DUP C@ 128 AND
    if leave then
    i 127 = if drop ['] blank leave then
  loop
;

\ ************* Double math extensions *************

: D<= 1 s>d d+ D< ;

: string>d ( caddr u -- d )
\G Returns the first six characters of the indicated string as a double.
  drop dup @ swap cell+ @ swap
;

\ ************* Dump cell as characters *************

: cell>chars
  dup 16 rshift swap
  dup 8 rshift 255 and swap
  255 and
;
: cell>chars. cell>chars emit emit emit ;

\ ************* Dump character as binary flags *************

create bindumpdata 8 allot
46 value bindump-off
42 value bindump-on
: bindump1 ( caddr1 -- )
\G Write a single character, either the value of bindump-off or bindump-on, to caddr1.
  bindumpdata + swap tuck 1 and 0= if bindump-off else bindump-on then swap c!
;
: bindump ( v -- )
\G Consume the byte v and write its binary contents as text.
  0 bindump1 1 rshift
  1 bindump1 1 rshift
  2 bindump1 1 rshift
  3 bindump1 1 rshift
  4 bindump1 1 rshift
  5 bindump1 1 rshift
  6 bindump1 1 rshift
  7 bindump1 drop
  bindumpdata 8 fasttype
;

\ ************* Colorized memory dumps *************

10 value debug-col0-v
2 value debug-col1-v
15 value debug-col2-v

: debug-col0 17 emit debug-col0-v emit ;
: debug-col1 17 emit debug-col1-v emit ;
: debug-col2 17 emit debug-col2-v emit ;

: COL-DL ( addr1 --- addr2 )
\G hex/ascii dump in one line of 16 bytes at addr1 addr2 is addr1+16
  debug-col2
  BASE @ >R 16 BASE ! CR
  DUP 0 <# # # # # # # #> TYPE ."  "
  debug-col1
  8 0 DO
   DUP I 2*     + C@ 0 <# # # #> TYPE debug-col0
   DUP I 2* 1+  + C@ 0 <# # # #> TYPE debug-col1 ."  "
  LOOP
  debug-col2
  16 0 DO
   DUP I + C@ DUP 32 < OVER 127 = OR IF DROP ." ." ELSE EMIT THEN
  LOOP
  16 + R> BASE ! ;

: COL-DUMP ( addr len --- )
\G Show a hex/ascii dump of the memory block of len bytes at addr
  7 + 4 RSHIFT 0 DO
   col-dl ?TERMINAL IF LEAVE THEN
  LOOP DROP ;

\ ************* File System *************
\ The words built into Agon Forth don't track many features about the file.
\ This is an extension that, when a handle is assigned to fs$,
\ enables usage of additional MOS and FatFS features.

CODE OSCALL3 ( HL DE BC func --- res)
\G Call the MOS API via RST 8 with the desired parameters in HL, DE and BC.
\G Return the return code as in the HL register.
    LD A, E
    EXX
    POP BC
    POP DE
    POP HL
    PUSH IX
    PUSH IY
    RST .LIL $8
    EX DE, HL
    POP IY
    POP IX
    NEXT
END-CODE

variable _file-p-caddr 0 , \ temp var for storing 32-bit value
: REPOSITION-FILE-P ( caddr1-d fid -- ior )
\G MOS 0x24: mos_flseek_p. Reposition fid to the double address stored in caddr1.
  >r _file-p-caddr 2!
  0 ( < will be replaced with contents of A register )
  r> ( fid ) _file-p-caddr 36 oscall
;

0 value fs$
\G fs: Selected file handle. fs machine persists a file handle.
0 value fs/status$
\G fs: status code returned from MOS/FatFS.
0 value fs/bytes-status$
\G fs: number of bytes read from last status.
create fs/_tmp 16 allot
create fs/curfilename$ 80 allot
0 value fs/curfilemode$
: fs/get-fil ( -- fil )
\G fs: Return the FIL pointer of fs$.
  0 0 fs$ 25 oscall3
;
: fs/fsize-d ( -- fsize-d )
\G fs: Return the file size of fs$.
  fs/_tmp 6 erase
  fs/get-fil fs/_tmp 0 $8F oscall to fs/status$ fs/_tmp 2@ swap
;
: fs/truncate ( -- )
\G fs: Truncate the file size of fs$ to the position at fs/tell.
  fs/get-fil 0 0 $85 oscall to fs/status$
;
: fs/fsync ( -- )
\G fs: Call fsync on fs$ to flush any file caches and ensure data writes. (Caching not used as of MOS 3.0)
  fs/get-fil 0 0 $86 oscall to fs/status$
;
: fs/tell ( -- pos-d )
\G fs: Return the current position of fs$.
  fs/_tmp 6 erase
  fs/get-fil fs/_tmp 0 $8D oscall to fs/status$ fs/_tmp 2@ swap
;
: fs/seek ( pos-d -- )
\G fs: Reposition handle in fs$ to the double address stored in caddr1.
  fs/_tmp 6 erase
  swap fs/_tmp 2!
  fs/_tmp 0 fs$ $24 oscall to fs/status$
;
: fs/+ ( v -- )
\G fs: Advance the position of fs$ by v (single).
    s>d fs/tell D+ fs/seek
;
: fs/d+ ( v-d -- )
\G fs: Advance the position of fs$ by v (double).
    fs/tell D+ fs/seek
;

: fs/@ ( -- v )
\G fs: Read one LE cell (3 bytes) from fs$.
  fs/_tmp 3 fs$ read-file to fs/status$ to fs/bytes-status$ fs/_tmp @
;
: fs/2@-l ( -- v-d )
\G fs: Read a double LE cell (3 bytes low-LE, 3 bytes hi-LE, linear order) from fs$.
  fs/_tmp 6 fs$ read-file to fs/status$ to fs/bytes-status$ fs/_tmp 2@ swap
;
: fs/2@-f ( -- v-d )
\G fs: Read a double LE cell (3 bytes hi-LE, 3 bytes low-LE, Forth order) from fs$.
  fs/_tmp 6 fs$ read-file to fs/status$ to fs/bytes-status$ fs/_tmp 2@
;
: fs/h@ ( -- v )
\G fs: Read 2 LE bytes from fs$.
  fs/_tmp 2 fs$ read-file to fs/status$ to fs/bytes-status$ fs/_tmp h@
;
: fs/c@ ( -- v )
\G fs: Read byte from fs$.
  fs$ fgetc
;
: fs/bytes@ ( caddr1 u -- )
\G fs: Read from fs$ into byte array.
  fs$ read-file to fs/status$ to fs/bytes-status$
;
: fs/! ( v -- )
\G fs: Write one LE cell (3 bytes) to fs$.
  fs/_tmp ! fs/_tmp 3 fs$ write-file to fs/status$ to fs/bytes-status$
;
: fs/2!-l ( v-d -- )
\G fs: Write a double LE cell (3 bytes low-LE, 3 bytes hi-LE, linear order) to fs$.
  swap fs/_tmp 2! fs/_tmp 6 fs$ write-file to fs/status$ to fs/bytes-status$
;
: fs/2!-f ( v-d -- )
\G fs: Write a double LE cell (3 bytes hi-LE, 3 bytes low-LE, Forth order) to fs$.
  fs/_tmp 2! fs/_tmp 6 fs$ write-file to fs/status$ to fs/bytes-status$
;
: fs/h! ( v -- )
\G fs: Write 2 LE bytes to fs$.
  fs/_tmp h! fs/_tmp 2 fs$ write-file to fs/status$ to fs/bytes-status$
;
: fs/c! ( v -- )
\G fs: Write byte to fs$.
  fs$ fputc
;
: fs/bytes! ( caddr1 u -- )
\G fs: Write byte array to fs$.
  fs$ write-file to fs/status$ to fs/bytes-status$
;

$1 constant fs/mode/read
$2 constant fs/mode/write

$0 constant fs/mode/open-existing
$4 constant fs/mode/create-new
$8 constant fs/mode/create-always
$10 constant fs/mode/open-always
$30 constant fs/mode/open-append

: fs/open ( c-addr u mode -- )
\G fs: Open the file with the name starting at c-addr and with length u.
\G Mode flags are fs/mode/read, fs/mode/write, fs/mode/open-existing,
\G fs/mode/create-new, fs/mode/create-always, fs/mode/open-always,
\G fs/mode/open-append. Combine as indicated in MOS 0x0A.
\G Result is stored to fs$.
    to fs/curfilemode$ fs/curfilename$ >ASCIIZ
    fs/curfilename$ 0 fs/curfilemode$ $A OSCALL DUP 0= to fs/status$ to fs$ ;
;
: fs/close
\G fs: Close fs$.
  fs$ close-file to fs/status$ ;
: fs/reopen
\G fs: Close fs$ and open file in fs/curfilename$ fs/curfilemode.
  fs/close
  fs/curfilename$ 0 fs/curfilemode$ $A OSCALL DUP 0= to fs/status$ to fs$
;

: fs/dump ( u -- )
\G fs: Dump u rows of 16 bytes from the file starting from fs/tell
  ." fs: " fs$ . space fs/tell d. backspace ." /" fs/fsize-d d. cr
  ( u ) 0 do
    fs/_tmp 16 fs/bytes@
    fs/_tmp 16 col-dump
  loop
;

\ : rw-test-file
\   s" rwtest.binary"
\ ;

\ : rwtest
\   rw-test-file fs/mode/read fs/mode/write or fs/mode/create-always or fs/open
\   $123456 $789012 fs/2!
\   $123456 fs/!
\   $1234 fs/h!
\   $12 fs/c!
\   fs/fsync
\   fs/close
\   rw-test-file fs/mode/read fs/mode/write or fs/mode/open-existing or fs/open
\   fs/2@ $123456 $789012 d= .
\   fs/@ $123456 = .
\   fs/h@ $1234 = .
\   fs/c@ $12 = .
\   fs/close
\ ;

\ ************* Memory arenas *************
\
\ Arenas limit the scope of memory error by checking for writes outside their bounds.
\ Arenas contain a max capacity and write pointer.
\ Arenas are modelled as buffers that can be instanced and selected with:
\ 100 arena/create myarena \ size 100 bytes
\ myarena to arena$ \ select
\ Each arena contains an overflow token (run on writes that will overflow)
\ and a send token (call to complete an outbound message using the buffer)

0 value arena$ \ selected

: arena/len@
\G Arena: write pointer/number of bytes written.
  arena$ @
;
: arena/max
\G Arena: max capacity.
  arena$ cell+ @
;
: arena/overflow-xt!
\G Write to the selected arena's overflow execution token.
  arena$ cell+ cell+ !
;
: arena/overflow-xt@
\G Read the selected arena's overflow execution token.
  arena$ cell+ cell+ @
;
: arena/send-xt!
\G Write to the selected arena's send execution token.
  arena$ [ 3 cells literal ] + !
;
: arena/send-xt@
\G Read the selected arena's send execution token.
  arena$ [ 3 cells literal ] + @
;
: arena/bounds? ( offset -- t )
\G Arena: Test for whether the indicated offset will overflow or underflow.
  dup arena/max <= swap 0< 0= + -2 =
;
: arena/len! ( n -- )
\G Arena: Modify the write cursor's position. Run overflow if outside bounds.
  dup arena/bounds? if
    arena$ !
  else drop arena/overflow-xt@ execute then
;
: arena/buf
\G Return the address of the arena's memory buffer.
  arena$ [ 4 cells literal ] +
;
: arena/here
\G Return the address pointed to by the arena's write pointer.
  arena/buf arena/len@ +
;
: arena/header-dump
\G Return a formatted view of the arena's properties.
  arena$ 5 - \ gross hack to walk back from arena$ parameter field to the name field. may break if code size changes
  >name-timeout id. arena/len@ . backspace ." /" arena/max .
  ." ovf=" arena/overflow-xt@ >name-timeout id. ." snd=" arena/send-xt@ >name-timeout id.
;
: arena/dump-len ( u -- )
\G Memory dump the arena's header and data with the specified length plus 8 cells of padding.
  arena/header-dump
  dup arena/max > if drop arena/max then
  arena$ 4 cells + swap 8 cells + col-dump
;
: arena/dump
\G Memory dump the arena's header and all data.
  arena/len@ arena/dump-len
;
: arena/type
\G Type the arena's data to VDP.
  arena/len@ 0> if
    arena/buf arena/len@ fasttype
  then
;
: arena/reset
\G Reset the arena's write pointer.
  0 arena/len!
;
: arena/zero-reset
\G Reset the arena's write pointer and zero the buffer.
  arena/reset
  0 arena/buf arena/max rot fill
;
: ar24!
\G Arena: Write cell as 24-bit value. Test overflow.
  arena/len@ cell+ arena/bounds? if
    arena/here ! arena/len@ cell+ arena$ !
  else arena/overflow-xt@ execute then
;
: ar16!
\G Arena: Write cell as 16-bit value. Test overflow.
  arena/len@ 1+ 1+ arena/bounds? if
    arena/here h! arena/len@ 1+ 1+ arena$ !
  else arena/overflow-xt@ execute then
;
: ar8!
\G Arena: Write cell as 8-bit value. Test overflow.
  arena/len@ 1+ arena/bounds? if
    arena/here c! arena/len@ 1+ arena$ !
  else arena/overflow-xt@ execute then
;
: arena/cmove ( c-addr1 u -- )
\G Arena: Append the memory at c-addr1, length u to the end of the buffer. Test overflow.
  dup -rot dup arena/len@ + arena/bounds? if
    arena/here swap cmove
    arena/len@ + arena/len!
  else arena/overflow-xt@ execute then
;
: arena/d-o
\G Arena: Default overflow word. Aborts.
  arena/dump
  abort" Arena overflowed!"
;
: arena/d-s
\G Arena: Default send word. Resets.
  arena/type arena/reset
;
: arena/create ( max-size "name" -- )
\G Arena: Make a new arena of max-size and name.
  create 0 , dup , ['] arena/d-o , ['] arena/d-s , allot
  does>
  to arena$
;

\ 100 arena/create myarena
\ myarena 48 arena-8! \ "0"
\ arena/dump
\ : hello s" hello" ;
\ hello arena/cmove
\ arena/dump
\ arena/type \ "0hello"

\ ************* Serialization *************

\ The goal of this section is to describe memory in terms of types,
\ and to synchronize it with serialized data in some capacity.
\ that is, we have a machine that points to an address...
\ it has a type defined...
\ it also points to a file position, and a handle...

\ TODO: Consider removing serialization - might not be worth it compared with 3ed rows

\  0 value ser$
\  : ser/create
\      create
\      100 allot \ FIXME
\      does>
\      to ser$
\  ;
\
\  : ser/offset$ ser$ ;
\  : ser/size$ ser$ cell+ cell+  ;
\  : ser/type$ ser$ 4 cells +  ;
\  : ser/sync-r$ ser$ 5 cells + ;
\  : ser/sync-w$ ser$ 6 cells + ;
\
\  8 constant ser/c
\  16 constant ser/h
\  24 constant ser/1
\  32 constant ser/f
\  48 constant ser/2-l
\  48 constant ser/2-f
\  72 constant ser/vlq
\  71 constant ser/flq
\
\  : ser/c/r fs/c@ ser/offset$ c! ;
\  : ser/c/w ser/offset$ fs/c! ;
\  : ser/c/s 1 ;
\  : ser/h/r fs/h@ ser/offset$ h! ;
\  : ser/h/w ser/offset$ fs/h! ;
\  : ser/h/s 2 ;
\  : ser/1/r fs/@ ser/offset$ ! ;
\  : ser/1/w ser/offset$ fs/! ;
\  : ser/1/s 3 ;
\  : ser/2-l/r fs/2@-l ser/offset$ 2! ;
\  : ser/2-l/w ser/offset$ fs/2!-l ;
\  : ser/2-l/s 6 ;
\  : ser/2-f/r fs/2@-f ser/offset$ 2! ;
\  : ser/2-f/w ser/offset$ fs/2!-f ;
\  : ser/2-f/s 6 ;
\
\  : ser/type! ( v -- t )
\      dup
\      case
\      ser/c of ser/type$ ! ['] ser/c/r ser/sync-r$ ! ['] ser/c/w ser/sync-w$ ! ser/c/s ser/size$ ! true exit endof
\      ser/h of ser/type$ ! ['] ser/h/r ser/sync-r$ ! ['] ser/h/w ser/sync-w$ ! ser/h/s ser/size$ ! true exit endof
\      ser/1 of ser/type$ ! ['] ser/1/r ser/sync-r$ ! ['] ser/1/w ser/sync-w$ ! ser/1/s ser/size$ ! true exit endof
\      endcase drop false
\  ;
\
\  \ TODO rename to variable-buffer fixed-buffer
\  \ fill in the details of declaration/write.
\
\  : ser/vb#! ( l -- t )
\  \G Ser: Declare a variable-length quantity (single) length at this offset.
\  ;
\  : ser/vb&! ( -- t )
\  \G Ser: Write the variable-length quantity (single) to disk.
\  ;
\
\  : ser/vb#@ ( -- t )
\  \G Ser: read the declared variable-length quantity (single) length from disk.
\  ;
\  : ser/vb&@ ( -- t )
\  \G Ser: Read the variable-length quantity (single) from disk.
\  ;
\  : ser/vb#-d! ( l-d -- t )
\  \G Ser: declare a variable-length quantity (double) length at this offset.
\  ;
\  : ser/vb#-d@ ( -- t )
\  \G Ser: read the declared variable-length quantity (double) length from disk.
\  ;
\  : ser/fb#! ( l -- t )
\  \G Ser: declare a fixed-length quantity (single) length at this offset.
\
\  ;
\ : ser/@ ser/sync-r execute ;
\ : ser/! ser/sync-w execute ;
\ : ser/+ ser/size$ @ dup fs/+ ser/offset$ +! ;
\ : ser/D+ ser/size$ 2@ dup fs/d+ ser/offset$ 2@ D+ ser/offset$ 2! ;

\ ************* 3ed (Triplefox Editor) format *************

0 value 3ed/rom$ \ The offset of the rom for all viewing words relative to rom
0 value 3ed/ram$ \ The offset of the ram for all viewing words relative to ram
0 value 3ed/fs-chunk$ \ The index of the chunk, for all 3ed words using fs.
0 value 3ed/stream$ \ The offset within the stream, when reading/writing stream data relative to ram.
0 value 3ed/stream-bytes$ \ The number of bytes last read or written from the stream.
0 value 3ed/status$ \ The status code returned by 3ed/verify

: 3ed/row/t-u 3 ; \ type
: 3ed/row/d-u 48 ; \ data
: 3ed/row-u 51 ; \ total size

\ All of the row types in 3ed share this base wordset:

\ row type is the first 3 bytes
\ data is the following 48
: 3ed/data^ ( ram/rom$ -- ) cell+ ;
: 3ed/data@ ( dest-caddr ram/rom$ -- ) cell+ swap 3ed/row/d-u cmove ;
: 3ed/data! ( src-caddr ram/rom$ -- ) cell+ 3ed/row/d-u cmove ;
: 3ed/row. ( ram/rom$ -- )
  dup @ cell>chars. ."  "
  3ed/data^ 3ed/row/d-u rawtype
;

\ The ROM row occurs at the base of the file:

: 3ed/rom/magic? 3ed/rom$ @ $4D4F52 = ;
: 3ed/rom/magic! $4D4F52 3ed/rom$ ! ;
: 3ed/rom/romrows^ 3ed/rom$ 3ed/data^ ;
: 3ed/rom/ramrows^ 3ed/rom$ 3ed/data^ cell+ ;
: 3ed/rom/chunkcap^ 3ed/rom$ 3ed/data^ cell+ cell+ ;
: 3ed/rom/numchunks^ 3ed/rom$ 3ed/data^ [ 3 cells literal ] + ;
: 3ed/rom/romname^ 3ed/rom$ 3ed/data^ [ 4 cells literal ] + ;
: 3ed/rom/romname-u 36 ;
: 3ed/romrows-u 3ed/rom/romrows^ @ 3ed/row-u * ;
: 3ed/ramrows-u 3ed/rom/ramrows^ @ 3ed/row-u * ;
: 3ed/str-u 3ed/rom/chunkcap^ @ 3ed/ramrows-u - ;
: 3ed/rom/romrows? 3ed/rom/romrows^ @ 0> ;
: 3ed/rom/ramrows? 3ed/rom/ramrows^ @ 0> if 3ed/row-u * 3ed/rom/chunkcap^ @ <= else false exit then ;
: 3ed/rom/fsize-d ( -- d ) 3ed/romrows-u s>d 3ed/rom/chunkcap^ @ 3ed/rom/numchunks^ @ m* d+ ;
: 3ed/rom-dump 3ed/rom$ 3ed/romrows-u 512 min 16 + col-dump ;
: 3ed/rom. 3ed/rom$ @ cell>chars. ."  "
  3ed/rom/romrows^ @ ." rom=" .
  3ed/rom/ramrows^ @ ." ram=" .
  3ed/rom/chunkcap^ @ ." cap=" .
  3ed/rom/numchunks^ @ ." chk=" .
  3ed/rom/romname^ 3ed/rom/romname-u rawtype
;
: 3ed/rom-clear
\G Clear the ROM rows past row 0 (the header row).
  3ed/rom$ 3ed/row-u + 3ed/romrows-u 3ed/row-u - erase
;

\ The RAM row occurs once per chunk:

: 3ed/ram/magic? 3ed/ram$ @ $4D4152 = ;
: 3ed/ram/magic! $4D4152 3ed/ram$ ! ;
: 3ed/ram/chunktype^ 3ed/ram$ 3ed/data^ ;
: 3ed/ram/strlength^ 3ed/ram$ 3ed/data^ cell+ ;
: 3ed/ram/strlength? 3ed/ram/strlength^ @ 3ed/ramrows-u + 3ed/rom/chunkcap^ @ <= ;
: 3ed/ram/chunkname^ 3ed/ram$ 3ed/data^ cell+ cell+ ;
: 3ed/ram/chunkname-u 41 ;
: 3ed/ram-index-d ( idx -- offset-d )
\G Compute the byte offset of indicated chunk index.
  3ed/rom/chunkcap^ @ M* 3ed/romrows-u s>d d+ ;
: 3ed/ram-index-d? ( idx -- t )
\G Compute whether the indicated chunk index is within 0 and numchunks.
  0 3ed/rom/numchunks^ @ within ;
: 3ed/ram-dump 3ed/ram$ 3ed/ramrows-u 512 min 16 + col-dump ;
: 3ed/ram-clear
\G Clear the RAM rows past row 0 (the header row).
  3ed/ram$ 3ed/row-u + 3ed/ramrows-u 3ed/row-u - erase
;
: 3ed/ram/chunk-u 3ed/ramrows-u 3ed/ram/strlength^ @ + ;

: 3ed/str-index-d ( idx -- offset-d )
  3ed/ram-index-d 3ed/ramrows-u s>d d+ ;
;

: 3ed/ram. 3ed/ram$ @ cell>chars. ."  "
  3ed/ram/chunktype^ @ ." type=" cell>chars.
  3ed/ram/strlength^ @ ."  #str=" .
  3ed/ram/chunkname^ 3ed/ram/chunkname-u rawtype
;

: 3ed/rom>fs
\G Write the selected rom buffer in 3ed/rom$ to the file.
  0 0 fs/seek
  3ed/rom$ 3ed/romrows-u fs/bytes!
;
: 3ed/fs>rom ( u -- )
\G Read up to u bytes from fs to the rom buffer in 3ed/rom$.
  0 0 fs/seek
  3ed/rom$ swap
  fs/bytes@
;
: 3ed/fs>ram
\G Read 3ed/fs-chunk$ to 3ed/ram$. Reset 3ed/stream$ to 0.
  3ed/fs-chunk$ 3ed/ram-index-d fs/seek
  3ed/ram$ 3ed/ramrows-u fs/bytes@
  0 to 3ed/stream$
;
: 3ed/ram>fs
\G Write 3ed/ram$ ram-u to 3ed/fs-chunk$.
  3ed/fs-chunk$ 3ed/ram-index-d fs/seek
  3ed/ram$ 3ed/ramrows-u fs/bytes!
;
: 3ed/fs>strall ( caddr -- )
\G Read all the stream bytes of 3ed/fs-chunk$ 3ed/str-u to caddr.
  3ed/fs-chunk$ 3ed/str-index-d fs/seek
  3ed/str-u fs/bytes@
;
: 3ed/strall>fs ( caddr -- )
\G Write caddr str-u to the beginning of the stream area of 3ed/fs-chunk$.
  3ed/fs-chunk$ 3ed/str-index-d fs/seek
  3ed/str-u fs/bytes!
;
: 3ed/str-advance ( u -- u )
\G Advance the position of 3ed/stream$ by u bytes within the chunk, saturating at end of chunk.
\G Sync the seek position in fs$ to 3ed/fs-chunk$ 3ed/stream$.
\G Return the actual number of bytes of advancement.
  3ed/stream$ + 3ed/str-u 1- min 3ed/stream$ - dup
  3ed/stream$ s>d 3ed/fs-chunk$ 3ed/str-index-d d+ fs/seek
  3ed/stream$ + to 3ed/stream$
;
: 3ed/str@ ( dest u -- )
\G Read bytes from the stream data at 3ed/stream$, relative to selected fs chunk.
\G Advance 3ed/stream$ by u until end of chunk.
\G Actual number of bytes read is stored to 3ed/stream-bytes$.
  3ed/str-advance dup to 3ed/stream-bytes$ fs/bytes@
;
: 3ed/str! ( dest u -- )
\G Write bytes to the selected fs chunk at 3ed/stream$ from the stream data at dest.
\G Advance 3ed/stream$ by u until end of chunk.
\G Actual number of bytes written is stored to 3ed/stream-bytes$.
  3ed/str-advance dup to 3ed/stream-bytes$ fs/bytes!
;
: 3ed/str-end? ( -- t )
\G Return true if 3ed/stream$ has reached the end of the chunk.
  3ed/stream$ 3ed/str-u 1- - 0=
;
: 3ed/str-erase! ( -- )
\G Fill the stream area in $fs with zero bytes, copied from the PAD area.
  0 to 3ed/stream$
  pad 256 erase
  begin
    pad 256 3ed/str!
  3ed/str-end? until
;
: 3ed/rom-row? ( idx -- t )
\G Return true if supplied row index is within area specified by rom.
  0 3ed/rom/romrows^ @ within
;
: 3ed/ram-row? ( idx -- t )
\G Return true if supplied row index is within area specified by ram.
  0 3ed/rom/ramrows^ @ within
;
: 3ed/chunk? ( idx -- t )
\G Return true if supplied chunk index is within area specified by rom.
  0 3ed/rom/numchunks^ @ within
;

: 3ed/populate! ( -- )
\G Write the data in $rom and $ram to fs$.
\G Fill out the file with the number of bytes and copies of $ram indicated by the chunk count and capacities.

    3ed/rom>fs
    0 to 3ed/fs-chunk$
    begin
      3ed/ram>fs
      3ed/str-erase!
      3ed/fs-chunk$ 1+ to 3ed/fs-chunk$
    3ed/fs-chunk$ 3ed/rom/numchunks^ @ =
    until
;

100 constant 3ed/status/rom-magic \ the opening three bytes are not "ROM"
200 constant 3ed/status/romrows-underflow \ The rom rows are less than 1
201 constant 3ed/status/romrows-overflow \ The rom rows exceed fsize
300 constant 3ed/status/alloc-mismatch \ The total rom + chunks data does not match fsize
400 constant 3ed/status/ramrows-underflow \ The ram rows are less than 1
401 constant 3ed/status/ramrows-overflow \ The ram rows exceed chunk capacity
500 constant 3ed/status/ram-magic \ the opening three bytes are not "RAM"
600 constant 3ed/status/ramlength-overflow \ The total rows + stream of this chunk exceeds capacity

: 3ed/verify ( -- )
\G Verify the integrity of rom$ and fs$.
\G Detect whether ROM and RAM headers are in the correct places and quantities.
\G Stores to 3ed/status$ and 3ed/fs-chunk$. Does not run if status$ is set.
\G Fails if reported fs/fsize-d is different from actual(e.g. newly written file).

  3ed/status$ 0<> if exit then
  3ed/rom/magic? if else 3ed/status/rom-magic to 3ed/status$ exit then
  3ed/rom/romrows^ @ 0> if else 3ed/status/romrows-underflow to 3ed/status$ exit then
  fs/fsize-d 3ed/rom/romrows^ @ 3ed/row-u m* d< if 3ed/status/romrows-overflow to 3ed/status$ exit then
  fs/fsize-d 3ed/rom/fsize-d d= if else 3ed/status/alloc-mismatch to 3ed/status$ exit then
  3ed/rom/ramrows^ @ 0> if else 3ed/status/ramrows-underflow to 3ed/status$ exit then
  3ed/rom/chunkcap^ @ s>d 3ed/rom/ramrows^ @ 3ed/row-u m* d< if 3ed/status/ramrows-overflow to 3ed/status$ exit then

  3ed/rom/numchunks^ @ 0 do
    i to 3ed/fs-chunk$
    3ed/fs>ram

    3ed/ram/magic? if else 3ed/status/ram-magic to 3ed/status$ leave then
    3ed/rom/chunkcap^ @ 3ed/ram/chunk-u < if 3ed/status/ramlength-overflow to 3ed/status$ leave then

  loop

;

: 3r/str $525453 ;
: 3r/p48 $383450 ;
: 3r/p24 $343250 ;

\ 3ed examples

\  512 constant rombuf-u
\  512 constant rambuf-u
\  512 constant strbuf-u
\
\  create rombuf rombuf-u allot
\  create rambuf rambuf-u allot
\  create strbuf strbuf-u allot
\
\  : fs>3edtest
\    rombuf to 3ed/rom$
\    rambuf to 3ed/ram$
\    rombuf-u 3ed/fs>rom
\  ;
\
\  123 value myval
\
\  s" test.3ed" fs/mode/open-existing fs/open
\
\  fs>3edtest
\  3ed/fs>ram
\  5 to myval
\  3ed/rom.
\  6 to myval
\  3ed/rom-dump cr
\  7 to myval
\  3ed/ram.
\  8 to myval
\  3ed/ram-dump
\  9 to myval
\
\  3ed/verify
\  cr .( Verify: ) 3ed/status$ . cr
\  fs/close

\  : adv
\    cr
\    strbuf strbuf-u 3ed/str@ 3ed/stream-bytes$ .
\    strbuf strbuf-u col-dump
\    cr
\  ;
\
\  : outfile
\    s" out.3ed"
\  ;
\  : untitled
\    s" untitled"
\  ;
\
\  : populate-example
\    outfile fs/mode/read fs/mode/write or fs/mode/create-always or fs/open
\
\    ." open" fs/status$ . cr
\
\    3ed/rom/magic!
\    2 3ed/rom/romrows^ !
\    2 3ed/rom/ramrows^ !
\    256 3ed/rom/chunkcap^ !
\    4 3ed/rom/numchunks^ !
\    3ed/rom/romname^ 3ed/rom/romname-u erase
\    untitled 3ed/rom/romname^ swap cmove
\    3ed/rom-clear
\    3ed/ram-clear
\
\    ." rom"
\
\    3ed/ram/magic!
\    3r/str 3ed/ram/chunktype^ !
\    0 3ed/ram/strlength^ !
\    3ed/ram/chunkname^ 3ed/ram/chunkname-u erase
\    untitled 3ed/ram/chunkname^ swap cmove
\
\    ." ram"
\
\    3ed/populate!
\
\    ." pop"
\
\    fs/close
\  ;
\
\  : 3edtest
\    fs/mode/open-existing fs/mode/read or fs/open
\    fs/curfilename$ asciiz> type ." : " fs>3edtest
\    3ed/verify 3ed/status$ . 0 to 3ed/status$
\    fs/close cr
\  ;
\  : alltests
\    s" 3ed_tests/clean.3ed" 3edtest
\    s" 3ed_tests/err100.3ed" 3edtest
\    s" 3ed_tests/err200.3ed" 3edtest
\    s" 3ed_tests/err201.3ed" 3edtest
\    s" 3ed_tests/err300.3ed" 3edtest
\    s" 3ed_tests/err400.3ed" 3edtest
\    s" 3ed_tests/err401.3ed" 3edtest
\    s" 3ed_tests/err500.3ed" 3edtest
\    s" 3ed_tests/err600.3ed" 3edtest
\  ;

\ ************* Color mixing and display *************

60100 constant color:font \ buffer for color font
61000 constant color:bmp \ buffers(thru 61255) for color font bitmaps
0 value color/map$
0 value color$

: color/logical>rgba ( v -- v )
\G map logical color index (0-64) to RGBA byte (0 for transparent, 192-255 for visible colors)
  dup 0= if else 191 + then
;
: color/logical>map ( v -- v )
\G map logical color index (0> ) into the table assigned at color/map$
  color/map$ + c@
;

: color/rgba2222>u ( r g b a -- v )
\G mix RGBA colors. Input takes values 0-3 for each, a is "visible if non-zero"
  6 lshift swap
  4 lshift or swap
  2 lshift or or
;
: color/u>rgba2222 ( v -- r g b a )
\G Split RGBA colors into four cell values.
  dup 6 rshift >r
  dup 63 and 4 rshift >r
  dup 15 and 2 rshift >r
  3 and >r
  r> r> r> r>
;
create color:r^ 4 allot
color:r^ 1+ constant color:g^
color:g^ 1+ 1+ constant color:b^
color:b^ 3 + constant color:a^
: color/rgba2222>mix= ( r g b a -- )
\G Assign the four cells given to the mix color.
  color:a^ c! color:b^ c! color:g^ c! color:r^ c!
;
: color/wrap 3 and ;
: color/saturate 3 min 0 max ;
: color/rgba2222>mix+wrap ( r g b a -- )
\G Add the four cells given to the mix color, wrapping around.
  color:a^ c@ + color/wrap color:a^ c!
  color:b^ c@ + color/wrap color:b^ c!
  color:g^ c@ + color/wrap color:g^ c!
  color:r^ c@ + color/wrap color:r^ c!
;
: color/rgba2222>mix+saturate ( r g b a -- )
\G Add the four cells given to the mix color, saturating.
  color:a^ c@ + color/saturate color:a^ c!
  color:b^ c@ + color/saturate color:b^ c!
  color:g^ c@ + color/saturate color:g^ c!
  color:r^ c@ + color/saturate color:r^ c!
;
: color/u>mix= ( v -- )
\G Assign the cell given to the mix color.
color/u>rgba2222 color/rgba2222>mix= ;
: color/u>mix+wrap ( v -- )
\G Add the cell given to the mix color, wrapping around.
color/u>rgba2222 color/rgba2222>mix+wrap ;
: color/u>mix+saturate ( v -- )
\G Add the cell given to the mix color, saturating.
color/u>rgba2222 color/rgba2222>mix+saturate ;
: color/mix>rgba2222 ( -- r g b a )
\G Read the mix color to the stack as four cells.
color:r^ c@ color:g^ c@ color:b^ c@ color:a^ c@ ;
: color/mix>u ( -- v )
\G Read the mix color to the stack as one cell.
color/mix>rgba2222 color/rgba2222>u ;
: color/mix.
\G Print the mix color.
color/mix>rgba2222 ." A" . ." B" . ." G" . ." R" . ;

: color/make-char. ( v -- )
\G Make the buffer vdp/buf/bufid@ a bitmap with solid color v.
\G Assign the bitmap to character vdp/font/char-id$.
    ( v ) vdp/font/char-w$ vdp/font/char-h$ vdp/bmp/create-solid-2222.
    vdp/font/char-id$ vdp/buf/bufid@ vdp/sys/bmp>char.
;

: color/make-font.
\G Make a font in vdp/font/bufid@ based on the system font, that contains solid colors in the upper region,
\G mapped to their corresponding RGBA2222 values from byte 192 upwards.
\G Remember that not all colors will display in all graphics modes!
    color:font vdp/font/bufid!
    vdp/font/sysfont.
    8 to vdp/font/char-w$
    8 to vdp/font/char-h$
    color:font vdp/font/select.

    0 color:bmp + vdp/buf/bufid!
    0 to vdp/font/char-id$
    0 color/make-char.

    192 to color$
    begin
      color$ color:bmp + vdp/buf/bufid!
      color$ to vdp/font/char-id$
      color$ color/make-char.
      color$ 1+ to color$
    color$ 256 = until
;

\ ************* Keyboard *************
\ A-Nib has a custom keyboard vector controlled through mos/setkbvector, mos/clearkbvector.
\ This goes around the KEY and related words in Agon Forth in favor of an event-based system,
\ governed by a read/write ring buffer with 16 entries.
\ To use it once installed, advance the reader with kb/read+, read the values in ascii@, mods@, fabgl@, and is-down@,
\ launch the desired tasks, and repeat until kb/done? is true.
\ If you don't need to use it for an extended period, run kb/flush to keep the write queue unblocked.
\
\ Technical Note:
\
\ ascii@ will not always contain the key that changed on keyup. For example, if you depress A and B and then release
\ A and B, it will read "B and B". This is because fabgl is only updating it on keydown.
\ Therefore, the correct thing to do for distinguishing input as button presses is to always use fabgl@,
\ and to only use ascii@ for keydown typing.

variable kb:w^
variable kb:r^
16 4 * constant kb:event-u
create kb:event kb:event-u allot
0 kb:w^ !
0 kb:r^ !

: kb/done? ( -- t ) kb:r^ @ kb:w^ @ = ;
: kb/read+ ( -- ) kb:r^ @ 4 + [ kb:event-u 1- literal ] and kb:r^ ! ;
: kb/ascii@ ( -- v ) kb:r^ @ kb:event + c@ ;
: kb/mods@ ( -- v ) kb:r^ @ kb:event + 1 + c@ ;
: kb/fabgl@ ( -- v ) kb:r^ @ kb:event + 2 + c@ ;
: kb/is-down@ ( -- t ) kb:r^ @ kb:event + 3 + c@ ;
: kb/flush
  kb/done? 0= if
    begin
        kb/read+
    kb/done? until
  then
;

\ TODO: there's probably a way to neatly encapsulate this in the dictionary but i haven't figured it out
code kb/_iv_out
	pop iy
	pop ix
	pop hl
	pop bc
	ret
end-code
code kb/_iv_

    push bc
    push hl
    push ix
    push iy

    \ DE starts with our new key event

    ld a, kb:w^ ()          \ load the write pointer
    add a, 4                \ add 4 (size of event)
    and a, kb:event-u 1-    \ modulo size of event buffer (wraparound)
    ld hl, kb:r^            \ load the read pointer for comparison
    cp a, (hl)              \ compare our new value with read pointer
    jr z, ' kb/_iv_out      \ if it's going to be equal, cancel
    ld kb:w^ (), a          \ store write pointer
    ld ix, kb:event         \ load the event buffer
    ld bc, kb:w^ ()         \ load the write pointer for adding
    add ix, bc              \ answer: index into the buffer
    push ix                 \ answer to stack
  	push de                 \ store address of key event to stack
  	pop hl                  \ ldir: dest
  	pop de                  \ ldir: src
    ld bc, 4                \ ldir: count
    ldir

	pop iy
	pop ix
	pop hl
	pop bc
	ret
end-code

code mos/setkbvector
    \ Based on https://github.com/tomm/toms-agon-experiments/blob/main/custom_kbvector_demo/custom_kbvector_demo.asm
    ld hl, ' kb/_iv_ \ quote the interrupt word to get the address
    ld c, 0		     \ c=0 means 24-bit handler pointer in hl (c=1 means 16-bit pointer)
    ld a, $1d        \ mos_setkbvector
    rst .lil $8
    next
end-code

code mos/clearkbvector
    \ Based on https://github.com/tomm/toms-agon-experiments/blob/main/custom_kbvector_demo/custom_kbvector_demo.asm
    ld hl, 0         \ hl=0 clears
    ld c, 0
    ld a, $1d        \ mos_setkbvector
    rst .lil $8
    next
end-code

\  true value end-demo$
\  : end-demo?
\      kb/ascii@ 27 = if true to end-demo$ then
\  ;
\
\  : handlertest/print
\      begin
\          kb/read+
\          kb/ascii@ . kb/mods@ . kb/fabgl@ . kb/is-down@ . cr
\          end-demo?
\      kb/done? until
\  ;
\
\  : handlertest
\      false to end-demo$
\      mos/setkbvector
\      cr ." Handling!" cr
\      begin
\          kb/done? 0= if
\              handlertest/print
\          then
\      end-demo$ until
\      mos/clearkbvector
\  ;

\ ************* Screen initialization and teardown *************

: screen/init. ( screen-mode -- )
  255 vdp/ctx/reset.
  vdp/reset-modes.
  0 vdp/sys/logical-scale.
  0 vdp/sys/legacy.
  vdp/bmp/reset.
  ( mode ) vdp/screen-mode.
  vdp/clg.
  vdp/sys/flush.
;

: screen/finish.
  1 vdp/cursor-ctrl.
  vdp/reset-modes.
  1 vdp/sys/logical-scale.
  vdp/bmp/reset.
  0 vdp/screen-mode.
  vdp/cls.
  vdp/sys/flush.
  255 vdp/ctx/reset.
;

0 value a2d8$ \ array data begins here. w/h header appears behind this position
0 value a2d8? \ last operation error flag
' false value a2d8/oob-xt   \ on OOB read, return v from this

: a2d8/create ( w h "name" -- )
  create 2dup * -rot swap , , allot
  does>
  [ 2 cells literal ] + to a2d8$
;
: a2d8/w^ a2d8$ [ 2 cells literal ] - ;
: a2d8/h^ a2d8$ cell- ;
: a2d8-h-u [ 2 cells literal ] ;
: a2d8-d-u a2d8/w^ @ a2d8/h^ @ * ;
: a2d8-u a2d8-h-u a2d8-d-u + ;
: a2d8/xy>idx ( x y -- idx ) a2d8/w^ @ * + ;
: a2d8! ( v idx -- ) a2d8$ + c! ;
: a2d8@ ( idx -- v ) a2d8$ + c@ ;
: a2d8/h.
\G Print the header of the selected a2d8 structure.
  a2d8$ [ 2 cells 4 + literal ] - \ gross hack to walk back from cur-arena parameter field to the name field. may break if code size changes
  >name-timeout id. a2d8/w^ @ . backspace ." w " a2d8/h^ @ . backspace ." h "
;
: a2d8/d.
\G Print the data dump of the selected a2d8 structure.
a2d8$ a2d8-d-u col-dump ;
: a2d8.
\G Print the header and data of the selected a2d8 structure.
a2d8/h. cr a2d8/d. ;
: a2d8/within? ( x y -- t )
\G Test whether the x y value fits inside the defined a2d8 area.
  0 a2d8/h^ @ within
  if
    0 a2d8/w^ @ within
  else drop false then ;

: a2d8/plot@ ( x y -- v ) \
\G Read a value from a2d8$ at coordinates x y. If OOB, indirect to a2d8/oob-xt.
  2dup a2d8/within? if
    a2d8/xy>idx a2d8@
  else
    drop drop a2d8/oob-xt execute
  then
;
: a2d8/plot! ( v x y -- )
\G Write value at coordinates x and y. Test for valid coordinates first.
  2dup a2d8/within? dup to a2d8?
  if a2d8/w^ @ * + a2d8$ + c!
  else 2drop drop then
;
: a2d8/plot-unsafe! ( v x y -- )
\G Write value at coordinates x and y, with no memory protection.
  a2d8/w^ @ * + a2d8$ + c!
;
: a2d8/fill ( v -- )
\G Fill the entire map with value v.
  a2d8$ a2d8-d-u rot fill
;

\ 3 5 a2d8/create mymap
\ mymap a2d8.
\ 0 0 a2d8/within? . depth .
\ -1 0 a2d8/within? . depth .
\ 0 -1 a2d8/within? . depth .
\ 3 0 a2d8/within? . depth .
\ 0 5 a2d8/within? . depth .
\ 10 0 0 a2d8/plot!
\ 10 1 1 a2d8/plot!
\ 10 2 2 a2d8/plot-unsafe!
\ 2 2 a2d8/plot@ .
\ a2d8.
\ $03 a2d8/fill a2d8.

0 value rect/a$
0 value rect/b$

: rect/x@ @ ;
: rect/y@ cell+ @ ;
: rect/w@ [ 2 cells literal ] + @ ;
: rect/h@ [ 3 cells literal ] + @ ;
: rect/x! ! ;
: rect/y! cell+ ! ;
: rect/w! [ 2 cells literal ] + ! ;
: rect/h! [ 3 cells literal ] + ! ;
4 cells constant rect-u
: rect/create-hwyx ( h w y x "name" -- )
  create , , , ,
  does>
;
: rect/create-btrl ( b t r l "name" -- )
  create dup , - >r dup , - r> , ,
  does>
;
: rect/create-empty ( "name" -- )
  create 0 , 0 , 1 , 1 ,
  does>
;
: rect. ( rect$ -- )
  dup rect/x@ ." x" . dup rect/y@ ." y" . dup rect/w@ ." w" . rect/h@ ." h" .
;

: rect/right@ ( rect$ -- r ) dup rect/w@ swap rect/x@ + ;
: rect/bottom@ ( rect$ -- b ) dup rect/h@ swap rect/y@ + ;
: rect/right! ( v rect$ -- ) tuck rect/x@ - swap rect/w! ;
: rect/bottom! ( v rect$ -- ) tuck rect/y@ - swap rect/h! ;
: rect/a>b! rect/a$ rect/b$ rect-u cmove ;
: rect/b>a! rect/b$ rect/a$ rect-u cmove ;
: rect/normalize-w!
\G If rect/a$ has a negative width, flip the relative position of x to make it positive.
  rect/a$ rect/w@ 0< if rect/a$ rect/w@ dup rect/a$ rect/x@ + rect/a$ rect/x! negate rect/a$ rect/w! then
;
: rect/normalize-h!
\G If rect/a$ has a negative height, flip the relative position of y to make it positive.
  rect/a$ rect/h@ 0< if rect/a$ rect/h@ dup rect/a$ rect/y@ + rect/a$ rect/y! negate rect/a$ rect/h! then
;
: rect/col-relation ( x -- x )
\G x describes a point parented to rect/a$, that is, the left side of the rectangle is x=0.
\G rect/b$ is a camera view of rect/a$, and translates x relative to its position.
  rect/a$ rect/x@ rect/b$ rect/x@ - +
;
: rect/row-relation ( y -- y )
\G y describes a point parented to rect/a$, that is, the top side of the rectangle is y=0.
\G rect/b$ is a camera view of rect/a$, and translates y relative to its position.
  rect/a$ rect/y@ rect/b$ rect/y@ - +
;
: rect/col-snap-inside ( x -- x )
\G x describes a point on the x-axis of rect/a$. If outside, snap the point inside the rectangle.
  rect/a$ rect/x@ max rect/a$ rect/right@ min
;
: rect/row-snap-inside ( y -- y )
\G y describes a point on the y-axis of rect/a$. If outside, snap the point inside the rectangle.
  rect/a$ rect/y@ max rect/a$ rect/bottom@ min
;
: rect/col-wrap-inside ( x -- x )
\G x describes a point on the x-axis of rect/a$. If outside, wrap the point around to the other side.
  rect/a$ rect/x@ - rect/a$ rect/w@ mod rect/a$ rect/x@ +
;
: rect/row-wrap-inside ( y -- y )
\G y describes a point on the y-axis of rect/a$. If outside, wrap the point around to the other side.
  rect/a$ rect/y@ - rect/a$ rect/h@ mod rect/a$ rect/y@ +
;
: rect/row-bounds ( y -- offset len )
\G Compute the boundaries of one row of data if rect/a$ is projected to an array starting at 0,0 as in a2d8.
\G Note that you will need to normalize, crop and offset the rectangle to actually fit the array.
  rect/a$ rect/w@ dup -rot * rect/a$ rect/x@ + swap
;

\ TODO: tests
\ rect/point-within?
\ rect/point-without?
\ rect/left?
\ rect/right@?
\ rect/above?
\ rect/below?
\ rect/overlap?

\ I think I can stop at this featureset. There's plenty more that I can add to my rectangles,
\ but this will be enough to let me build an editor.
\ I'll have to return to them when I go towards making an action game.

0 value c2d$
: c2d/create-y1x1y0x0 ( y1 x1 y0 x0 "name" -- )
  create , , , , does> to c2d$
;
: c2d/create-empty ( "name" -- )
  create 0 , 0 , 0 , 0 , does> to c2d$
;
: c2d/x0@ c2d$ @ ;
: c2d/x0! ( v -- ) c2d$ ! ;
: c2d/y0@ c2d$ cell+ @ ;
: c2d/y0! ( v -- ) c2d$ cell+ ! ;
: c2d/x1@ c2d$ [ 2 cells literal ] + @ ;
: c2d/x1! ( v -- ) c2d$ [ 2 cells literal ] + ! ;
: c2d/y1@ c2d$ [ 3 cells literal ] +  @ ;
: c2d/y1! ( v -- ) c2d$ [ 3 cells literal ] + ! ;
: c2d-u [ 4 cells literal ] ;
: c2d. c2d/x0@ ." ((" . c2d/y0@ . ." )(" c2d/x1@ . c2d/y1@ . ." ))" ;

: xy/left -1 0 ;
: xy/right 1 0 ;
: xy/up 0 -1 ;
: xy/down 0 1 ;
: c2d/inc0 ( x y -- )
  c2d/y0@ + c2d/y0! c2d/x0@ + c2d/x0!
;
: c2d/inc1 ( x y -- )
  c2d/y1@ + c2d/y1! c2d/x1@ + c2d/x1!
;

: c2d/>rect
  c2d/x0@ rect/a$ rect/x!
  c2d/y0@ rect/a$ rect/y!
  c2d/x1@ rect/a$ rect/right!
  c2d/y1@ rect/a$ rect/bottom!
;

: c2d/rect/wrap0
\G Produces wraparound motion for c2d$ x0 y0 inside rect/a$.
  c2d/x0@ rect/col-wrap-inside c2d/x0!
  c2d/y0@ rect/row-wrap-inside c2d/y0!
;
: c2d/rect/wrap1
\G Produces wraparound motion for c2d$ x1 y1 inside rect/a$.
  c2d/x1@ rect/col-wrap-inside c2d/x1!
  c2d/y1@ rect/row-wrap-inside c2d/y1!
;
: c2d/rect/snap0
\G Produces snap-to-border motion for c2d$ x0 y0 inside rect/a$.
  c2d/x0@ rect/col-snap-inside c2d/x0!
  c2d/y0@ rect/row-snap-inside c2d/y0!
;
: c2d/rect/snap1
\G Produces snap-to-border motion for c2d$ x1 y1 inside rect/a$.
  c2d/x1@ rect/col-snap-inside c2d/x1!
  c2d/y1@ rect/row-snap-inside c2d/y1!
;

\ TODO line drawing, rectangle drawing, etc.

\ ************* Linear Interpolation *************

100 value lerp/%range$ \ lerp inputs range between 0 and this value. Outputs are provided at call time
: lerp/% \ ( x1 x0 input-pct -- interpolated-x0x1 )
\G interpolate between x0 and x1 by input-pct, using lerp/%range$ to judge the relative distance of input-pct.
  -rot dup -rot - \ compute difference
  rot lerp/%range$ */ + \ multiply divide interpolation
;

\ TODO write a screen definition for the next generation of the other editors:
\ width, height, named positional targets
\ stream area containing character data
\ this doesn't actually need its own editor just yet
\ i want it to be data driven so that it can be reused for tilemapping at some point
\ and i want to use it to make the ui screens rather than hand-code each of those

\ Ahh, we can build the positional targets using , data.
\ The rest we might have to make words for.
\ There's an argument that it would be efficient to use row data for that purpose, I guess?

\ There's probably more I can do with input buffers that resembles the VDP code.

\ I think the way to go for revising the editors is to start with the presentation, then add back in the functions.
\ That gets me in the saddle with writing the VDP code again.

\ I think there might be some kind of thing I could do with reusable UI, for sure.
\ That would bring a distinctive "look" to A-Nib stuff.
\ Since I'm going to be prototyping chorded UI I can probably focus the design language around that.

\ Design plan for the new UI scheme:
\ I need words that let me define "UI screens" in terms of, when I have a particular mode,
\ it needs to display a bunch of text quickly. The text will be relatively short in preplanned positions.
\ The screens are not the entire screen, they are panes. The pane model can probably take a general rectangle offset.
\ The panes have a cursor state. The cursor state is going to be tied to the text cell.
\ The cursor state is reused by the cursor visualization and I can do a tween effect on it to clarify UI changes.
\ The cursors should probably identify themselves as left/right clearly. So they could have a bias instead of being centered crosshairs.
\ I can use some color or inversion to help clarify. If I go with 8 buttons per, I can do something like QWER/ASDF, map WASD to arrows, then the others are buttons.
\ And then the screen layout reflects this by dedicating four rows at the bottom. In my graphics 20 screen, I have 32 cols per side to get the job done.
\ That would mean 8 cols per feature...which is small. If I go up to six rows, then I can add slightly more explanation.
\ Ah. I can allocate 3 cols just for the key and then leave 5 for the text, meaning that in 4-row form I can do some two-word stuff.
\ Some keys like BK. (backspace) or ESC (escape) will get little abbreviations. But in ordinary circumstances they don't even show up because that won't be the
\ binding.
\ This can all exist as a single 128-byte (plus command codes to set color) segment that gets uploaded repeatedly for each screen.

\ Maybe the thing I'm after should just be "panes", the data structure. A pane is a byte area that is an array but also positional, gets synchronized in various ways.
\ It basically resembles an a2d8 but also has some other stuff related to text and color.

.( Type SAVE-SYSTEM a-nib.bin to save as binary) cr
