swapforth.fa

\ The definition starts with "CODE" and the word name
\
\ Every definition should call DORETURN - this
\ should appear early for maximum overlap.
\
\ Definitions the only use port-execution are
\ shortest - they have only a prefix.
\
\ Definitions that need labels (i.e. "if" and
\ "next" targets) will actually be loaded into node
\ RAM.  The load pump leaves A on the stack, so in
\ this case the prefix must start with "a!". The
\ jump/call from the prefix into RAM is explicit,
\ e.g. "jump main". So a common pattern is:
\
\     CODE fancyword
\       a! call DORETURN
\       call main
\
\     : main
\       ...
\       ;
\
\ Permanent subroutines (see nt.ga for source):
\   -!        push T onto the D stack
\   LIT       push literal, usage "@p call LIT"
\   GO        tell R to request next fragment T
\   DORETURN  tell R to request next fragment from R stack
\   TO_R      push T on R
\
\ Do this to run:
\
\   python fa.py swapforth.fa           # assemble this file into "image", listing "lst"
\   python flash.py $PORT write image   # write "image" to flash
\   python asm.py $PORT nt.ga           # bootstrap, dump results of running "boot" word
\

CODE >r
  @p !b @b
    @+ !p
  over call TO_R
  @+ over
  call GO

CODE r@
  call -!
  @p !b @b
    @+ !p
  @p !b @b
    @ !p
  over call GO

CODE r>
  call -!
  @p !b @b
    @+ !p
  @p !b @b
    @+ !p
  over call GO

CODE 2>r
  @p !b @b
    @+ !p
  @+ call TO_R
  over call TO_R
  @+ over
  call GO

CODE 2r>
  @p !b @b
    @+ !p
  push
  call -!
  @p !b @b
    @+ !p
  call -!
  @p !b @b
    @+ !p
  @ over !
  pop call GO

CODE true           #returns #inline
  call -!
  @p
    -1

CODE false          #returns #inline
  call -!
  dup or

CODE 1+             #returns #inline
  @p . +
    1

CODE 1-             #returns #inline
  @p . +
    -1

CODE negate         #returns #inline
  - @p . +
    1

CODE abs            #returns #inline
  dup call 18shr    \ x m
  over over . +     \ x m x+m
  or                \ x (x+m)^m

CODE invert         #returns #inline
  -

CODE 2*             #returns #inline
  2*

CODE 2/             #returns #inline
  2/

CODE emit
  call DORETURN
  a over @p
    EAST
  a! @p !
   1
  ! a! @+

CODE wait
  call -!
  a @p a! @p
    EAST
    3
  ! @
 over a!
 call DORETURN

CODE sleep
  a @p a! @p
    EAST
    2
  !
  over ! @
  drop a! @+
 call DORETURN

CODE read-buttons
  call -!
  a @p a! @p
    EAST
    4
  ! @
 over a!
 call DORETURN

CODE joyy
  a @p a! @p
    EAST
    5
  ! over !
  @ over a!
  call DORETURN

CODE +              #returns #inline
  @+ . +

CODE -              #returns #inline
  @+ - . +
  -

CODE and            #returns #inline
  @+ and

CODE or             #returns #inline
  @+ over -
  and or

CODE xor            #returns #inline
  @+ or

CODE lshift         #returns
  a!  push @+
  next lshift
: lshift
  2* unext
  jump NORTH

CODE rshift         #returns
  a!
  call NORTH          \ so body code can use ';'
  push @+
  next main
: main
  -if pos
  2/ @p and
    0x1ffff
  next pos
  ;
: pos
  2/ unext ;

CODE *              #returns #inline
  @+
  a push a!
  @p @p push
    0
    17
  +* unext a
  pop a!

CODE um*
  a! call DORETURN
  @ a push
  call main
  pop a! !
: main
  over a! @p @p
    0
    8
  push
  +* . +* unext 
  push -if L1
  drop pop . +
  a ;
