Updated 2012-07-21 16:33:07 by RLE ▲

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

See also:

Category CalculatorCategory GUICategory MathematicsCategory Application