if 0 {
---
[http://www.smith-house.org/images/HP-43.gif]
---

  I've always been a big fan of HP calcs, but of all the simulated ones none
  really try to equal the best of the "traditional" (pre-rpl) models - the
  32SII and the 42S.  This one doesn't either, at least not yet, but it has
  potential.  The basic plumbing is there, one just needs to fill in a lot
  of functions - and I've not been able to get to that, so I hope some of you
  will.  Hopefully the use of the calc should be fairly obvious.
}

 set stdmenu "1/X X! % %ch ABS \u03c0"
 set xstack 0
 set SIGMODE 0
 set numbase DEC
 set anglemode DEG

 label .dummy -text "xxx"
 array set attributes [font actual [.dummy cget -font]]
 set attributes(-size) 10
 set attributes(-weight) bold
 set font [eval font create [array get attributes]]
 option add *font $font
 option add *background darkgray
 option add *activebackground darkgray
 option add *highlightbackground darkgray
 option add *highlightcolor darkgray
 destroy dummy

 label .tl -text "DEC         T:" -anchor e
 label .tt -background lightgray -foreground black -anchor w -relief sunken

 label .zl -text "DEG         Z:" -anchor e
 label .zt -background lightgray -foreground black -anchor w -relief sunken

 label .yl -text "4STK        Y:" -anchor e
 label .yt -background lightgray -foreground black -anchor w -relief sunken

 label .xl -text "\u03a3LIN        X:" -anchor e
 label .xt -background lightgray -foreground black -anchor w -relief sunken

 grid config .tl -row 0 -column 0 -sticky "nsew"
 grid config .tt -row 0 -column 1 -columnspan 5 -sticky "nsew"
 grid config .zl -row 1 -column 0 -sticky "nsew"
 grid config .zt -row 1 -column 1 -columnspan 5 -sticky "nsew"
 grid config .yl -row 2 -column 0 -sticky "nsew"
 grid config .yt -row 2 -column 1 -columnspan 5 -sticky "nsew"
 grid config .xl -row 3 -column 0 -sticky "nsew"
 grid config .xt -row 3 -column 1 -columnspan 5 -sticky "nsew"

 set udklist { udk1 udk2 udk3 udk4 udk5 udk6 }

 set shiftlist { func invf g h spare alpha }

 set label(func)   f
 set label(invf)   f\u00af\u00b9
 set label(g)      g
 set label(h)      h
 set label(spare)  spare
 set label(alpha)  \u03b1

 set bg(func)      yellow
 set bg(invf)      yellow
 set bg(g)         slateblue
 set bg(h)         black
 set bg(spare)     darkgreen
 set bg(alpha)     white
 set bg(unshifted) black

 set fg(func)      black
 set fg(invf)      black
 set fg(g)         white
 set fg(h)         white
 set fg(spare)     white
 set fg(alpha)     black
 set fg(unshifted) black

 set funcname(\u03c0)   const-pi
 set funcname(\u2190)   backsp
 set funcname(.)   decimal

 set btnlist {
   0  1  2  3  4  5  \
   6  7  8  9  10 11 \
   12 13 14 15 16 17 \
   18 19 20 21 22 23 \
   24 25 26 27 28 29 }

 set unshifted {
   "PRINT"  "X\u2194Y" "CHS"  "EEX"  "\u2190" "\u00f7"  \
   "7"      "8"        "9"    "0xA"  "0xD"    "\u00d7"  \
   "4"      "5"        "6"    "0xB"  "0xE"    "-"       \
   "1"      "2"        "3"    "0xC"  "0xF"    "+"       \
   "ON/OFF" "0"        "."    "DO"   "MOD"    "ENTER"   }

 set func {
   "STO"    "INT"      "D\u2192H" "R\u2192P" "D\u2192R" "\u03a3+"     \
   "STO@"   "X\u00b2"  "Y\u2191X" "LN"       "LOG"      "(    )"      \
   "HYP"    "TRIG"     "(    )"   "(    )"   "ISG"      "R\u2191"     \
   "FS?"    "M\u2192E" "(    )"   "(    )"   "(    )"   "\u03a3ALL"   \
   "EXIT"   "XSTK+"    "SF#"      "(    )"   "SST"      "(    )"      }

 set invf {
   "RCL"    "FRAC"      "D\u2190H" "R\u2190P" "D\u2190R"    "\u03a3-"  \
   "RCL@"   "\u221aX"   "Y\u221aX" "e\u2191X" "10\u2191X"   "(    )"   \
   "AHYP"   "ATRG"      "(    )"   "(    )"   "DSZ"         "R\u2193"  \
   "FC?"    "M\u2190E"  "(    )"   "(    )"   "(    )"      "\u03a3LIN"\
   "EXIT"   "XSTK-"     "CF#"      "(    )"   "BST"         "(    )"   }

 set g {
   "(    )"  "PROG"   "TEST"     "IF"     "GTO"    "SHL" \
   "(    )"  "LBL"    "DISP"     "LOOP"   "GSB"    "SHR" \
   "BASE"    "DRG"    "P\u2194S" "(    )" "RTN"    "AND" \
   "CLEAR"   "STDM"   "(    )"   "(    )" "NOT"    "XOR" \
   "EXIT"    "RND#"   "2'sC"     "(    )" "LstX"   "OR"  }

 set h {
   "SOLVE"  ""       "SD"       "PSD"     "AVG"   "\u222bf(x)" \
   "L.R."   "AVGxy"  "s,\u03c3" "SUMS"    "CFIT"  "NPV"   \
   "N"      "Int"    "PMT"      "PV"      "FV"    "DATE-" \
   "IRR"    "BOND"   "DEPR"     "BAL"     "%T"    "DATE+" \
   "EXIT"   "(    )" "(    )"   "(    )"  "ACCi"  "ENTER" }

 set spare {
   "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
   "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
   "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
   "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" \
   "(    )" "(    )" "(    )" "(    )" "(    )" "(    )" }

 set alpha {
   "A"    "B"   "C"   "D"    "E"    "F" \
   "G"    "H"   "I"   "J"    "K"    "L" \
   "M"    "N"   "O"   "P"    "Q"    "R" \
   "S"    "T"   "U"   "V"    "W"    "X" \
   "EXIT" "Y"   "Z"   "punc" "cap"  "ENTER" }

 set lock 0
 set curshift ""
 proc setlabels { newshift } {
   global btnlist func invf alpha g h unshifted spare lock curshift bg

   if [ string equal $newshift $curshift ] {
     set lock [ expr !$lock ]
     if $lock return
     setlabels unshifted
     return
   }
   set curshift $newshift
   set lock 0
   set n 0
   foreach btn $btnlist {
     set text [ lindex [ set $newshift ] $n ]
     set fg $bg($curshift)
     .$btn configure -text $text -foreground $fg -activeforeground $fg
     incr n
   }
 }

 proc call { func } {
   global funcname
   if [ info exists funcname($func) ] {
     set func $funcname($func)
   }
   if [string match $func [ info commands $func ]] {
     $func
   } else {
     puts "no such func: $func"
   }
 }

 proc dispatch { key } {
   global lock curshift shiftlist menupick

   if [ regexp udk(.) $key mpos ] {
     if $menupick {
       set temp [ .$key cget -text ]
       if [ string equal $temp >> ] { next
       } elseif [ string equal $temp << ] { prev
       } else { set menupick $temp
       }
       return
     }
     set function [ .$key cget -text ]
     call $function
     return
   }
   if { $menupick } {
     if { $key != 24 } return
     set menupick ""
   }
   if { [ lsearch -exact $shiftlist $key ] != -1 } {
     setlabels $key
     return
   }
   global $curshift
   set function [ lindex [set $curshift] $key ]
   if ![ string equal $function "" ] {
     if [ string equal curshift alpha ] {
       puts "inpchar $function"
     } else {
       call $function
     }
   }
   if !$lock { setlabels unshifted }
 }

 set curmenu ""
 set oldmenu ""
 set menubase 0
 set menupick 0

 proc updudks { } {
   global menubase curmenu

   set i $menubase
   set menulen [ llength $curmenu ]
   for { set j 1 } { $j <= 6 } { incr j } {
     if { $j > $menulen } {
       .udk$j configure -text ""
     } else {
       .udk$j configure -text [ lindex $curmenu [ expr $menubase + $j -1 ]]
     }
   }
 }

 proc menu { args } {
   global curmenu oldmenu menubase stdmenu

   if [string equal $args ""] { set args $stdmenu }
   set oldmenu $curmenu
   set curmenu $args
   set menubase 0
   set page 6
   while { [ llength $curmenu ] > $page } {
     set curmenu [ linsert $curmenu [ expr $page - 1] >> << ]
     incr page 6
   }
   updudks
 }

 proc resume { } {
   global curmenu oldmenu menubase
   set curmenu $oldmenu
   set oldmenu ""
   set menubase 0
   updudks
 }

 proc pick { args } {
   global menupick oldmenu

   if {$menupick == 1} {
     set menupick ""
   }
   set menupick 1
   eval menu $args
   vwait menupick
   set result $menupick
   set menupick 0
   resume ; return $result
 }

 proc next { } {
   global menubase ; incr menubase 6 ; updudks
 }

 proc prev { } {
   global menubase ; incr menubase -6 ; updudks
 }

 set row 4 ; set col 0
 set keylist "$udklist $shiftlist $btnlist"
 foreach fn $keylist {
   set lbl $fn
   if [ info exists label($fn) ] { set lbl $label($fn) }
   set color ""
   if [ info exists fg($fn) ] {
     set color " -foreground $fg($fn) -background $bg($fn) "
     set color "$color -activeforeground $fg($fn) -activebackground $bg($fn) "
   } else {
     set color "-foreground black -activeforeground black"
   }
   if [ info exists label($fn) ] {
     set lbl $label($fn)
   }
   eval button .$fn $color -text $lbl -pady 0 -borderwidth 1
   .$fn configure -command [ list dispatch $fn ]
   grid config .$fn -row $row -column $col -sticky "nsew"
   incr col
   if { $col > 5 } {
     set col 0
     incr row
   }
 }

 wm protocol . WM_DELETE_WINDOW {OFF}

 proc TRIG {} { menu SIN COS TAN }
 proc ATRG {} { menu ASIN ACOS ATAN }
 proc HYP {} { menu SINH COSH TANH }
 proc AHYP {} { menu ASINH ACOSH ATANH }
 proc SUMS {} {
   global SIGMODE
   if { ${SIGMODE} } {
     set which [ pick n X Y X² Y² XY \
       "lnX" "(lnX)²" "lnY" "(lnY)²" \
       "(lnX)(lnY)" "X•lnY" "Y•lnX" ]
   } else {
     set which [ pick n X Y X² Y² XY ]
   }
   puts "SUMS: $which"
 }
 proc punc {} {
   set ch [ pick ? , : \; ! ( ) \[ \] \{ \} spc _ * \" ' @ # $ % ^ & * = ~ ]
   puts "selected '$ch'"
 }
 proc BASE {} {
   set base [ pick HEX DEC OCT BIN ]
   .tl configure -text "$base         T:"
   puts "new base: $base"
 }
 proc DISP {} {
   set disp [ pick ALL FIX SCI ENG ]
   puts "disp is: $disp"
 }
 proc EXIT {} { setlabels unshifted }
 proc DRG {} {
   global anglemode
   set anglemode [ pick DEG RAD GRD ]
   .zl configure -text "$anglemode         Z:"
 }
 proc CLEAR {} {
   global x y z t
   set what [ pick REGS \u03a3REG FIN PROG STACK X ALL ]
   if [ string equal $what ALL ] {
     set sure [ pick "DO IT" EXIT ]
     if [ string equal $sure "DO IT" ] {
       puts "clearing all"
     }
   } else {
     switch $what {
       REGS {}
       \u03a3REG {}
       FIN  {}
       PROG {}
       STACK { set x 0 ; set y 0; set z 0; set t 0; end }
       X { set x 0; end }
     }
     puts "clearing $what"
   }
 }
 proc XSTK+ {} {
   global xstack
   set xstack 1
   .yl configure -text "XSTK       Y:"
 }
 proc XSTK- {} {
   global xstack
   set xstack 0
   .yl configure -text "4STK       Y:"
 }
 proc \u03a3ALL {} {
   global SIGMODE
   set SIGMODE 1
   .xl configure -text "\u03a3ALL       X:"
 }
 proc \u03a3LIN {} {
   global SIGMODE
   set SIGMODE 0
   .xl configure -text "\u03a3LIN       X:"
 }
 proc L.R. {} {
   set which [ pick ESTx ESTy r m b ]
   puts "Linear Regression: $which"
 }
 proc AVGxy {} {
   set which [ pick AVGx AVGy AVGxw ]
   puts "AVGxy: $which"
 }
 proc s,\u03c3 {} {
   set which [ pick sx sy \u03c3x \u03c3y ]
   puts "s,\u03c3: $which"
 }
 proc CFIT {} {
   set which [ pick MODL ... ]
   puts "CFIT: $which"
 }
 proc BOND {} {
   set which [ pick PRICE YTM ]
   puts "BOND: $which"
 }
 proc DEPR {} {
   set which [ pick SL SOYD DB ]
   puts "DEPRECIATION: $which"
 }
 proc STDM {} {
   menu
 }
 proc TEST {} {
   set which [ pick X?0 X?Y FS? FC? FS?C FC?S ]
   set func ""
   switch $which {
     X?0 { set func [ pick < \u2264 = \u2260 \u2265 > ] }
     X?Y { set func [ pick < \u2264 = \u2260 \u2265 > ] }
   }
   if [ string equal $func "" ] {
     puts "test: $which"
   } else {
     set which [ string replace $which 1 1 $func ]
     puts "test: $which"
   }
 }
 proc IF {} {
   set which [ pick TEST ELSE ELSIF ENDIF ]
   if [ string equal $which "TEST" ] TEST
   puts "IF $which"
 }
 proc LOOP {} {
   set which [ pick BEGIN BREAK NEXT ENDL ]
   puts "LOOP: $which"
 }
 proc M\u2192E {} {
   set which [ pick in ft yds miles degF gals lbs ]
 }
 proc E\u2192M {} {
   set which [ pick cm m km degC ltrs kgs ]
 }
 proc OFF {} {
   exit
 }
 proc ON {} {
   set which [ pick OFF EXIT ]
   if [ string equal $which OFF ] OFF
 }

 setlabels unshifted
 menu

 set minsize 80
 grid columnconfigure . 0 -minsize $minsize
 grid columnconfigure . 1 -minsize $minsize
 grid columnconfigure . 2 -minsize $minsize
 grid columnconfigure . 3 -minsize $minsize
 grid columnconfigure . 4 -minsize $minsize
 grid columnconfigure . 5 -minsize $minsize
 wm title . "HP-43"

 set x 0
 set y 0
 set z 0
 set t 0

 proc upddisp {} {
   global x y z t
   .tt configure -text $t
   .zt configure -text $z
   .yt configure -text $y
   .xt configure -text $x
 }

 proc pull {} {
   global needpush x y z t
   set x $y
   set y $z
   set z $t
   set needpush 1
 }

 proc ENTER {} {
   global needpush wipex x y z t
   set t $z
   set z $y
   set y $x
   set wipex 1
   set needpush 0
   upddisp
 }

 set needpush 1
 set wipex 0
 proc key n {
   global needpush wipex x y z t rcl_pending sto_pending
 puts "key: $n rp:$rcl_pending sp:$sto_pending"
   if { $rcl_pending || $sto_pending } {
     register $n
     return
   }
   if $needpush ENTER
   if { $wipex } {
     set x ""
     set wipex 0
   }
   if [ string equal $x "0" ] {
     set x $n
   } else {
     set x "${x}$n"
   }
   upddisp
 }

 proc backsp {} {
   global x needpush
   if $needpush {
     pull
   } else {
     set len [ expr [ string length $x ] - 2 ]
     set x [ string range $x 0 $len ]
     if [ string equal $x "" ] { pull }
   }
   set needpush 1
   upddisp
 }

 proc 0 {} { key 0 }
 proc 1 {} { key 1 }
 proc 2 {} { key 2 }
 proc 3 {} { key 3 }
 proc 4 {} { key 4 }
 proc 5 {} { key 5 }
 proc 6 {} { key 6 }
 proc 7 {} { key 7 }
 proc 8 {} { key 8 }
 proc 9 {} { key 9 }
 proc decimal {} { key . }

 proc float { args } {
   foreach var $args {
     upvar 1 $var tmp
     if [ string is integer $tmp ] {
       set tmp [ expr double($tmp) ]
     }
   }
 }

 proc end {} {
   global needpush
   set needpush 1
   upddisp
 }

 proc binop { op { real 0 } } {
   global x y needpush
   if $real { float x y }
   set result [ expr $y $op $x ]
   pull
   set x $result
   end
 }

 proc + {} { binop + }
 proc - {} { binop - }
 proc \u00d7 {} { binop * }
 proc \u00f7 {} { binop / 1 }
 proc X\u2194Y {} {
   global x y needpush
   set tmp $x
   set x $y
   set y $tmp
   end
 }
 proc 1/X {} {
   global x

   set x [ expr 1.0 / double($x) ]
   end
 }
 proc ABS {} {
   global x

   set x [ expr abs($x) ]
   end
 }
 proc const-pi {} {
   global x needpush
   if $needpush ENTER
   set x "3.141592653589792"
   end
 }

 proc gamma { c } {
   set cof(0) 76.18009172947146
   set cof(1) -86.50532032941677
   set cof(2) 24.01409824083091
   set cof(3) -1.231739572450155
   set cof(4) 0.1208650973866179e-2
   set cof(5) -0.5395239384953e-5
   set xx [ expr double($c) ]
   set yy [ expr double($c) ]
   set tmp [ expr $xx + 5.5 - ($xx + 0.5) * log($xx + 5.5) ]
   set ser 1.000000000190015
   for {set j 0 } { $j<=5 } { incr j } {
     set yy [ expr $yy + 1.0 ]
     set ser [ expr $ser + ($cof($j) / $yy) ]
   }
   return [ expr exp(log(2.5066282746310005*$ser/$xx)-$tmp) ]
 }

 proc X! {} {
   global x
   set result 1
   set j 0
   if [ string is integer $x ] {
     if { $x > 29 } {
       float result x j
     }
     for { set j 2 } { $j <= $x } { incr j } {
       set result [ expr { $result * $j } ]
     }
   } else {
     set result [ gamma [ expr double($x) + 1.0 ] ]
   }
   set x $result
   end
 }
 proc PRINT {} {
   global x y z t
   set what [ pick X STK ]
   switch $what {
     X { puts "X = $x" }
     STK { foreach reg { t z y x } {
       puts "[ string toupper $reg ] = [set $reg]" }
     }
   }
 }
 proc trig { func } {
   global anglemode x
   switch $anglemode {
     DEG { set x [ expr ${func}($x*3.141592653489792/180.0) ] }
     RAD { set x [ expr ${func}($x) ] }
     GRD { set x [ expr ${func}($x*3.141592653489792/200.0) ] }
   }
   end
 }
 proc atrig { func } {
   global anglemode x
   switch $anglemode {
     DEG { set x [ expr a${func}($x)/3.141592653489792*180.0 ] }
     RAD { set x [ expr a${func}($x) ] }
     GRD { set x [ expr a${func}($x)/3.141592653489792/200.0 ] }
   }
   end
 }
 proc htrig { func } {
   global anglemode x
   switch $anglemode {
     DEG { set x [ expr ${func}h($x*3.141592653489792/180.0) ] }
     RAD { set x [ expr ${func}h($x) ] }
     GRD { set x [ expr ${func}h($x*3.141592653489792/200.0) ] }
   }
   end
 }
 proc setglob { name value } { global $name ; set $name $value }
 proc SIN {} { trig sin }
 proc COS {} { trig cos }
 proc TAN {} { trig tan }
 proc ASIN {} { atrig sin }
 proc ACOS {} { atrig cos }
 proc ATAN {} { atrig tan }
 proc SINH {} { htrig sin }
 proc COSH {} { htrig cos }
 proc TANH {} { htrig tan }
 proc STO {} { puts "sto"; setglob sto_pending 1 }
 proc STO@ {} { setglob sto_pending 1 ; setglob indirect 1 }
 proc RCL {} { setglob rcl_pending 1 }
 proc RCL@ {} { setglob rcl_pending 1 ; setglob indirect 1 }

 set reg_base 0
 set alt_base 10
 proc register { digit } {
 puts "register $digit"
   global alt_reg reg_base alt_base sto_pending rcl_pending x
   if [ string equal $digit "." ] {
     set alt_reg 1
     return
   }
   if $alt_reg {
     set regnum [ expr $digit + $alt_base ]
     set alt_base 0
   } else {
     set regnum [ expr $digit + $reg_base ]
   }
   global reg$regnum
   if $sto_pending {
     set reg$regnum $x
   } else {
     ENTER
     set x [ set reg$regnum ]
   }
   set sto_pending 0
   set rcl_pending 0
   end
 }
 # init regs
 for { set j 0 } { $j < 1000 } { incr j } {
   set reg$j 0
 }
 set alt_reg 0
 set sto_pending 0
 set rcl_pending 0
 set indirect 0
 set tcl_precision 17
 upddisp
 vwait forever