calculator (Booth)

What: calculator (Booth)

 Where: ftp://ftp.procplace.com/pub/tcl/sorted/packages-7.6/math/calculator/calculator.tk.tar.gz
 Description: Simple Tk calculator.
 Updated: 09/1997
 Contact: [Richard Booth]

recently revisited rvb

The original calculator dates from pre- "switch" command days (and before too much experience with Tcl/Tk!). It was also "pack append", back then, rather than "pack $window".

Here is a slightly more modern, updated version. Some of the changes are:

different layout
button procs instead of single punch button dispatch procedure
backspace for correcting number entry
OFF button
ARC and HYP buttons
bitmaps for pi and sqrt
menu of additional commands, including random number and logging
use tk_messageBox for help and error messages

 #############################################################################
 # NAME    : calc.tk
 # PURPOSE : calculator
 # AUTHOR  : rvb
 #############################################################################
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 # globals
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 set buttons {
   OFF  HELP const pi   AC 
   DRG  MENU put   e    CE 
   HYP  sin  cos   tan  sqrt
   ARC  x!   10^x  exp  x^2
   M+   1/x  log   ln   y^x
   M-   EE   (     )    /
   STO  7    8     9    *
   RCL  4    5     6    -
   XCH  1    2     3    +
   CLR  0    .     +/-  =
 }
 set buttoncommands {
   OFF  HELP const pi   AC 
   DRG  MENU put   e    CE 
   HYP  trig trig  trig sqrt
   ARC  fact tenx  exp  sqr
   M+   inv  log   ln   ytox
   M-   EE   lpar  rpar mdiv
   STO  num  num   num  mdiv
   RCL  num  num   num  pmin
   XCH  num  num   num  pmin
   CLR  num  pt    porm eq
 }
 set bindings { 
   Control-Key-q       H           less        numbersign  A
   d                   question    greater     at          C     
   h                   s           c           t           r
   a                   exclam      X           x           dollar
   Control-Key-p       percent     L           l           asciicircum
   Control-Key-m       e           parenleft   parenright  slash
   Control-Key-s       Key-7       Key-8       Key-9       asterisk
   Control-Key-r       Key-4       Key-5       Key-6       minus
   Control-Key-x       Key-1       Key-2       Key-3       plus
   Control-Key-c       Key-0       period      asciitilde  equal
 }
 set menuentries {
   "random number"  "RAND"
   "random seed"    "SEED"
   "list stack"     "STK?"
   "set precision"  "PREC"
   "logging"        "LOG"
 }
 set constants {
   "273.16          :Tabs         :T(O deg C) deg K"
   "1.380622E-23    :kB   (J/K)   :boltzmann constant"
   "8.61708E-05     :kB   (eV/K)  :boltzmann constant"
   "6.58218E-16     :hbar (eV-s)  :planck constant"
   "2.99792E+10     :co   (cm/s)  :speed of light in vacuum"
   "1.602192E-19    :qe   (C)     :unit charge"
   "8.854215E-14    :eo   (F/cm)  :permittivity of free space"
   "9.10956E-31     :mo   (kg)    :electron rest mass"
   "11.7            :ksi          :relative permittivity (Si)"
   "3.9             :kox          :relative permittivity (SiO2)"
   "1.03594315e-12  :esi  (F/cm)  :permittivity (Si)"
   "3.45314385e-13  :eox  (F/cm)  :permittivity (SiO2)"
 }
 set Bitmap(pi) [image create bitmap -data "
   #define pi_width 16
   #define pi_height 16
   static unsigned char pi_bits[] = {
     0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfe, 0x3f, 0x12, 0x04,
     0x10, 0x04, 0x10, 0x04, 0x10, 0x04, 0x10, 0x04, 0x10, 0x04, 0x10, 0x04,
     0x10, 0x04, 0x10, 0x04, 0x1c, 0x04, 0x00, 0x00
   };
 "]
 set Bitmap(sqrt) [image create bitmap -data "
   #define sqrt_width 16
   #define sqrt_height 16
   static unsigned char sqrt_bits[] = {
     0x00, 0x00, 0x00, 0x00, 0x00, 0x7e, 0x00, 0x02, 0x00, 0x02, 0x00, 0x03,
     0x00, 0x01, 0x00, 0x01, 0x87, 0x01, 0x8c, 0x00, 0x98, 0x00, 0xf0, 0x00,
     0x60, 0x00, 0x40, 0x00, 0x40, 0x00, 0x00, 0x00
   };
 "]
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 # button commands:
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 proc num {button} {
   global mode x
   switch -- $mode {
     > {
       set x $button
       set mode I
     }
     I - F {
       append x $button
     }
     E - X {
       set e [string index  $x   end]
       set x [string range  $x 0 end-2]$e$button
       set mode X
     }
   } 
   dispx
 }
 proc pt  {button} {
   global mode x
   switch -- $mode {
     > {
       set x 0.
       set mode F
     }
     I {
       append x .
       set mode F
     }
   }
   dispx
 }
 proc EE {button} {
   global mode x
   switch -- $mode {
     I - F {
       append x E+00
       set mode E
     }
   }
   dispx
 }
 proc porm {button} {
   global mode x
   switch -- $mode {
     > - I - F {
       set s [string index  $x 0]
       if {$s == "-"} {
         set x [string range $x 1 end]
       } else {
         set x -$x
       }
     }
     E - X {
       set s [string index  $x end-2]
       if {$s == "+"} {
         set s -
       } else {
         set s +
       }
       set x [string replace $x end-2 end-2 $s]
     }
   }
   dispx
 }
 proc OFF {button} {
   destroy .
   return
 }
 proc CE {button} {
   CLX
 }
 proc AC {button} {
   global PTR drg arc hyp tcl_precision
   CLX
   CLM
   set PTR 0
   set drg 0
   set hyp 0
   set arc 0
   set tcl_precision 16
   dispa
 }
 proc pi {button} {
   STX acos(-1)
 }
 proc e {button} {
   STX exp(1)
 }
 proc const {button} {
   set u [constant]
   if {$u != "NULL"} {
     STX $u
   }
 }
 proc put {button} {
   global constants
   set x [GTX]
   lappend constants "$x : :saved result"
 }
 proc sqr {button} {
   set x [GTX]
   STX $x*$x
 }
 proc sqrt {button} {
   set x [GTX]
   if {$x < 0} {
     messagebox "error: x<0"
   } else {
     STX sqrt($x)
   }
 }
 proc inv {button} {
   set x [GTX]
   if {$x == 0} {
     messagebox "error: x=0"
   } else {
     STX 1.0/$x
   }
 }
 proc tenx {button} {
   set x [GTX]
   STX pow(10.0,$x)
 }
 proc exp {button} {
   set x [GTX]
   STX exp($x)
 }
 proc log {button} {
   set x [GTX]
   if {$x <= 0} {
     messagebox "error: x<=0"
   } else {
     STX log10($x)
   }
 }
 proc ln  {button} {
   set x [GTX]
   if {$x <= 0} {
     messagebox "error: x<=0"
   } else {
     STX log($x)
   }
 }
 proc ytox {button} {
   global mode
   set x [GTX]
   PSH $x
   PSH **
   set mode >
   dispx
 }
 proc fact {button} {
   set x [GTX]
   if {$x < 0 || $x > 170} {
     messagebox "error: x<0 or x>170"
   } else {
     set u 1.0
     for {set i 1} {$i <= $x} {incr i} {
       set u [expr $u*$i]
     }
     STX $u
   }
 }
 proc trig {button} {
   global drg hyp arc
   set x [GTX]
   if {!$hyp} {
     set f [lindex "[expr acos(-1)/180.0] 1.0 [expr acos(-1)/200.0]" $drg]
     if {!$arc} {
       STX ${button}($f*$x)
     } else {
       STX a${button}($x)/$f
     }
   } else {
     if {!$arc} {
       STX ${button}h($x)
     } else {
       STX [a${button}h $x]
     }
   }
   set arc 0
   set hyp 0
 }
 proc pmin {button} {
   global mode
   switch -- $mode {
     E {
       global x
       set x [string replace $x end-2 end-2 $button]
       dispx
     }
     default {
       PSH [GTX]
       POW
       STX [PEX {[(]}]
       PSH [GTX]
       PSH $button
     }
   }
 }
 proc mdiv {button} {
   PSH [GTX]
   POW
   STX [PEX {[-+(]}]
   PSH [GTX]
   PSH $button
 }
 proc lpar {button} {
   global mode
   if {$mode == ">"} {
     PSH $button
   }
 }
 proc rpar {button} {
   PSH [GTX]
   POW
   STX [PEX {[(]}]
   POP
 }
 proc eq {button} {
   PSH [GTX]
   POW
   STX [PEX]
 }

 proc HELP {button} {
   global buttons bindings
   set    text "Button:\tKey-binding:\n"
   append text "----------------------------\n"
   foreach button $buttons binding $bindings {
     append text "$button\t$binding\n"
   }
   append text "=\t<Return>\n"
   append text "=\t<space>\n"
   messagebox $text
 }
 proc DRG {button} {
   global drg
   set drg [expr ($drg+1)%3]
   dispa
 }
 proc ARC {button} {
   global arc
   set arc [expr !$arc]
   dispa
 }
 proc HYP {button} {
   global hyp
   set hyp [expr !$hyp]
   dispa
 }
 proc M+ {button} {
   set x [GTX]
   set m [GTM]
   STM $m+$x
 }
 proc M- {button} {
   set x [GTX]
   set m [GTM]
   STM $m-$x
 }
 proc STO {button} {
   set x [GTX]
   STM $x
 }
 proc RCL {button} {
   set m [GTM]
   STX $m
 }
 proc XCH  {button} {
   set x [GTX]
   set m [GTM]
   STX $m
   STM $x
 }
 proc CLR {button} {
   CLM
 }
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 # binding and menu commands
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 proc BS {} {
   global mode x
   if {[string length $x] == 1} {
     CLX
     return
   }
   switch -- $mode {
     I {
       set c [string index $x end-1]
       if {$c == "+" || $c == "-"} {
         CLX
       } else {
         set x [string range $x 0 end-1]
       }
     }
     F {
       set c [string index $x end-1]
       if {$c == "."} {
         set x [string range $x 0 end-2]
         set mode I
       } else {
         set x [string range $x 0 end-1]
       }
     }
     X - E {
       set x [string range $x 0 end-4]
       if {[string first "." $x] > 0} {
         set mode F
       } else {
         set mode I
       }
     }
   }
   dispx
 }
 proc RAND {} {
   STX [expr rand()]
 }
 proc SEED {} {
   global x
   set s [expr int($x)]
   expr srand($s)
 }
 proc STK? {} {
   global STK PTR x
   set text "LOC:\tVALUE:\nX:\t$x\n"
   append text "----------------------------\n"
   for {set i $PTR} {$i>0} {incr i -1} {
     append text "$i:\t$STK($i)\n"
   } 
   messagebox $text
 }
 proc PREC {} {
   global x
   if {$x < 1 || $x >= 18} {
     messagebox "error: x<1 or x>=18"
   } else {
     set p [expr int($x)]
     set tcl_precision $p
     messagebox "PRECISION = $p"
   }
 }
 proc LOG {} {
   global _log _logfid
   set _log [expr !$_log]
   set logfile calc.tk.log
   if {$_log} {
     if {[catch {set _logfid [open $logfile w]}]} {
       messagebox "error: cannot open log file \"$logfile\""
       set _log 0
       return
     } else {
       messagebox "log file \"$logfile\" opened"
     }
   } else {
     catch {close $_logfid}
     messagebox "log file \"$logfile\" closed"
   } 
 }
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 # basic calculator functions
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 #============================================================================
 # PSH: push token onto stack
 #============================================================================
 proc PSH {token} {
   global STK PTR
   incr   PTR
   set    STK($PTR) $token
 }
 #============================================================================
 # POP: pop token from stack
 #============================================================================
 proc POP {} {
   global STK PTR 
   set token $STK($PTR)
   if {$PTR>0} {
     incr PTR -1
   }
   return $token
 }
 #============================================================================
 # PEX: pop expression from stack (stop before $stop)
 #============================================================================
 proc PEX {{stop ""}} {
   global PTR
   set e ""
   while {$PTR > 0} {
     set t [POP]
     if {[string match $stop $t]} {
       PSH $t
       break
     }
     if {$t != "NOP"} {
       set e $t$e
     }
   }
   return $e
 }
 #============================================================================
 # STX: set accumulator
 #============================================================================
 proc STX {expression} {
   global x mode
   global _log _logfid
   set x [expr $expression]
   set mode >
   dispx
   if {$_log} {
     puts $_logfid "$expression: $x"
     flush $_logfid
   }
 }
 #============================================================================
 # STM: set memory
 #============================================================================
 proc STM {expression} {
   global m mem mode
   set m [expr $expression]
   set mem 1
   dispm
   set mode >
   dispx
 }
 #============================================================================
 # CLX: clear accumulator
 #============================================================================
 proc CLX {} {
   global x mode
   set x 0
   set mode >
   dispx
 }
 #============================================================================
 # CLM: clear memory
 #============================================================================
 proc CLM {} {
   global m mem
   set m 0
   set mem 0
   dispm
 }
 #============================================================================
 # GTX: return x
 # *  put decimal point on end of x if still in integer mode
 #    before further processing
 #============================================================================
 proc GTX {} {
   global x mode
   if {$mode == "I"} {
     set x $x.
     set mode F
     dispx
   }
   return $x
 }
 #============================================================================
 # GTM: return m
 #============================================================================
 proc GTM {} {
   global m mem
   if {!$mem} {
     set m 0
     set mem 1
     dispm
   }
   return $m
 }
 #============================================================================
 # POW: process powers in stack
 # to change x**y into pow(x,y)
 #============================================================================
 proc POW {} {
   global STK PTR
   for {set i $PTR} {$i>2} {incr i -1} {
     set j [expr $i-1]
     set k [expr $i-2]
     set e $STK($i)
     set p $STK($j)
     set b $STK($k)
     if {$p == "**"} {
       set STK($i) pow($b,$e)
       set STK($j) NOP
       set STK($k) NOP
     }
   }
 }
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 # extra math functions
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 proc asinh {x} {
   return [expr log($x+sqrt($x*$x+1.0))]
 }
 proc acosh {x} {
   return [expr log($x+sqrt($x*$x-1.0))]
 }
 proc atanh {x} {
   if {$x == 1.0} {
     return 100.0
   }
   return [expr log(sqrt((1.0+$x)/(1.0-$x)))]
 }
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 # windows
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 #============================================================================
 # dispx: re-display x, mode
 #============================================================================
 proc dispx {} {
   global x mode
   .display.e configure -state normal
   .display.e delete 0 end
   .display.e insert end $x
   .display.e configure -state disabled
   .states.s  configure -text $mode
 }
 #============================================================================
 # dispm: re-display mem
 #============================================================================
 proc dispm {} {
   global mem
   .states.m  configure -text [lindex "{} MEM" $mem]
 }
 #============================================================================
 # dispa: re-display drg, hyp, arc
 #============================================================================
 proc dispa {} {
   global drg hyp arc
   .states.d  configure -text [lindex "DEG RAD GRD" $drg]
   .states.a  configure -text [lindex "{} ARC" $arc]
   .states.h  configure -text [lindex "{} HYP" $hyp]
 }
 #============================================================================
 # messagebox: display error or info
 #============================================================================
 proc messagebox {message} {
   if {[regexp error $message]} {
     set icon error
   } else {
     set icon info
   }
   tk_messageBox -message $message -parent . -icon $icon
 }
 #============================================================================
 # constant: constant toplevel
 #============================================================================
 proc constant {} {
   global constants SELECTION
   set top .constants
   catch {destroy $top}
   toplevel $top
   label          $top.title   -text    "select constant with <Double-Button-1>"
   scrollbar      $top.scrolly -command "$top.list yview" -orient vertical
   scrollbar      $top.scrollx -command "$top.list xview" -orient horizontal
   button         $top.cancel  -width 10 -text "cancel" \
                   -command "set SELECTION NULL;destroy $top"
   listbox        $top.list    -relief raised -height 15 -width 60 \
                   -yscroll "$top.scrolly set" -xscroll "$top.scrollx set" 
   pack           $top.title   -side top   -fill x
   pack           $top.cancel  -side top
   pack           $top.scrollx -side top   -fill x
   pack           $top.scrolly -side right -fill y
   pack           $top.list    -side left  -expand yes -fill both
   bind           $top.list <Double-Button-1> \
                  "set SELECTION \[selection get\];after 200;destroy $top"
   foreach constant $constants {
     $top.list insert end $constant
   }
   wm title       $top "constants"
   tkwait window  $top 
   return [lindex [string trim $SELECTION "{}"] 0]
 }
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 # calculator display
 #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 frame .display
 frame .states
 frame .buttons
 pack  .display -side top -fill x    -expand yes
 pack  .states  -side top -fill x    -expand yes
 pack  .buttons -side top -fill both -expand yes
 entry .display.e  -bd 2 -relief sunken -state disabled \
   -font -adobe-courier-bold-r-normal-*-14-* \
   -background GhostWhite -foreground black
 pack  .display.e -side top -padx 1 -pady 1 -expand yes -fill both 

 foreach state {a h d m s} {
   label .states.$state -width 4 \
     -background "steel blue" -foreground white
   pack  .states.$state -side left -fill x -expand yes
 }

 set brows [split $buttons "\n"]
 set nrows [expr [llength $brows]-2]
 set ncols [llength [lindex $brows 1]]
 set i -1
 foreach button $buttons buttoncommand $buttoncommands binding $bindings {
   incr i
   set x [expr ($i%$ncols)*1.0/$ncols]
   set y [expr ($i/$ncols)*1.0/$nrows]
   set w .buttons.$i
   if {$button == "MENU"} {
     menubutton $w -text $button -menu $w.m \
       -relief raised -pady 2 -padx 2 -highlightthickness 0 -bd 2
     menu $w.m -background red -foreground white
     foreach {label command} $menuentries {
       $w.m add command -label $label -command $command
     }
   } else {
     button $w -command [list $buttoncommand $button] \
       -pady 1 -padx 1 -highlightthickness 0 -bd 2
     if {[info exists Bitmap($button)]} {
       $w configure -image $Bitmap($button) -width 36 -height 16
     } else {
       $w configure -text $button -width 5 -height 1
     }
   }
   $w configure -font -adobe-helvetica-medium-r-normal-*-12-* \
     -background "dark khaki" -foreground black \
     -relief raised -highlightthickness 0 -bd 2
   place $w -relx $x -rely $y
   bind all <$binding> [list $buttoncommand $button]
 }

 update idletasks
 set W [winfo reqwidth  .buttons.0]
 set H [winfo reqheight .buttons.0]
 .buttons configure -width [expr $ncols*$W] -height [expr $nrows*$H]
 foreach window {all .display.e} {
   bind $window <Return>          "eq ="
   bind $window <space>           "eq ="
   bind $window <BackSpace>       "BS"
   bind $window <Delete>          "BS"
   bind $window <Double-Button-2> "STX \[selection get\]; eq ="
 }

 set _log 0
 AC AC
 tkwait window .
 exit 0