: L1
  drop drop pop
  a ;

CODE m*
  @ call DORETURN
  a push dup
  call 18shr
  push a! dup dup
  or @p push
    8
  +* . +* unext
  - over pop
  and . +
  - a pop
  a! !

CODE um/mod
  - @p . +
    1
  push call DORETURN
  @+ @ pop
  a push
  call --u/mod
  pop a!
  over !

CODE execute
  @+ over
  call GO

CODE rot            #returns #inline
  a push
  @ over !+
  @ over !
  pop a!

CODE drop           #returns #inline
  @+

CODE 2drop          #returns #inline
  @+ @+

CODE nip            #returns #inline
  @+ drop

CODE tuck           #returns #inline
  @ over dup
  ! over
  call -!

CODE dup            #returns #inline
  dup call -!

CODE over           #returns #inline
  @ over
  call -!

CODE swap           #returns #inline
  @ over !

CODE snap
  a! jump main
: main
  a over @p
    EAST
  a! @p !
   1
  ! a! @+
  jump main

CODE 0<>            #returns #inline
  dup
  - @p . +
    1
  or call 18shr

CODE 0=             #returns #inline
  dup @p . +
    -1
  over - and
  call 18shr

CODE 0<             #returns #inline
  call 18shr

CODE <>             #returns #inline
  @+ or dup
  - @p . +
    1
  or call 18shr

CODE =              #returns #inline
  @+ or
  dup @p . +
    -1
  over - and
  call 18shr

CODE depth          #returns #inline
  call -!
  a
  - @p . +
    STACKTOP

CODE <              #returns #inline
  @+ over over
  or - 2/
  push - and
  pop . +
  - call 18shr

CODE >              #returns #inline
  push @+ pop
  over over or
  - 2/ push
  - and pop .
  + -
  call 18shr

CODE u<             #returns #inline
  @+
  over over or
  dup push
  - 2/ push
  - and pop .
  + - pop
  or call 18shr

CODE u>             #returns #inline
  @+ over over
  over or dup
  push - 2/
  push - and
  pop . +
  - pop or
  call 18shr

CODE d+             #returns #inline
  call 0x200|NORTH
  call clc
  @+ @+               
  a push @           ( ah al bh bl )

  a! push a .
  + a! pop .
  + a

  pop a! ! ;

CODE pick          #returns #inline
  a dup push +
  a! @ pop
  a!   

CODE ni
  call DORETURN
  call -!
  pop dup push
  
\ : sgn ( u1 n1 -- n2 ) \ n2 is u1 with the sign of n1
CODE sgn            #returns #inline
  @p and @+ @p
    0x20000
    0x1ffff
  and or

\ ====================================================
\ external RAM
\ ====================================================

CODE @              #inline #returns
  a
  push @p a! @p
    SOUTH
    call 506.@
  ! ! @
  pop a!

CODE !              #inline #returns
  @+
  a push @p
    SOUTH
  a! over @p
    call 506.!
  ! ! !
  pop a! @+

CODE c@
  a call DORETURN
  push @p a! @p
    SOUTH
    call 506.c@
  ! ! @
  pop a!

CODE erase               #inline #returns
  @+ a push @p
    SOUTH
  a! over @p
    call 506.erase
  ! ! !
  pop a! @+

\ ====================================================
\ display control
\ ====================================================
CODE g-new
  @p @p !b    \set a
     EAST     \west in 605
     a @p a!
  !b dup dup
  or @p !b    \send 0
     @p !
  !b @p !b    \send arg1
     @p ! @p
  !b @+ !b @p \send arg2
     ! @ !p   \read return val
  !b @b @p    \reset a
     a!
  !b
  call DORETURN

CODE g-del
  @p @p !b
     EAST
     a @p a!
  !b @p !b @p
     @p !
     3
  !b @p !b
    @p !
  !b @+ @p
    a!
  !b
  call DORETURN

