( Retro ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Copyright [c] 2008 - 2011, Charles Childers                                 )
( Copyright [c] 2009 - 2010, Luke Parrish                                     )
( Copyright [c] 2010,        Marc Simpson                                     )
( Copyright [c] 2010,        Jay Skeer                                        )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )

( Assembler and Metacompiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
2560 constant IMAGE-SIZE

( Assembler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
variables| target origin 'WORD 'MACRO 'DATA 'PRIM link chain |

: m,  ( n-  ) @target !+ !target ;
: vm: ( n"- ) ` : .data ` m, ` ; ;
   0 vm: nop,          1 vm: lit,          2 vm: dup,
   3 vm: drop,         4 vm: swap,         5 vm: push,
   6 vm: pop,          7 vm: loop,         8 vm: jump,
   9 vm: ;,           10 vm: >jump,       11 vm: <jump,
  12 vm: !jump,       13 vm: =jump,       14 vm: @,
  15 vm: !,           16 vm: +,           17 vm: -,
  18 vm: *,           19 vm: /mod,        20 vm: and,
  21 vm: or,          22 vm: xor,         23 vm: <<,
  24 vm: >>,          25 vm: 0;           26 vm: 1+,
  27 vm: 1-,          28 vm: in,          29 vm: out,
  30 vm: wait,

: t-here      (  -n ) @target @origin - ;
: pad         ( -   ) 32 @origin + !target ;
: endKernel   (  -  )
  t-here "\nKernel ends @ %d\n" puts
  IMAGE-SIZE t-here - "%d cells free" puts
  depth 1 >= [ "\nError in stack depth!: " puts .s ] ifTrue ;
: main:       (  -  ) t-here [ "\nMAIN @ %d" puts ] [ @origin 1+ ! ] bi ;
: label:      ( "-  ) t-here constant ;
: #           ( n-  ) lit, m, ;
: __#         ( $-  ) lit, toNumber m, ; parsing
: $,          ( $-  ) withLength [ @+ m, ] times 0 m, drop ;

( Metacompiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: t: ( "-  ) label: nop, nop, &m, reclass ;

{{
  : cond ( -a ) @target 0 m, ;
---reveal---
  : =if  ( -a ) !jump, cond ;
  : <if  ( -a ) >jump, cond ;
  : >if  ( -a ) <jump, cond ;
  : !if  ( -a ) =jump, cond ;
  : then ( a- ) t-here swap ! ;
}}

: jump:  ( "-  ) jump, ' m, ;
: repeat (  -a ) t-here ;
: again  ( a-  ) jump, m, ;

: variable: ( n"- ) label: m, ;
: variable  (  "- ) 0 variable: ;
: elements  ( n"- ) &variable times ;
: entry     ( a"- ) t-here @link m, !link m, m, getToken $, ;
: word:     ( a"- ) @'WORD  entry ;
: macro:    ( a"- ) @'MACRO entry ;
: data:     ( a"- ) @'DATA  entry ;
: prim:     ( a"- ) @'PRIM  entry ;
: patch     (   - ) @link [ @chain ! ] [ "\nLast header at %d" puts ] bi ;
: mark      (   - ) @target !chain ;
: setClass  ( aa- ) ! ;

( Image Relocator ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  : for      ( n-   )  here 5 , ; compile-only
  : next     (  -   )  6 , 7 , , ; compile-only
  : @+       ( a-ac )  dup 1+ swap @ ;
  : !+       ( ca-a )  dup 1+ push ! pop ;
  : copy     ( aan- )  for push @+ pop !+ next drop drop ;
  : wait     ( - )     0 0 out [[ 30 , ]] ;
  : save     ( - )     1 4 out 0 0 out wait ;
  : relocate ( - )     origin @ 0 IMAGE-SIZE copy ;
---reveal---
  : bootNew  ( - )     relocate save 0 push ;
}}

( Setup target memory for new image ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: ; ( - ) ;, ;, ;; [[
here [ !target ] [ !origin ] bi IMAGE-SIZE allot
jump, 0 m,
reset
( Retro ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Copyright [c] 2008 - 2012, Charles Childers                                 )
( Copyright [c] 2009 - 2010, Luke Parrish                                     )
( Copyright [c] 2010,        Marc Simpson                                     )
( Copyright [c] 2010,        Jay Skeer                                        )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )


( Kernel Begins ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
IMAGE-SIZE  constant CORE
CORE 0000 + constant TIB
TIB   512 + constant HEAP

( Initial Variables ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
mark variable last  ( Pointer to the most recent dictionary header            )
HEAP variable: heap ( Starting address of the data/code heap                  )
variable compiler   ( Is the compiler on or off?                              )
variable which      ( Pointer to dictionary header of the most recently       )
                    ( looked up word                                          )
pad
label: copytag   "Retro" $,
label: version   "11.2" $,
label: build     "2012.01.10" $,
label: okmsg     "ok  " $,

( Primitives ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: dup  (  n-nn )  dup,  ;      t: 1+   (  n-n  )  1+,   ;
t: 1-   (  n-n  )  1-,   ;      t: swap ( xy-yx )  swap, ;
t: drop (  n-   )  drop, ;      t: and  ( xy-n  )  and,  ;
t: or   ( xy-n  )  or,   ;      t: xor  ( xy-n  )  xor,  ;
t: @    (  a-n  )  @,    ;      t: !    ( na-   )  !,    ;
t: +    ( xy-n  )  +,    ;      t: -    ( xy-n  )  -,    ;
t: *    ( xy-n  )  *,    ;      t: /mod ( xy-qr )  /mod, ;
t: <<   ( xy-n  )  <<,   ;      t: >>   ( xy-n  )  >>,   ;
t: out  ( np-   )  out,  ;      t: in   (  p-n  )  in,   ;
t: wait (   -   )  0 # 0 # out, wait, ;

t: over  (  xy-xyx )  push, dup, pop, swap, ;
t: not   (   x-y   )  -1 # xor, ;
t: on    (   a-    )  -1 # swap, !, ;
t: off   (   a-    )   0 # swap, !, ;
t: /     (  xy-q   )  /mod, swap, drop, ;
t: mod   (  xy-r   )  /mod, drop, ;
t: negate (  x-y   )  -1 # *, ;
t: do    (   a-    )  1-, push, ;
t: @+    (   a-ac  )  dup, 1+, swap, @, ;
t: !+    (  ca-a   )  dup, 1+, push, !, pop, ;

( Core Compiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: here     (  -a )  heap # @, ;
t: ,        ( n-  )  here !+ heap # !, ;
t: ;;       (  -  )  9 # , ;
t: t-;      (  -  )  ;; ;; compiler # off ;
t: ($,)     ( a-a )  repeat @+ 0; , again ;
t: $        ( a-  )  ($,) drop, 0 # , ;
t: push     ( n-  )  5 # , ;
t: pop      (  -n )  6 # , ;

( Conditionals and Flow Control ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: (if)     ( -a            )  , here 0 # , ;
t: t-=if    ( R: xy-  C: -a )  12 # jump: (if)
t: t->if    ( R: xy-  C: -a )  11 # jump: (if)
t: t-<if    ( R: xy-  C: -a )  10 # jump: (if)
t: t-!if    ( R: xy-  C: -a )  13 # jump: (if)
t: t-then   ( R: -    C: a- )  here swap, !, ;
t: t-0;     ( n-n   ||   n- )  25 # , ;
t: t-repeat ( R: -    C: -a )  here ;
t: t-again  ( R: -    C: a- )  8 # , , ;

( Word Classes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: withClass   ( ac- ) 1-, push, ;
t: .word       (  a- ) compiler # @, 0 # !if , ; then jump: do
t: .macro      (  a- ) jump: do
t: .data       (  a- ) compiler # @, 0; drop, 1 # , , ;
t: .primitive  (  a- )
    dup, @, 0 # =if compiler # @, -1 # =if 2 # +, @, then then jump: .word

' .word      'WORD  setClass
' .macro     'MACRO setClass
' .data      'DATA  setClass
' .primitive 'PRIM setClass

( Console Output ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
-1 variable: update
t: redraw (  -  ) update # @, 0; drop, 0 # 3 # out, ;
t: putc   ( c-  ) 0; 1 # 2 # out, wait redraw ;
t: cr     (  -  ) 10 # putc ;
t: (puts) ( a-a ) repeat @+ 0; putc again ;
t: <puts> ( a-  ) (puts) drop, ;
t: puts   ( a-  ) <puts> ;

( Console Input ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
variable break                           ( Holds the delimiter for 'accept'   )
-1 variable: remapping                   ( Allow extended whitespace?         )
-1 variable: eatLeading?                 ( Eat leading delimiters?            )
-1 variable: tabAsWhitespace

t: tib ( -a ) TIB # ;

t: remapKeys ( c-c ) ;
t: ws        ( c-c )
   dup,  127 # =if drop,  8 # then
   dup,   13 # =if drop, 10 # then
   remapping # @, 0; drop,
   dup,   10 # =if drop, 32 # then
   tabAsWhitespace # @, 0 # !if dup, 9 # =if drop, 32 # then then ;

t: <getc> (  -c ) 1 # 1 # out, wait 1 # in, ;
t: getc   (  -c ) repeat <getc> remapKeys dup 0 # !if ws ; then drop, again ;
t: putc?  ( n-n ) dup, 8 # =if drop, break # @, ; then dup, putc ;
t: eat    ( a-a )
   eatLeading? # @, 0; drop
   repeat getc putc? dup, break # @, !if swap, !+ ; then drop, again ;
t: guard? ( n-n ) dup, 1+, tib <if drop, tib ; then 8 # putc ;
t: (accept) ( a-a )
   repeat
     getc
     dup, 8 # =if drop, 1-, guard? jump: (accept) then
     dup, putc
     dup, break # @, =if drop, ; then
     swap, !+
   again ;
t: accept ( c- ) break # !, tib eat (accept) 0 # swap, !+ drop, ;

( Colon Compiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: d->class ( a-a )  1+, ;
t: d->xt    ( a-a )  1+, 1+, ;
t: d->name  ( a-a )  1+, 1+, 1+, ;
t: header   ( $-  )  push, here        ( Entry Start      )
                     last # @, ,       ( Link to previous )
                     last # !,         ( Set as newest    )
                     ' .data # ,       ( Class = .data    )
                     here 0 # ,        ( XT               )
                     pop, $            ( Name             )
                     here swap, !, ;   ( Patch XT to HERE )
t: create   ( "-  )  32 # accept tib header ;
t: [[       (  -  )  compiler # off ;
t: ]]       (  -  )  compiler # on ;
t: :        ( "-  )  create ' .word # last # @, d->class !, ]] 0 # , 0 # , ;
t: t-(      ( "-  )  ') # accept ;

( Quotes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: [        (    -naa ) compiler # @, 8 # , here 0 # , here compiler # on ;
t: ]        ( naa-q   ) push, ;; here swap, !, compiler # !, pop, .data ;

( Combinators ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: empty    (    -    ) ;
t: if       ( fqq-    )
   push, swap, pop, swap, 0 # !if drop, do ; then swap, drop, do ;
t: ifTrue   (  fq-    ) ' empty # if ;
t: ifFalse  (  fq-    ) ' empty # swap, if ;
t: dip      (  nq-n   ) swap, push, do pop, ;
t: sip      (  nq-n   ) over ' do # dip ;

( Conditionals ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: =    ( xy-f  ) =if -1 # ; then 0 # ;
t: <>   ( xy-f  ) !if -1 # ; then 0 # ;
t: >=   ( xy-f  ) >if -1 # ; then 0 # ;
t: <=   ( xy-f  ) <if -1 # ; then 0 # ;
t: <    ( xy-f  ) >if  0 # ; then -1 # ;
t: >    ( xy-f  ) <if  0 # ; then -1 # ;

( Strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: compare  ( $$-f )
   repeat
     dup, @, push, 1+, swap,
     dup, @, push, 1+, pop, dup, pop,
     !if drop, drop, dup, xor, ; then
   0 # 12 m, m,
   drop, drop, -1 # ;
t: count       ( a-a ) repeat @+ 0; drop, again ;
t: getLength   ( a-n ) dup, count 1-, swap, -, ;
t: withLength  ( a-an ) dup, getLength ;
t: keepString  ( a-a ) withLength 3 # +, here +, 8 # , , here swap, $ ;

( Numbers [Parsing & Display] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
4 elements #value num negate? flag
10 variable: base
label: numbers "0123456789ABCDEF" $,

t: nums     ( -a ) numbers # ;
t: (digits) nums +, @, over =if num # on then ;
t: digits   1- repeat dup, push, (digits) pop, 0; 1- again ;
t: valid?   base # @, dup, 16 # <if digits ; then drop, ;
t: digit?   num # off valid? drop, num # @, ;
t: toDigit  ( c-n ) '0 # -, base # @, 16 # =if dup, 16 # >if 7 # -, then then ;
t: isNegative? ( a-a )
   dup, @, '- # =if -1 # negate? # !, 1+, ; then 1 # negate? # !, ;
t: (convert)
   repeat
     dup, @, 0; toDigit #value # @, base # @, *, +, #value # !, 1+,
   again ;
t: toNumber ( $-n )
   isNegative? 0 # #value # !, (convert) drop, #value # @, negate? # @, *, ;
t: (isnumber)
   repeat dup, @, 0; digit? flag # @, and, flag # !, 1+, again ;
t: isNumber? ( $-f ) isNegative? flag # on (isnumber) drop, flag # @, ;

( Startup ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
6 elements memory fb fw fh cw ch

t: boot         (  -  )
   copytag # puts 32 # putc version # puts
   32 # putc 40 # putc build # puts 41 # putc cr ;
t: query        ( n-n ) 5 # out, wait 5 # in, ;
t: run-on-boot  (  -  )
   -1  # query memory # !,  ( Memory Size     )
   -2  # query fb #     !,  ( Canvas Present? )
   -3  # query fw #     !,  ( Canvas Width    )
   -4  # query fh #     !,  ( Canvas Height   )
   -11 # query cw #     !,  ( Console Width   )
   -12 # query ch #     !,  ( Console Height  )
   boot ;

( Dictionary Search ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
2 elements name found
t: prepare  ( a-a  ) found # off name # !, last # @, ;
t: done     (  -af ) which # @, found # @, ;
t: match?   ( $-$f ) dup, d->name name # @, compare ;
t: <search> ( $-   )
   repeat match? 0 # !if which # !, found # on ; then @ 0; again ;
t: find     ( $-af ) prepare <search> done ;
t: t-'      ( "-a  ) 32 # accept tib find 0 # !if d->xt @, ; then drop, 0 # ;

( Word Prefixes and "Not Found" ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
label: ___   "___" $,
t: get      ( $-$  ) dup, @, ___ # 2 # +, !, 1+, ;
t: xt:class ( d-aa ) dup, d->xt @, swap, d->class @, ;
t: try      (  -   )
   tib get find 0 #
   !if d->xt @, ___ # find
      0 # !if xt:class withClass 0 # ; then drop,
   then drop, -1 # ;
t: <notFound> ( -f ) tib getLength 2 # >if try then ;
t: notFound   ( -  ) <notFound> 0; drop cr tib puts 32 # putc '? # putc cr ;

( Listener ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: ok      (   - ) compiler # @, not 0; drop, cr okmsg # puts ;
t: word    (  d- ) xt:class jump: withClass
t: build#  (   - ) tib toNumber ' .data # withClass ;
t: number  (   - ) tib isNumber? 0 # !if build# ; then notFound ;
t: process ( af- ) 0 # !if word ; then drop number ;
t: listen  (   - ) repeat ok 32 # accept tib find process again ;

( Initial Dictionary ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
' 1+           prim: 1+            ' 1-           prim: 1-
' swap         prim: swap          ' drop         prim: drop
' and          prim: and           ' or           prim: or
' xor          prim: xor           ' @            prim: @
' !            prim: !             ' +            prim: +
' -            prim: -             ' *            prim: *
' /mod         prim: /mod          ' <<           prim: <<
' >>           prim: >>            ' tib          word: tib
' dup          prim: dup           ' in           prim: in
' out          prim: out           ' accept       word: accept
' here         word: here          ' ,            word: ,
' create       word: create        ' ]]           word: ]]
' :            word: :             ' header       word: header
' cr           word: cr            ' putc         word: putc
' remapKeys    word: remapKeys     ' <puts>       word: <puts>
' over         word: over
' not          word: not           ' on           word: on
' off          word: off           ' /            word: /
' mod          word: mod           ' negate       word: negate
' do           word: do            ' nums         word: numbers
' wait         word: wait          ' t-'          word: '
' @+           word: @+            ' !+           word: !+
' keepString   word: keepString    ' getLength    word: getLength
' withLength   word: withLength    ' withClass    word: withClass
' .word        word: .word         ' .macro       word: .macro
' .data        word: .data         ' .primitive   word: .primitive
' d->class     word: d->class      ' d->xt        word: d->xt
' d->name      word: d->name       ' boot         word: boot
' toNumber     word: toNumber      ' isNumber?    word: isNumber?
' ok           word: ok            ' listen       word: listen
' getc         word: getc          ' find         word: find
' notFound     word: notFound      ' <notFound>   word: <notFound>
' puts         word: puts          ' compare      word: compare
' redraw       word: redraw        ' if           word: if
' ifTrue       word: ifTrue        ' ifFalse      word: ifFalse
' dip          word: dip           ' sip          word: sip
' =            word: =             ' <>           word: <>
' <            word: <             ' >            word: >
' <=           word: <=            ' >=           word: >=

' t-;          macro: ;            ' ;;           macro: ;;
' t-=if        macro: =if          ' t->if        macro: >if
' t-<if        macro: <if          ' t-!if        macro: !if
' t-then       macro: then         ' t-repeat     macro: repeat
' t-again      macro: again        ' t-0;         macro: 0;
' push         macro: push         ' pop          macro: pop
' [            macro: [            ' ]            macro: ]
' t-(          macro: (            ' [[           macro: [[

  last         data: last          compiler     data: compiler
  fb           data: fb            fw           data: fw
  fh           data: fh            memory       data: memory
  cw           data: cw            ch           data: ch
  heap         data: heap          which        data: which
  remapping    data: remapping     eatLeading?  data: eatLeading?
  base         data: base          update       data: update
  version      data: version       build        data: build
  tabAsWhitespace data: tabAsWhitespace
patch

( Finish Metacompiled Part ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
main: run-on-boot jump: listen
endKernel bootNew


( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Ok, at this point the new image should be in control so we have a normal,   )
( though brutally minimal Retro system from here on.                          )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )


( Stack Words ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: nip   (  xy-y    ) swap drop ;
: rot   ( xyz-yzx  ) push swap pop swap ;
: tuck  (  xy-yxy  ) swap over ;
: +!    (  na-     ) dup push @ + pop ! ;
: -!    (  na-     ) dup push @ swap - pop ! ;
: ++    (   a-     ) 1 swap +! ;
: --    (   a-     ) 1 swap -! ;

( Scope ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
create list  ( -a )  0 , 0 ,
: {{ ( - )  last @ dup list ! list 1+ ! ;
: ---reveal--- ( - ) last @ list 1+ ! ;
: }} ( - )
  list @ list 1+ @ =if list @ last ! ;; then
  list @ [ last repeat @ dup @ list 1+ @ =if ;; then again ] do ! ;

( Vectored Execution ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: :devector ( a-  ) dup 0 swap ! 1+ 0 swap ! ;
: :is       ( aa- ) dup 8 swap ! 1+ ! ;
: devector  ( "-  ) ' 0; :devector ;
: is        ( a"- ) ' 0; :is ;
: default:  ( "-  ) ' 2 + , ; ' .macro last @ d->class !

( Dictionary ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  create a 0 , create b 0 , create c 0 , create xt 0 ,
  : skim       ( a-a )
    last repeat @ over over d->xt @ =if nip ;; then 0; again ;
  : getHeaders ( $-  )
    xt ! 0 a ! 0 b ! 0 c !
    last repeat @ 0; dup d->xt @ xt @ =if dup b ! @ a ! ;; then dup c ! again ;
  : <hide>     ( a-  ) getHeaders b @ 0; drop a @ c @ ! ;
---reveal---
  : d'         ( "-a ) ' drop which @ ;
  : xt->d      ( a-d || a-0 ) dup skim over over = [ - ] [ nip ] if ;
  : :hide      ( a-  )
    dup xt->d last @ = [ drop last @ @ last ! ] [ <hide> ] if ;
  : hide       ( "-  ) ' 0; :hide ;
}}
hide list
: reclass      (  a- ) last @ d->class ! ;
: reclass:     ( a"- ) d' d->class ! ;

( Initial Prefixes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  : xt:class ( a-aa ) dup xt->d 0; d->class @ withClass ;
---reveal---
  : __&  ( a-a ) .data                  ; &.macro reclass
  : __@  ( a-n ) xt:class &@  xt:class  ; &.macro reclass
  : __!  ( na- ) xt:class &!  xt:class  ; &.macro reclass
  : __+  ( na- ) xt:class &+! .word     ; &.macro reclass
  : __-  ( na- ) xt:class &-! .word     ; &.macro reclass
  : __2  ( a-  ) &xt:class sip xt:class ; &.macro reclass
}}

( Classes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: .compiler    (  a- ) @compiler &do &drop if ;
: immediate    (   - ) &.macro reclass ;
: compile-only (  "- ) &.compiler reclass ;

( Remap some classes for efficiency and safety ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
here
{{
  : c: ( "- ) &.compiler reclass: ;
  c: pop    c: push   c: 0;     c: ;;    c: ;      c: repeat c: again
}}
!heap

( Compiler Macros ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: `     ( "-  )
  ' dup 0 !if .data @which @d->class , ;; then
  drop tib isNumber? -1
  =if tib toNumber .data &.data , ;; then
  notFound ; compile-only
: jump: ( "- ) ' 0; 8 , , ; compile-only

( Additional Combinators ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: []      (    -    ) ` [ ` ] ; immediate
: while   (   q-    ) [ repeat dup dip swap 0; drop again ] do drop ;
: curry   (  nq-q   ) [ [ ` [ ] dip .data ] dip , ` ] ;
: take    (  qq-q   ) swap [ [ ` [ ] dip , ] dip .data ` ] ;
: bi      (  xqq-   ) &sip dip do ;
: bi*     ( xyqq-   ) &dip dip do ;
: bi@     (  xyq-   ) dup bi* ;
: tri     ( xqqq-   ) [ &sip dip sip ] dip do ;
: tri*    ( xyzqqq- ) [ [ swap &dip dip ] 2dip ] dip do ;
: tri@    ( xyzq-   ) 2dup tri* ;
: cons    (  ab-q   ) 2push ` [ 2pop &.data bi@ ` ] ;
: preserve ( aq-    ) swap &@ sip [ &do dip ] dip ! ;
: when    (  nqq-n  )
  [ over swap do ] dip swap
  [ do -1 ] [ drop 0 ] if 0; pop 2drop ;
: whend   ( nqq-? )
  [ over swap do ] dip swap
  [ nip do -1 ] [ drop 0 ] if 0; pop 2drop ;

{{
  : for   ( R: n-  C: -a ) here ` push ; compile-only
  : next  ( R: -   C: a- ) ` pop 7 , , ; compile-only
  : i 2pop pop 2over 2push swap - swap push ;
  : tors  (    -n ) ` pop ` dup ` push ; compile-only
---reveal---
  : times (  nq-  )
    over 1 >= [ swap for dup dip next drop ] [ 2drop ] if ;
  : iterd (  nq-  )
    over 1 >= [ swap for tors swap dup dip next drop ] [ 2drop ] if ;
  : iter  (  nq-  )
    over 1 >= [ swap dup push for i swap dup dip next pop 2drop ] [ 2drop ] if ;
}}

{{
  : <each> (  qa- ) [ dup [ swap dup &do dip ] dip 1+ ] times 2drop ;
  : array  (  aq- ) swap @+ dup 1 > [ <each> ] [ 2drop ] if ;
  : buffer ( anq- ) 2rot <each> ;
  : list   (  lq- ) [ &@ dip 2over [ [ do ] dip ] dip over @ ] while 2drop ;
---reveal---
  : <each@> ( ...t- ) drop ;
  : each@   ( ...t- )
    [ 0  ( ARRAY  ) = ] [ array                  ] whend
    [ 1  ( BUFFER ) = ] [ buffer                 ] whend
    [ 2  ( STRING ) = ] [ &withLength dip buffer ] whend
    [ 3  ( LIST   ) = ] [ list                   ] whend
    <each@> ;
}}

( Memory Blocks ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: copy   ( aan-  ) [ &@+ dip !+ ] times 2drop ;
: fill   ( ann-  ) swap !here [ @here swap !+ ] times drop ;

( Conditionals ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: ahead  (   -a  ) 8 , here 0 , ;
: if;    (  f-   ) ` not ` 0; ` drop ; compile-only
: within ( xlu-f ) &over dip <= &>= dip and ;

( Data Structures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: variable:  ( n"-  ) create , ;
: variable   (  "-  ) 0 variable: ;
: constant   ( n"-  ) create @last !d->xt ;
: allot      (  n-  ) dup 0 < [ +heap ] [ repeat 0; 1- 0 , again ] if ;
{{
  : list     (  n-a ) here swap allot ;
  : element  (  a-a ) create dup @last !d->xt 1+ ;
---reveal---
  : elements ( n"-  ) dup list swap &element times drop ;
}}

( Numbers and Math ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: decimal ( - ) 10 !base ;
: hex     ( - ) 16 !base ;
: octal   ( - )  8 !base ;
: binary  ( - )  2 !base ;

( Output ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  create buf   32 allot
  2 elements digits pos
  : split    (   n-... )
    repeat @base /mod swap numbers + @ swap digits ++ 0; again ;
  : build    ( ...-    )
    buf @pos [ @pos swap !+ ] ifTrue
    @digits [ !+ ] times 0 swap ! ;
  : negate?  (   n-n   ) dup 0 >= if; negate 45 !pos ;
---reveal---
  : toString (   n-$   ) 0 [ !pos ] [ !digits ] bi negate? split build buf ;
}}
: clear (  - ) -1 putc ;
: space (  - ) 32 putc ;
: putn  ( n- ) toString puts ;

( Parsing prefixes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: .parse  (  a- ) do ;
: parsing (   - ) &.parse reclass ;
{{
  : number ( a- ) base [ do toNumber .data ] preserve ;
---reveal---
  : __$   ( $-n ) &hex     number ; parsing
  : __#   ( $-n ) &decimal number ; parsing
  : __%   ( $-n ) &binary  number ; parsing
  : __'   ( $-n ) @ .data         ; parsing
}}

( Chained Vocabularies ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
create dicts 64 allot
{{
  2 elements active prior
  create "|" 124 ,  0 ,
  create "%%" 37 , 37 , 0 ,
  : seal   (  - ) last repeat @ 0; @active over @ =if 0 swap ! ;; then again ;
  : revert (  - ) @prior 0; !last 0 !prior ;
  : safety (  - ) "%%" header immediate &revert @last !d->xt ;
---reveal---
  : %%     (  - ) revert ;
  : <%>    ( a- ) @last !prior !last ;
  : .chain ( a- ) @dicts &drop &<%> if ;
  : chain: ( "- ) create 0 , &.chain reclass @last !active safety ;
  : ;chain (  - ) seal @last @active [ !last ] [ !d->xt ] bi ;
  : :with  ( a- ) 0; @dicts 1+ dicts + ! dicts ++ ;
  : with   ( "- ) ' :with ;
  : without ( - ) @dicts 0; 1- !dicts ;
  : global  ( - ) 0 !dicts ;
  : findInChain ( $a-df ) :with find without ;
  : with|  ( "- )
    global
    repeat
      32 accept tib "|" compare if;
      tib find [ @d->xt :with ] &drop if
    again ;
}}

: rename: ( a"- )
  create dup xt->d swap :hide
  [ @d->xt @last !d->xt ] [ @d->class @last !d->class ] bi ;

( Extend 'find' and 'xt->d' to search chains before global ~~~~~~~~~~~~~~~~~~ )
{{
  5 elements flag dt name safety xt
  : search  (  -   ) @dicts repeat 0; dup dicts + <%> @xt do 1- again ;
  : (chains ( $-   ) !name 0 [ !dt ] [ !flag ] bi @last !safety ;
  : back)   (   -  ) @safety !last ;
  : seek    ( na-n ) @name default: find [ !dt flag on drop 1 ] &drop if ;
  : lookup  ( $-af )
    &seek !xt (chains search back)
    @flag [ @dt @flag ] [ @name default: find ] if ;
  &lookup is find

  : seek    (   -  )
    @name default: xt->d dup [ !dt flag on drop 1 ] &drop if ;
  : lookup  (  a-d )
    &seek !xt (chains search back)
    @flag [ @dt ] [ @name default: xt->d ] if ;
  &lookup is xt->d
}}

( Extend Prefix Handler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  4 elements xt class name flag
  create ___ 95 , 95 , 95 , 0 ,

  ( Split Token into Prefix and Name ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
  : action   (  -   ) @xt @class withClass ;
  : (split   (  -a  ) @+ ___ tuck 1+ 1+ ! swap !name ;
  : prefix)  ( $-f  )
    find [ [ @d->class !class ] [ @d->xt !xt ] bi -1 ] [ 0 ] if ;

  ( Prefix Handling ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
  : handle   (  -   )
    @class &.parse =
    [ flag off @name action ]
    [ @name find [ @d->xt action flag off ] &drop if ]
    if ;

  ( Main Wrapper ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
  : try      (  -   )
    flag on tib (split prefix) [ handle ] &drop if @flag ;
  &try is <notFound>
}}

( Core Strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
  : buffers ( -a ) 2048 here + ;
  variable next
---reveal---
  : tempString ( $-$ )
    withLength 1+
    @next 12 = [ 0 !next ] ifTrue
    @next 512 * buffers + [ swap copy ] sip
    next ++ ;
}}

{{
  variable end
  : pad     (  -a ) 1024 here + ;
  : keep    (  -  ) @compiler &keepString &tempString if .data ;
  : >pad    ( $-$ ) pad over getLength 1+ copy pad keep ;
  : chop    ( $-$ ) end -- 0 @end ! ;
  : >$      ( n-  ) dup 8 = [ chop drop ] [ @end !+ !end ] if ;
  : end?    ( $-$ ) @end @1- '" = [ chop >pad -1 ] [ 0 ] if ;
  : noEat   ( q-  ) eatLeading? off do eatLeading? on ;
  : withPad ( q-  ) 32 pad 1- ! &pad &tib :is noEat &tib :devector ;
  : get     (  -c ) getc dup putc ;
---reveal---
  : __"  ( "-a )
    dup withLength + !end
    end? [ 32 >$ [ end? [ 0 ] [ get >$ -1 ] if ] while ] ifFalse ; parsing
  : "    ( "-$ ) [ '" accept pad 1- keep ] withPad ; immediate
}}

( Formatted String Display ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
-1 variable: formatted
{{
  : withBase ( n$q-$ ) [ swap ] dip base [ do ] preserve ;
  : char ( $-$ )
    @+ [ 'n = ] [ cr      ] whend
       [ '' = ] [ '" putc ] whend
       [ '[ = ] [ 27 putc putc ] when
    putc ;
  : obj  ( $-$ )
    @+ [ 'd = ] [ [ decimal putn ] withBase ] whend
       [ 'o = ] [ [ octal   putn ] withBase ] whend
       [ 'x = ] [ [ hex     putn ] withBase ] whend
       [ 'c = ] [ swap putc                 ] whend
       [ 's = ] [ formatted off &puts dip formatted on ] whend
       putc ;
  : complex ( $-n )
    repeat
      @+ 0;
      dup '\ = [ drop char 0 ] ifTrue
      dup '% = [ drop obj  0 ] ifTrue
      putc
    again ;
  : simple ( $- ) [ @ putc ] 2 ( STRING ) each@ ;
  : defer  ( q- ) update off do update on redraw ;
  [ [ @formatted [ complex drop ] &simple if ] defer ] is <puts>
}}

( Debugging ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: depth   (    -n ) -5 5 out wait 5 in ;
: reset   ( ...-  ) depth repeat 0; 1- nip again ;
: .s      (    -  )
  depth [ "\n<%d> " puts ] sip 0;
  heap  [ [ here 1+ ;; [[ 128 allot  ]] ] do !heap
          dup [ swap , ] times
              [ here 1- @ dup putn space -1 allot ] times ] preserve ;

{{
  : list    ( a-  ) [ d->name puts space ] 3 ( LIST ) each@ ;
  : others  (  -  ) @dicts repeat 0; cr dup dicts + list 1- again ;
---reveal---
  : words   (  -  ) cr formatted dup [ off others cr last list ] preserve ;
}}

( Misc. Words ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: save     (  -  ) 1 4 out wait ;
: bye      (  -  ) cr -9 5 out wait ;
: getToken ( "-$ ) 32 accept tib tempString ;
: :include ( $-  ) 2 4 out wait ;
: include  ( "-  ) getToken :include ;
: time     (  -n ) -8 5 out wait 5 in ;
: delay    ( n-  ) time + [ dup time > ] while drop ;
: getEnv   ( a$- ) -10 5 out wait ;
: later    (  -  ) 2pop swap 2push ;
: doc{     ( "-  ) repeat getToken "}doc" compare if; again ;
: variables|  ( "- )
  repeat getToken "|" compare if; tib header 0 , again ;

( Math Operations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: pow  ( bp-n ) 1 swap [ over * ] times nip ;
: abs  (  n-n ) dup 0 < &negate ifTrue ;
: min  ( ab-c ) 2over < &drop &nip  if ;
: max  ( ab-c ) 2over < &nip  &drop if ;
{{
  variables| w z |
  : seeds?   ( -  ) @w @z and ;
  : seed     ( -  ) time [ 62903 and !w ] [ 78578 and !z ] bi ;
  : ?seed    ( -  ) repeat seeds? 0 <> if; seed again ;
  : (random) ( -x )
    36969 z @ 65535 and * @z 16 >> + !z
    18000 w @ 65535 and * @w 16 >> + !w
    @z 16 << @w + ;
---reveal---
  : random     (  -x ) ?seed (random) abs ;
}}

( Generic Buffer ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
global
chain: buffer'
{{
  variables| buffer ptr |
  : terminate (  -  ) 0 @ptr ! ;
---reveal---
  : start     (  -a ) @buffer  ;
  : end       (  -a ) @ptr     ;
  : add       ( c-  ) end ! ptr ++ terminate ;
  : get       (  -c ) ptr -- end @ terminate ;
  : empty     (  -  ) start !ptr   terminate ;
  : size      (  -n ) end start -   ;
  : set       ( a-  ) !buffer empty ;
}}
;chain

( Text Strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
with buffer'
chain: strings'
{{
  variables| len needle haystack flag right left src |
  : buffer (  -a ) here 8192 + ;
  : trim   ( $-$ )
    dup withLength + 1- dup @ 32 =if 0 swap ! dup 1- -- trim ;; then drop ;
  : place  ( $$n- ) [ copy 0 ] sip here + ! ;
  : prep   (  $$- ) swap !haystack [ getLength !len ] [ !needle ] bi 0 !flag ;
  : move   (    - ) @haystack here @len place haystack ++ ;
  : cmp    (    - )
    @flag 0 <> if; @needle here compare [ @haystack 1- !flag ] ifTrue ;
---reveal---
  : search   ( $$-f )
    flag off prep @haystack getLength [ move cmp ] times @flag ;
  : findChar ( $c-a )
    !needle
    repeat @+
      dup 0   =if 2drop 0 ;; then
      @needle =if 1-      ;; then
    again ;
  : chop      ( $-$ ) tempString withLength over + 1- 0 swap ! ;
  : getSubset ( $nn-$ )
    buffer 0 1024 fill
    !right !left !src
    @src @left + @right buffer swap copy buffer tempString ;
  : trimLeft  ( $-$ ) [ @+ [ 32 = ] [ 0 <> ] bi = ] while 1- ;
  : trimRight ( $-$ )
    buffer [ 0 1024 fill ] [ over getLength copy ] [ trim ] tri tempString ;
  : prepend ( $$-$ )
    buffer 0 1024 fill
    withLength buffer swap dup &copy dip
    &withLength dip buffer + swap copy buffer tempString ;
  : append ( $$-$ ) swap prepend ;
  : appendChar ( $c-$ ) swap tempString [ withLength + !+ 0 swap ! ] sip ;
  : toLower ( $-$ )
    withLength 1+
    [ buffer + [ @+ dup 'A 'Z within [ 'a + 'A - ] ifTrue ] dip ! ] iter
    drop buffer tempString ;
  : toUpper ( $-$ )
    withLength 1+
    [ buffer + [ @+ dup 'a 'z within [ 'A + 'a - ] ifTrue ] dip ! ] iter
    drop buffer tempString ;
}}
  : reverse ( $-$ )
    dup tempString set
    [ getLength ] [ withLength + 1- ] bi swap
    [ dup @ add 1- ] times drop
    start tempString ;
  : split ( $n-$$ )
    2over 0 swap getSubset [ + ] dip ;
  : splitAtChar ( $c-$$ )
    2over over swap findChar over - 1+ 0 swap getSubset [ findChar 1+ ] dip ;
  : splitAtChar: ( $"-$$ )
    32 accept tib @ .data ` splitAtChar ; immediate
;chain
without

( Access Words Within Chains Directly ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
with strings'
: __^  ( "- )
  splitAtChar: ' find
  [ @d->xt findInChain [ [ @d->xt ] [ @d->class ] bi do ] &drop if ]
  &drop if ; parsing

: needs  ( "- )
  getToken dup find nip
  &drop [ "library/" prepend chop ".rx" append :include ] if ;
without

( Files ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
chain: files'
{{
  variables| fid fsize active |
  : io     (  n-f )  4 out wait 4 in ;
  : done   ( nn-  )  2drop active off ;
---reveal---
  0 constant :R
  1 constant :W
  2 constant :A
  3 constant :M
  : open   (  $m-h ) -1 io ;
  : read   (   h-f ) -2 io ;
  : write  (  ch-f ) -3 io ;
  : close  (   h-f ) -4 io ;
  : pos    (   h-n ) -5 io ;
  : seek   (  nh-f ) -6 io ;
  : size   (   h-n ) -7 io ;
  : delete (   $-n ) -8 io ;
  : slurp  (  a$-n )
    :R open !fid
    @fid size !fsize
    @fsize [ @fid read swap !+ ] times 0 swap !
    @fid close drop @fsize ;
  : spew   (  an$-n )
    :W open !fid 0 !fsize
    [ @+ @fid write drop fsize ++ ] times drop
    @fid close drop @fsize ;
  : readLine ( h-a )
    active on
    tib [ over read dup 10 13 within
          [ drop 0 swap ! drop active off ] [ swap !+ ] if @active ] while
    tib tempString ;
  : writeLine ( $h- )
    !fid active on
    [ @+ dup 0 = &done [ @fid write drop ] if @active ] while
    10 @fid write drop ;
}}
;chain

( types' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
chain: types'
  0 constant ARRAY  ( -n )
  1 constant BUFFER ( -n )
  2 constant STRING ( -n )
  3 constant LIST   ( -n )
;chain

( cleanup ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
hide =if
hide !if
hide >if
hide <if
hide then

global .s save bye