
compiletoflash

: 0-foldable $40 setflags immediate ;
: 1-foldable $41 setflags immediate ;
: 2-foldable $42 setflags immediate ;
: 3-foldable $43 setflags immediate ;

: spaces 0 ?do space loop ;

: cell+ 2+ inline 1-foldable ;
: cells 2* inline 1-foldable ;
: char+ 1+ inline 1-foldable ;
: chars    inline 1-foldable ;

: aligned even inline 1-foldable ;
: invert  not  inline 1-foldable ;

: count dup c@ ; ( cstr-addr -- cstr-addr count )

 0 constant false
-1 constant true

: sm/rem m/mod inline 3-foldable ;

: fm/mod  ( d1 n1 -- n2 n3   floored signed div'n courtesy of Ed Smeda )
    dup >r
      sm/rem 2dup 1 < and
      if swap r@ + swap 1- then
    r>
    drop
3-foldable ;

: octal 8 base ! ;
: sqr ( n -- n^2 ) dup * 1-foldable ;
: star 42 emit ;

: Flamingo cr
."      _" cr
."     ^-)" cr
."      (.._          .._" cr
."       \`\\        (\`\\        (" cr
."        |>         ) |>        |)" cr
." ______/|________ (7 |` ______\|/_______a:f" cr
;

: init Flamingo cr ." Have a nice day !" cr ;

: table   cr 11 1 do
                    11 1 do i j * . loop
                    cr
                  loop ;
table


( Roman numerals taken from Leo Brodies "Thinking Forth" )

: create> <builds does> ;
( In ANS, this would simply be done with "create" )

create> romans
  (      ones ) char I c,  char V c,
  (      tens ) char X c,  char L c,
  (  hundreds ) char C c,  char D c,
  ( thousands ) char M c,

0 variable column# ( current_offset )
: ones      0 column# ! ;
: tens      2 column# ! ;
: hundreds  4 column# ! ;
: thousands 6 column# ! ;

: column ( -- address-of-column ) romans column# @ + ;

: .symbol ( offset -- ) column + c@ emit ;
: oner  0 .symbol ;
: fiver 1 .symbol ;
: tener 2 .symbol ;

: oners ( #-of-oners )
  ?dup if 0 do oner loop then ;

: almost ( quotient-of-5 -- )
  oner if tener else fiver then ;

: romandigit ( digit -- )
  5 /mod over 4 = if almost drop else if fiver then oners then ;

: roman ( number -- )
  1000 /mod thousands romandigit
   100 /mod  hundreds romandigit
    10 /mod      tens romandigit
                 ones romandigit ;

: mealtime   19 u<= if
                      ." Fruit salad "
                    else
                      ." Green salad "
                    then
                    ." would be nice !" ;

: mealsforwholeday cr 25 6 do i dup roman ." : " mealtime cr 2 +loop cr ;
mealsforwholeday

: numbertable  <builds
                  0 do
                      token number 1 <> if ." Constant error." quit then ,
                    loop
               does> swap 2* + @ ;

hex
10 numbertable e^ka  C90F 76B1 3EB6 1FD5 0FFA 07FF 03FF 01FF 00FF 007F 003F 001F 000F 0007 0003 0001
decimal

: 2rshift 0 ?do d2/ loop ;

: cordic ( f-angle -- f-error f-sine f-cosine )
         ( Angle between -Pi/2 and +Pi/2 ! )
  0 0 $9B74 0
  16 0 do
    2rot dup 0<
    if
      i e^ka 0 d+ 2rot 2rot
            2over i 2rshift 2rot 2rot
      2swap 2over i 2rshift
      d- 2rot 2rot d+
    else
      i e^ka 0 d- 2rot 2rot
            2over i 2rshift 2rot 2rot
      2swap 2over i 2rshift
      d+ 2rot 2rot 2swap d-
    then
  loop
2-foldable ;

: sine   ( f-angle -- f-sine )   cordic 2drop 2nip   2-foldable ;
: cosine ( f-angle -- f-cosine ) cordic 2nip  2nip   2-foldable ;

3,14159   2constant pi
pi 2,0 f/ 2constant pi/2

pi 4,0 f/ cosine f. \ Displays cos(Pi/4)

: widecosine ( f-angle -- f-cosine )
  dabs
  pi/2 ud/mod drop 3 and ( Quadrant f-angle )

  case
    0 of                 cosine         endof
    1 of dnegate pi/2 d+ cosine dnegate endof
    2 of                 cosine dnegate endof
    3 of dnegate pi/2 d+ cosine         endof
  endcase

  2-foldable ;

: widesine ( f-angle -- f-sine )
  dup >r \ Save sign
  dabs
  pi/2 ud/mod drop 3 and ( Quadrant f-angle )

  case
    0 of                 sine          endof
    1 of dnegate pi/2 d+ sine          endof
    2 of                 sine  dnegate endof
    3 of dnegate pi/2 d+ sine  dnegate endof
  endcase

  r> ?dnegate
  2-foldable ;


compiletoram