CODE redraw
  @p @p !b
     EAST
     a @p a!
  !b @p !b @p
     @p !
     5
  !b @p !b
     a!
  call DORETURN

CODE >604
  @p @p !b
     EAST
     a @p a!
  !b @p !b
     @p !
  !b @p !b
     a!
  @+ call DORETURN

\ ====================================================
\ flash reads
\ ====================================================

CODE @flash
   - call GO

%FORTHLIKE%

\ ====================================================
\ CORE words
\ ====================================================

: +!
  tuck @ + swap ! ;

: 2dup
  over over ;

: 0>
  dup 0< invert swap 0<> and ;

: -rot
  rot rot ;


: dnegate
    invert swap invert swap
    1. d+
;

: dabs
    dup 0< if dnegate then
;

: s>d   dup 0< ;
: d>s   drop ;

: d=                        \ a b c d -- f )
    rot =                   \ a c b=d
    >r = r>                 \ a=c b=d
    and
;

: d<            \ ( al ah bl bh -- flag )
    rot         \ al bl bh ah
    2dup =
    if
        2drop u<
    else
        > nip nip
    then
;

: du<           \ ( al ah bl bh -- flag )
    rot         \ al bl bh ah
    2dup =
    if
        2drop u<
    else
        u> nip nip
    then
;

: d-
    dnegate d+
;

: d0<
    nip 0<
;

: d0=
    or 0=
;

: d2*
    2dup d+
;

: d2/
    >r 1 rshift r@
    17 lshift
    or r> 2/
;

\ Divide d1 by n1, giving the symmetric quotient n3 and the remainder
\ n2.
: sm/rem ( d1 n1 -- n2 n3 )
    2dup xor >r     \ combined sign, for quotient
    over >r         \ sign of dividend, for remainder
    abs >r dabs r>
    um/mod          ( remainder quotient )
    swap r> sgn     \ apply to remainder
    swap r> sgn     \ apply to quotient
;

\ Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
\ Adapted from hForth
: fm/mod ( d1 n1 -- n2 n3 )
    dup >r 2dup xor >r
    >r dabs r@ abs
    um/mod
    r> 0< if
        swap negate swap
    then
    r> 0< if
        negate         \ negative quotient
        over if
            r@ rot - swap 1-
        then
    then
    r> drop
;

: */mod     >r m* r> sm/rem ;
: */        */mod nip ;

: /mod      >r s>d r> sm/rem ;
: /         /mod nip ;
: mod       >r s>d r> sm/rem drop ;

\ From Wil Baden's "FPH Popular Extensions"
\ http://www.wilbaden.com/neil_bawd/fphpop.txt

: tnegate                           ( t . . -- -t . . )
    >r  2dup or dup if drop  dnegate 1  then
    r> +  negate ;

: t*                                ( d . n -- t . . )
                                    ( d0 d1 n)
    2dup xor >r                     ( r: sign)
    >r dabs r> abs
    2>r                             ( d0)( r: sign d1 n)
    r@ um* 0                        ( t0 d1 0)
    2r> um*                         ( t0 d1 0 d1*n .)( r: sign)
    d+                              ( t0 t1 t2)
    r> 0< if tnegate then ;

