\ calc.pretty.fs
\ Author: Tim Corrie Jr. 10/09/2021 first FORTH program, tried to keep generic Written for gforth
CREATE disp$ 24 chars allot
fVARIABLE eax
fVARIABLE ebx
VARIABLE disp$len
VARIABLE opid
VARIABLE gfinputting

0 disp$len ! 
2.2e eax f!
3.3e ebx f!

: outkey ( color {str len} i -- color ) 
    3 pick swap ( color {str len} i -- color {str len} color i ) 
    S\" F 0 10526880\n" type
    S" FR 0 " type dup 4 MOD 2000 * 220 + .
    S" " type dup 4 / 1200 * 1220 + .
    S" " type dup 4 MOD 2000 * 2080 + .
    S" " type dup 4 / 1200 * 2280 + .  CR
    S\" F 0 986895\n" type
    S" R 0 " type dup 4 MOD 2000 * 200 + .
    S" " type dup 4 / 1200 * 1200 + .
    S" " type dup 4 MOD 2000 * 2100 + .
    S" " type dup 4 / 1200 * 2300 + .  CR
    swap S\" F 0 " type . CR
    S" C$ 0 " type dup 4 MOD 2000 * 1100 + .
    S" " type 4 / 1200 * 1700 + .
    S\" \"" type type S\" \"" type CR
;

: displayf ( f -- )
    S\" F 0 16777215\nFR 0 0 0 9900 600\nF 0 6052991\n" type
    S\" R 0 100 100 9800 500\n" type S\" R$ 0 9800 520 \"" type 
    fdup fdup fround f= IF
        f>d 2dup 0 0 d< IF
            45 emit dabs
        THEN
        <# #s #> type
    ELSE
        20 18 17 f>str-rdp -trailing type
    THEN
    S\" \"\nZ \n" type stdout flush-file
;

: drawapp ( -- )
    S\" Fo 0 611 3\nFo 2 140 3\nF 0 16777215\nFR 0 0 0 10000 10000\nF 0 6052991\nZ \nB 0 12632256\n" type
    
    2628059 s" Off" 0 outkey
            s" C" 1 outkey
            s" <x]" 2 outkey drop
    1015567 s" *" 3 outkey
            s" /" 7 outkey
            s" +" 11 outkey
            s" -" 15 outkey
            s" =" 19 outkey drop
    986895  s" 7" 4 outkey
            s" 8" 5 outkey
            s" 9" 6 outkey
            s" 4" 8 outkey
            s" 5" 9 outkey
            s" 6" 10 outkey
            s" 1" 12 outkey
            s" 2" 13 outkey
            s" 3" 14 outkey
            s" 0" 16 outkey
            s" ." 17 outkey
            s" +/-" 18 outkey drop
    S\" F 1 t052864\n" type
    S\" C$ 0 5000 800 \"forth cloud app\"\n" type
    S\" C$ 2 5000 7200 \"Corrie Zucker Technologies LLC.\"\n" type
    S\" C$ 2 5000 7340 \"d/b/a CZ Technologies\"\nZ \n" type
    0.0e displayf
;


: displaystr ( -- ) 
    S\" F 0 16777215\nFR 0 0 0 9900 600\nF 0 6052991\n" type
    S\" R 0 100 100 9800 500\nR$ 0 9800 520 \"" type
    disp$ disp$len @ type
    S\" \"\nZ \n" type stdout flush-file
;

: eatwhite
    begin
        key dup 
        32 > dup
        IF
        ELSE
            swap drop
        THEN
    until
;

: eat$eval ( key -- )
    pad ( key pad -- )
    c! ( -- )
    pad char+ 1 ( *psz 1 )
    begin
        key ( *psz len key -- )
        dup ( *psz len key key -- )
        32  ( *psz len key key 32 -- )
        >=  ( *psz len key >= -- )
        while
            rot ( len key *psz -- )
            swap ( len *psz key -- )
            over ( len *psz key *psz -- )
            c! ( len *psz -- )
            char+ ( len psz++ -- )
            swap 1+ ( *psz len++ -- )
    repeat
    drop swap drop pad swap evaluate
;

: disp$++ ( numchar -- )
    disp$ disp$len @ + c! 1 disp$len +! displaystr 1 gfinputting !
;

: opprefix ( opid -- )
    opid !
    gfinputting @ IF
        disp$ disp$len @ >FLOAT eax f! 0 disp$len !
    THEN
;

: eatnumber ( [0-9] -- n )
    begin
        swap 10 * swap 48 - + key dup
    32 <= until
    drop *
;

: eatsignednumber ( [-0-9] -- sn )
    dup
    45 = IF
        drop -1 0 key eatnumber
    ELSE
        1 0 rot eatnumber
    THEN
;

