Programmable RPN Calculator
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. Many of the functions are already laid out, if you get a "no such func: XXX" message, all you need to is to add the function by that name. The existing funcs should show how to access the internals. If you don't see a function you'd like to add, use one of the "( )" placeholders to insert it. If you can't find a placeholder in the f, finv, g, or h shifts, the green "spare" shift is entirely free right now, and could be eliminated when the calc is done if no one comes up with anything needing that shift.
Hopefully the use of the calc should be fairly obvious. There are 1000 registers, however only 20 can be addressed directly, 0-9 and .0-.9, which correspond to 10-19. The rest can be addressed indirectly. One feature awaiting implementation is the ability to reset reg_base, which defaults to 0, and alt_base, which defaults to 10. This will allow you to shift the 0-9 and .0-.9 register "windows" around in the 1000 register space. Flags work in a similar manner.
The design, by the way, is meant to be realizable in actual hardware. That is, the shift keys are meant to be separate colors on an old-fashioned HP-style keypad - f and finv (yellow) to the upper left (only f shown, finv implied - notice that finv is always the exact opposite of the equivalent f function), g (blue) to the upper right, unshifted top, h (black) on the front, and spare (green) below left. Alpha would be white and below right. The top row of keys, whose legends change in menus and the like, are presumed to actually be labelled with the LCD screen above.
You can start the calc with -size {tiny | small | medium | large} to allow for failing eyes or conserving screen real estate.
Someday, when this is finished, it would make a wonderful addition to the Palm Pilot. Or even be built (Hey, I can dream, can't I?)
MB 2008-11-20 : Thank you for that calculator ! I did some updates so that it can be used on a PDA.
#https://wiki.tcl-lang.org/10854
# DKF
#
# rpncalc.tcl --
# A Programmable RPN Calculator
# Usage :
# rpncalc.tcl key value ...
# Arguments
# -size size : the size of the calculator : tiny, small, medium or large or PDA
# Default size is "small" or PDA for Windows CE system.
# History
# 2008-11-20, MB : small updates to make it usable on PDAs under Windows CE.
#
package require Tk
proc init { arglist } {
set rest {}
foreach { var val } $arglist {
set var [ string range $var 1 end ]
uplevel 1 set $var \{$val\}
lappend varlist $var
}
return ""
}
switch -- $::tcl_platform(os) {
"Windows CE" {
set size "PDA"
}
default {
set size "small"
}
}
init $::argv
set stdmenu "1/X X! % %ch ABS \u03c0"
set xstack 0
set SIGMODE 0
set numbase DEC
set anglemode DEG
label .dummy -text "xxx"
set dummyfont [.dummy cget -font]
destroy .dummy
array set attributes [font actual $dummyfont]
switch $size {
PDA {
#wm geometry . 240x360
set attributes(-size) 8
set attributes(-family) "Tahoma"
set attributes(-weight) normal
set minsize 20
set iw 6
}
tiny {
set attributes(-size) 5
set attributes(-weight) bold
set minsize 20
set iw 6
}
small {
set attributes(-size) 8;
set attributes(-weight) bold
set minsize 80
set iw 12
}
medium {
set attributes(-size) 12;
set attributes(-weight) bold
set minsize 110
set iw 12
}
large {
set attributes(-size) 18;
set attributes(-weight) bold
set minsize 130
set iw 12
}
default {
error "Unknown size $size"
}
}
set font [eval font create [array get attributes]]
option add *font $font
option add *background gray
option add *activebackground gray
option add *highlightbackground gray
option add *highlightcolor gray
label .tl -text "DEC" -anchor w -background lightgray -width $iw
label .tn -text "T:" -anchor e -background lightgray
label .tt -background lightgray -foreground black -anchor w -relief sunken
label .zl -text "DEG" -anchor w -background lightgray -width $iw
label .zn -text "Z:" -anchor e -background lightgray
label .zt -background lightgray -foreground black -anchor w -relief sunken
label .yl -text "4STK" -anchor w -background lightgray -width $iw
label .yn -text "Y:" -anchor e -background lightgray
label .yt -background lightgray -foreground black -anchor w -relief sunken
label .xl -text "\u03a3LIN" -anchor w -background lightgray -width $iw
label .xn -text "X:" -anchor e -background lightgray
label .xt -background lightgray -foreground black -anchor w -relief sunken
grid config .tl -row 0 -column 0 -sticky "nsw"
grid config .tn -row 0 -column 0 -sticky "nse"
grid config .tt -row 0 -column 1 -columnspan 5 -sticky "nsew"
grid config .zl -row 1 -column 0 -sticky "nsw"
grid config .zn -row 1 -column 0 -sticky "nse"
grid config .zt -row 1 -column 1 -columnspan 5 -sticky "nsew"
grid config .yl -row 2 -column 0 -sticky "nsw"
grid config .yn -row 2 -column 0 -sticky "nse"
grid config .yt -row 2 -column 1 -columnspan 5 -sticky "nsew"
grid config .xl -row 3 -column 0 -sticky "nsw"
grid config .xn -row 3 -column 0 -sticky "nse"
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 {
"( )" "INT" "D\u2192H" "R\u2192P" "D\u2192R" "\u03a3+" \
"STO" "X\u00b2" "Y\u2191X" "LN" "LOG" "( )" \
"ST0@" "( )" "( )" "( )" "ISG" "R\u2191" \
"FS?" "M\u2192E" "( )" "( )" "( )" "\u03a3ALL" \
"EXIT" "XSTK+" "SF#" "( )" "SST" "( )"
}
set invf {
"( )" "FRAC" "D\u2190H" "R\u2190P" "D\u2190R" "\u03a3-" \
"RCL" "\u221aX" "Y\u221aX" "e\u2191X" "10\u2191X" "( )" \
"RCL@" "( )" "( )" "( )" "DSZ" "R\u2193" \
"FC?" "M\u2190E" "( )" "( )" "( )" "\u03a3LIN"\
"EXIT" "XSTK-" "CF#" "( )" "BST" "( )"
}
set g {
"HYP" "PROG" "TEST" "IF" "GTO" "SHL" \
"TRIG" "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 ]] {
if ![string equal $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 "" ] return
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 "function: $function"
if { [ string length $function ] > 1 } {
call $function
} else {
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
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}
set hyptrig 0
set invtrig 1
proc TRIG {} {
global invtrig hyptrig
set hyptrig 0
if $invtrig {
menu INV SIN COS TAN
} else {
menu INV ASIN ACOS ATAN
}
}
proc HYP {} {
global invtrig hyptrig
set hyptrig 1
if $invtrig {
menu INV SINH COSH TANH
} else {
menu INV ASINH ACOSH ATANH
}
}
proc INV {} {
global invtrig hyptrig
set invtrig [ expr !$invtrig ]
if $hyptrig then HYP else TRIG
}
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" ]
# [DKF]: Not sure if the last two were fixed correctly...
} 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"
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"
}
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"
}
proc XSTK- {} {
global xstack
set xstack 0
.yl configure -text "4STK"
}
proc \u03a3ALL {} {
global SIGMODE
set SIGMODE 1
.xl configure -text "\u03a3ALL"
}
proc \u03a3LIN {} {
global SIGMODE
set SIGMODE 0
.xl configure -text "\u03a3LIN"
}
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 ON/OFF {} {
exit
}
proc OFF {} {
exit
}
proc ON {} {
set which [ pick OFF EXIT ]
if [ string equal $which OFF ] OFF
}
setlabels unshifted
menu
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 Y Z T STK ]
switch $what {
X { puts "X = $x" }
Y { puts "Y = $y" }
Z { puts "Z = $z" }
T { puts "T = $t" }
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
wm resizable . 0 0
vwait foreverHere's a Mac OS X screenshot: 
Larry Smith Looks nice in Aqua. But why don't the shift key colors show properly?
jcw - I'm not sure Aqua supports colors (buttons tend to be gray, plus a blue default). Or maybe Tk Aqua has no hooks for this yet.
Larry Smith Bummer. Sure wrecks a useful feature. Can you change the font color?
See also A little calculator - RPN