\ duco 05.3.2 NAB

needs core-ext
needs case
needs graphics
needs textalign
needs bitmap
needs toolkit
needs roman

needs resources
(ID) Duco (ID) rsrc use-resources

3000 constant DucoForm
3000 constant AboutBox
3001 constant HelpString
2001 constant AboutMenuItem
2002 constant HelpMenuItem
\ Button ids run from 2000 to 2016.
2000 constant first-item-id

5 7 2constant m-size
20 5 2constant m-position

m-size bitmap memory-indicator
2 base !
1110110000000000 ,
1001001000000000 ,
1001001000000000 ,
1001001000000000 ,
1001001000000000 ,
decimal

\ Calculator storage:
0 value a
0 value b
0 value memory

2variable display
\ High-cell of display indicates
\  range errors:
display constant out-of-range

: get-display ( -- u )  display 2@ d>s ;
: set-display ( d. -- )  display 2! ;
: zero-display ( -- )  0. set-display ;
: error ( -- )  -1. set-display ;

: add-symbol ( char -- )
  >r
  get-display ( u )
  split-roman ( nnn 1000's )
\ Add char to end of low Roman:
  swap  >roman 2dup +  r> swap c!
\ Convert back to integer:
  1+ roman> ( 1000's newnnn )
\ Combine new nnn and 1000's:
  >r  1000 m*  r> m+  set-display ;

\ Opcodes:
0 enum OpType
  OpType do-nothing
  OpType add
  OpType subtract
  OpType multiply
  OpType divide

do-nothing value nextoperator

false value pendingequals

: clear ( -- )
  zero-display
  false to pendingequals
  do-nothing to nextoperator
  0 to a   0 to b ;

: refresh ( -- )
  emit? 0= if  exit  then
\ The output display area:
  20 154 19 3 dialogFrame frame
  39 40 19 40 line
  boldFont font drop
\ Clear Roman display:
  16 107 22 44 erase-rectangle
\ Clear Arabic display:
  14 32 24 6 erase-rectangle
\ Display Roman:
  24 45 at
  out-of-range @ if
    s" error" type  zero-display  0
  else  get-display dup  romantype
  then
\ Display Arabic:
  0 <# #s #> 38 type.right
\ Memory indicator:
  memory if 
    m-position memory-indicator
  else
    m-size m-position erase-rectangle
  then ;

: args ( -- b. a. )  b 0  a 0 ;

: interim ( -- )
  a to b   get-display to a ;

: equals ( -- )
  pendingequals if  interim  then
  false to pendingequals
  nextoperator case
    add of  args d+ set-display  endof
    subtract of  args d- set-display
    endof
    multiply of
      args drop nip m* set-display
    endof
    divide of
      a if
        args drop
        1  swap  m*/  set-display
      else  error
      then
    endof
  endcase
  refresh
  get-display to b ;

: operator ( opcode -- )
  pendingequals if  equals  then
  to nextoperator
  true to pendingequals
  interim  zero-display ;

\ Map form ctlEvents to chars:
: item>button ( id -- char )
  first-item-id -
  s" MDCLXVI/*+-=wraek" drop + c@ 
;

\ Actions for each button:
: do-button ( char -- )
  case
    [char] k of  clear  refresh  endof
    [char] e of  \ clear error
      zero-display  refresh  endof
    [char] w of  \ mc
      0 to memory  refresh  endof
    [char] a of  \ m+
     get-display memory + to memory
     refresh  endof
    [char] r of  \ mr
      memory  0 set-display  refresh
    endof
    [char] + of  add operator  endof
    [char] -  of  subtract operator
    endof
    [char] * of  multiply operator
    endof
    [char] / of  divide operator  endof
    [char] = of  equals  endof
    dup  add-symbol  refresh
    endcase ;

: help/about ( -- itemid )
  event-id case
    AboutMenuItem of
      AboutBox FrmAlert drop
    endof
    HelpMenuItem of
      HelpString FrmHelp
    endof
  endcase ;

: do-event ( ekey -- )
  case
  menuEvent of  help/about  endof
  ctlSelectEvent of
      event-id item>button do-button
  endof
  frmUpdateEvent of  refresh  endof
  winEnterEvent of  refresh  endof
  endcase ;

\ Main entry point:
: go
  DucoForm ShowForm
  clear
  0 to memory
  refresh
  begin  ekey do-event  again ;