: do-calc ( -- )
    gfinputting @ IF
        disp$ disp$len @ >FLOAT ebx f! 0 gfinputting !
    THEN 
    0 disp$len ! eax f@ ebx f@
    opid @ CASE
        3 OF f* ENDOF
        7 OF f/ ENDOF
        11 OF f+ ENDOF
        15 OF f- ENDOF
    ENDCASE
    eax f! eax f@ displayf
;

: eat3#eval
     eatsignednumber eatwhite eatsignednumber eatwhite eatsignednumber 
     rot ( button x y -- x y button )
     2 pick 0 < IF
       2 pick -2 = IF
          drop dup
          CASE
              111 OF ." O 0 0 0" CR stdout flush-file 1000 ms bye ENDOF
              79 OF ." O 0 0 0" CR stdout flush-file 1000 ms bye ENDOF
              8 OF ( <*] backspace ) gfinputting @ IF disp$len @ dup 0 > IF 1 - disp$len ! displaystr THEN THEN ENDOF
              42 OF ( * ) 3 opprefix ENDOF
              47 OF ( / ) 7 opprefix ENDOF
              43 OF ( + ) 11 opprefix ENDOF
              45 OF ( - ) 15 opprefix ENDOF
              48 OF disp$++ ENDOF 49 OF disp$++ ENDOF 50 OF disp$++ ENDOF 51 OF disp$++ ENDOF
              52 OF disp$++ ENDOF 53 OF disp$++ ENDOF 54 OF disp$++ ENDOF 55 OF disp$++ ENDOF
              56 OF disp$++ ENDOF 57 OF disp$++ ENDOF
              83 OF ( +/- ) disp$ c@ 45 = 
                  IF disp$ dup 1 + swap disp$len @ 1 - dup disp$len ! MOVE
                  ELSE disp$ dup 1 + disp$len @ MOVE 45 disp$ c! disp$len @ 1 + disp$len ! THEN
                  displaystr ENDOF
              115 OF ( +/- ) disp$ c@ 45 = 
                  IF disp$ dup 1 + swap disp$len @ 1 - dup disp$len ! MOVE
                  ELSE disp$ dup 1 + disp$len @ MOVE 45 disp$ c! disp$len @ 1 + disp$len ! THEN
                  displaystr ENDOF
              61 OF do-calc ENDOF
          ENDCASE
          drop 
       ELSE
          2 pick -4 = IF
              S" Rz " type .  S" " type . CR drop
          ELSE
              2 pick -5 = IF
                  S" Mv " type .  S" " type . CR drop
              ELSE
                  drop drop drop ( is this correct? )
              THEN
          THEN
       THEN
     ELSE
         dup 1 = IF
             drop 1200 - 1200 / ( x y button -- x row )
             swap 200 - 2000 / swap ( row x -- col row )
             ( bounds checking needed here )
             4 * + ( col row -- rowcol )
             CASE 0 OF ." O 0 0 0" CR stdout flush-file 1000 ms bye ENDOF
                  1 OF ( C clear ) 0 disp$len ! 0 gfinputting ! 0.0e displayf ENDOF
                  2 OF ( <*] backspace ) gfinputting @ IF disp$len @ dup 0 > IF 1 - disp$len ! displaystr THEN THEN ENDOF
                  3 OF ( * ) 3 opprefix ENDOF
                  7 OF ( / ) 7 opprefix ENDOF
                  11 OF ( + ) 11 opprefix ENDOF
                  15 OF ( - ) 15 opprefix ENDOF
                  4 OF 55 disp$++ ENDOF 5 OF 56 disp$++ ENDOF 6 OF 57 disp$++ ENDOF 8 OF 52 disp$++ ENDOF
                  9 OF 53 disp$++ ENDOF 10 OF 54 disp$++ ENDOF 12 OF 49 disp$++ ENDOF 13 OF 50 disp$++ ENDOF
                  14 OF 51 disp$++ ENDOF 16 OF 48 disp$++ ENDOF
                  17 OF 46 disp$++ ENDOF 
                  18 OF ( +/- ) disp$ c@ 45 = 
                      IF disp$ dup 1 + swap disp$len @ 1 - dup disp$len ! MOVE
                      ELSE disp$ dup 1 + disp$len @ MOVE 45 disp$ c! disp$len @ 1 + disp$len ! THEN
                      displaystr ENDOF
                  19 OF do-calc ENDOF
             ENDCASE
         ELSE
             drop drop drop ( put not left button click stuff here )
         THEN
     THEN
;

: eattoken ( -- )
    eatwhite dup 
    45 = IF
        eat3#eval
    ELSE
        dup 
        48 < IF
            eat$eval
        ELSE
            dup
            57 > IF
                eat$eval
            ELSE
                eat3#eval
            THEN
        THEN
    THEN
;

: main ( -- )
    begin
        eattoken
    again
;

main