: t/                                ( t . . u -- d . )
                                    ( t0 t1 t2 u)
    over >r >r                      ( t0 t1 t2)( r: t2 u)
    dup 0< if tnegate then
    r@ um/mod                       ( t0 rem d1)
    rot rot                         ( d1 t0 rem)
    r> um/mod                       ( d1 rem' d0)( r: t2)
    nip swap                        ( d0 d1)
    r> 0< if dnegate then ;

: m*/  ( d . n u -- d . )
    >r t*  r> t/ ;

: bounds
  over + swap ;


\ ====================================================
\ display graphics

VARIABLE m1
VARIABLE m2
VARIABLE line

: {rect
\ |7b Y1|7b Y0|1000|    |1bfill|3b C|7b X1|7b X0|
0x8 m1 ! 0 m2 ! ;

: rect.x
7 lshift or m2 @ or m2 ! ;

: rect.y
7 lshift or
4 lshift
m1 @ or m1 ! ;

: rect.color
14 lshift m2 @ or m2 ! ;

: rect.fill
m2 @ 0x1ffff and m2 ! ;

: rect.nofill
m2 @ rect.fill 0x20000 or m2 ! ;

: end}
  m1 @ m2 @ g-new ;

: black 0 ;
: red 1 ;
: green 2 ;
: yellow 3 ;
: blue 4 ;
: purple 5 ;
: green 6 ;
: white 7 ;

: {update 4 >604
2 >604 ( reset )
;

: update} 0 >604 ;

: update-row ( row - )
 ( equivalent to:  set-row send-primitives end-row )
 3 lshift 3 or >604 ;

: set-row ( row - )
 3 lshift 4 or >604 ;

: end-row ( row - )
 1 + 3 lshift 5 or >604 ;

: send-primitives ( - )
 ( updates graphics for the current row )
 6 >604 ;

: pixel.color
 14 lshift m1 ! ;
: pixel.coord
 4 lshift m2 ! ;
: send-pixel
 0x20002 m1 @ or m2 @ or >604 ;
: pixel ( coord color - )
\  |1|3b color|000|7b coord|0010|
 14 lshift swap 4 lshift 0x20002 or or >604 ;

: black-pixel ( coord - )
 2* 2* 2* 2* 0x20002 or >604 ;

: {clear-display}
{update 7 >604 update} ;

: clear-display
 7 >604 ;

: _update-rows  \ equivalent to 'redraw'
{update
127 for
 128 i - update-row
next
update} ;

: _update-rows2  \ equivalent to 'redraw'
{update
127 for
 128 i - dup set-row send-primitives
 \    dup 50 > if
 \    green 50 pixel
 \    then
 end-row
next
update} ;


\ ====================================================
\ joystick
\ ====================================================

: joyy-calib 0 joyy drop ;
: joyy-sample 1 joyy ;
: joyy-delta 2 joyy ;

\ ====================================================
\ text
\ ====================================================

include(font.fs)

: @font 'f font-5x7 + @flash ;

variable line-buf
21 allot
variable line \ character line on the display
variable color \ pixel color
black @ color !

: render-text
\ render contents of `line-buff' at `line'
\ must be called from update mode
6 for \ y
  line @ 2* 2* 2* 6 I - + dup set-row send-primitives
  0 \ coord
  20 for \ char
    20 I - line-buf + @
    dup if
      7 * 6 J - +
      'f font-5x7 + @flash \ inlined @font   [coord font]
      \ 4 for \ x   unrolled loop
        dup
        0x20 and \ [coord font pixel?]
        if
          over
          2* 2* 2* 2* 0x20002 or >604 \ inlined black-pixel
        then
        2* swap 1+ swap
      \ next
        dup 0x20 and if over 2* 2* 2* 2* 0x20002 or >604 then 2* swap 1+ swap
        dup 0x20 and if over 2* 2* 2* 2* 0x20002 or >604 then 2* swap 1+ swap
        dup 0x20 and if over 2* 2* 2* 2* 0x20002 or >604 then 2* swap 1+ swap
        dup 0x20 and if over 2* 2* 2* 2* 0x20002 or >604 then
        drop \ font
        1+
    else
      drop 5 +
    then
    1+
  next
  drop \ coord
  end-row
next
;

: clear-line-buf
line-buf 21 erase ;

: show-line-buf
0 20 for
  dup line-buf + @ emit
  1 +
next ;

: erase-line ( line - )
\ clear text from LINE. Must be called from update mode
\ TODO: test
7 *
6 for
  dup I +
   dup set-row send-primitives end-row
  next
 drop ;

: emit-string ( ...string - )
 for emit next ;

VARIABLE cursor
: type ( string - )
for
  \cursor dup @ 1 + dup swap !
  cursor @ 1 + dup cursor ! line-buf + !
next ;

: cr
 line dup @ 1 + swap !
 0 cursor !
 clear-line-buf ;

: update-text
{update render-text update} ;

: reset-text
 0 line !
 0 cursor !
 clear-line-buf
 ;

: button0? 0x20000 and ;
: button1? 0x10000 and ;
: button2? 0x8000 and ;


VARIABLE second
VARIABLE minute
VARIABLE hour

variable 'button1
variable 'button2
variable 'time
: noop ;

: execute'button1 'button1 @ execute ;
: execute'button2 'button2 @ execute ;
: execute'time 'time @ execute ;

: event-loop
0
begin
 wait
 dup if
  dup button1? if execute'button1 then
      button2? if execute'button2 then
 else
  drop execute'time
 then
0 until
\ ' event-loop execute
; 

\ ====================================================
\ testing
\ ====================================================

: hex1
  15 and dup 10 u< if then
;

: memtest

  0x4142 256 !
  0x4443 0 !
  1 c@
  0 c@
  256 c@
  257 c@
;

: perf          \ Takes .266 s
  0xaaaa emit
  10000
  begin
    1- dup 0=
  until drop
  0xbbbb emit
;

: perf2
  0xaaaa emit
  1000 for 1000 for 0 drop next next
  0xbbbb emit
;

: bench
  50000 0 do
    i 7 mod drop
  loop ;

: doubles
  1 swap
  begin
    swap 2* swap
    1- dup 0=
  until
  drop
;

: fib ( u -- u )
  1 1 rot for
    tuck +
  next
  ;

VARIABLE second
VARIABLE minute
VARIABLE hour

VARIABLE t1

: update-clock-display
\ seconds
second @
10 t1 !

5 for
{rect
10 30 rect.x
t1 @ dup 15 + t1 !
dup 7 + rect.y

dup 1 and if
  rect.fill
else
  rect.nofill
then

1 rshift

red rect.color
end} drop ( id )
next
drop ( seconds )

\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\minutes

minute @
10 t1 !

5 for
{rect
40 60 rect.x
t1 @ dup 15 + t1 !
dup 7 + rect.y

dup 1 and if
  rect.fill
else
  rect.nofill
then

1 rshift

blue rect.color
end} drop ( id )
next
drop ( minutes )

\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\hours

hour @
10 t1 !

4 for
{rect
70 90 rect.x
t1 @ dup 15 + t1 !
dup 7 + rect.y

dup 1 and if
  rect.fill
else
  rect.nofill
then

1 rshift

purple rect.color
end} drop ( id )
next
drop ( hour )

redraw
1 16 for
dup g-del 2 +
next drop

;

: clock
111 222
1111 emit
0 hour !
0 minute !
0 second !

begin

second @ 1 + dup second !
60 = if
  minute @ 1 + dup minute !
  60 = if
    hour @ 1 + dup hour !
      24 = if
         0 hour !
    then
  0 minute !
  then

0 second !
then
update-clock-display
16 sleep
1 emit
0 until
;

: test-button1 1111 emit ;
: test-button2 2222 emit ;

: watch-main
' update-clock-display 'update-display !

 initial-hour hour !
 initial-min minute !
 initial-sec second !

' test-button1 'button1 !
' test-button2 'button2 !

' tick1s 'time !

event-loop
;

include(easter.fs)

: boot
  100 200 300
: sleeptest
0 begin
  1 + dup emit
  1 sleep
  0 until
 ;

: _show g-new redraw 4 sleep ;
: _del dup emit g-del redraw 4 sleep ;
: graphicstest
\ Animate the display of Mark's original image
begin
  260104 81792 _show
  131384 139283 _show
  129352 90004 _show
  260599 16896 _show
  503 49791 _show
  129527 33343 _show
  1111 emit
  _del _del _del _del  _del \_del
0 until
 ;


VARIABLE color
: colortest
0 color !
begin
{rect
  0 127 rect.y
  0 127 rect.x
  rect.fill
  color @ rect.color
 end}
 redraw
 2 sleep
 g-del
 color dup @ 1 + 7 and swap ! 
 0 until
;

  begin
    2dup <>
  while
    dup emit 1+
  repeat
: rectangletest2
begin
0 \ color
0 \ position
31 for
1111 emit
 {rect
    dup 127 over -
    over over
    rect.y rect.x
    2 +
    swap 1 + 7 and dup rect.color swap
    rect.fill
  end} drop
  redraw
  1 sleep
next drop drop
2222 emit
\ delete
1 30 for
dup g-del 2 +
redraw
 1 sleep
next drop

0 until
;


: helloworld
  {clear-display}
  clear-line-buf
  8 line !
  5 cursor !
  s" Hello World!" type
  update-text
;

: textdemo
 {clear-display}
 reset-text
 15 line !
 {update
  s" Monday October 23" type render-text cr
  s" 8:51pm" type render-text cr
 update} 
 ;

: test-shapes
  260104 81792 g-new
  131384 139283 g-new
  129352 90004 g-new
  260599 16896 g-new
;

: hellomark
{clear-display}
260599 16896 g-new
clear-line-buf
3 cursor !
s" Hello Mark " type
redraw
{update
 8 for
   I 2 * line !
   render-text
 next
update}
;

: _text+shapes_3
\ split into multiple words because of code overflow
\ probably because of the way strings are implemented with s"
s" 1234567890" type
update-text ;
: _text+shapes_2
update-text cr
10 line !
_text+shapes_3 ;
: text+shapes
{clear-display}
test-shapes redraw
3 cursor !
5 line !
clear-line-buf
s" hello world" type
_text+shapes_2 ;

: showfont
0xaaaa emit
redraw
reset-text
0 line !
{update
0
15 for
 19 for
  dup 0 type 1 +
 next
 render-text cr
next
update}
0xbbbbb emit \ 1.266 seconds
;

: i->s ( i  - ...s )
\ convert integer to string
   0 swap
   begin
       0 10  um/mod
       swap 48 +
       rot 1 +
       rot dup
   0= until
   drop 1-
;

: test-buttons
begin
 read-buttons
 dup button0? if 0 emit then
 dup button1? if 1 emit then
 button2? if 2 emit then
 4 sleep
 0 until
;

: ramtest
191 for i dup ! next
60 20 erase
191 for i @ emit next
;


\: testdrawtime
\0 0 10 for
\ {rect
\    dup 127 over -
\    over over
\    rect.y rect.x
\    2 +
\    swap 1 + 7 and dup rect.color swap
\    rect.fill
\  end} drop
\next drop drop
\begin
\  1111 emit
\  redraw
\0 until
\;

: show-initial-time
{clear-display}
reset-text
 s"  seconds: " type initial-sec i->s type render-text cr
\ s"  minutes: " type initial-min i->s type render-text cr
\ s"    hours: " type initial-hour i->s type render-text cr
\ s"    month: " type initial-mon i->s type render-text cr
\ s" week day: " type initial-wday i->s type render-text cr
\ s" year day: " type initial-yday i->s type render-text cr
\ s"    year: " type initial-year i->s type render-text
;

: test-show-int
 {clear-display}
 reset-text
 s" -->" type
 12387 i->s type
 s" <--" type
 render-text
 ;

  
\ \ 10000000000. 104348 33215 m*/

\ \ memtest
\ \ 0x123456789. 0x121212121.  d+
\ \ 0 begin
\ \   dup 0x1000 u> emit
\ \   0x1000 +
\ \ dup 0= until
\ \ drop

\ perf2
\  2 sleep

  0xcccc emit
  bench
  0xcccc emit

  2017 easter
  snap ;