#!/bin/csh -f
#\
exec wish -f $0 $*
#############################################################################
# NAME    : calculator
# PURPOSE : Tcl/Tk calculator
# AUTHOR  : Richard Booth 
#           rvbooth@lucent.com (610)712-2324
# DATE    : Sat Dec 20 22:09:05 EST 1997
# --------------------------------------------------------------------------
# NOTES :
#   * Tcl/Tk version 7.4/4.0
#   * calculator release 1.1
#############################################################################
#============================================================================
# globals
#============================================================================
set LOGFID "";# logging file id to file calc.tk.log
set NROW 10  ;# number of button rows
set NCOL 5   ;# number of button cols
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 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 {
  {"list stack"          "PUNCH stk?"}
  {"fixed rate mortgage" "mort"      }
  {"compound interest"   "compound"  }
  {"set precision"       "PUNCH 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 up calculator display
#============================================================================
foreach spec {
  {Background AntiqueWhite3 }
  {Foreground black }
  {activeForeground black }
  {activeBackground white }
  {Entry.Background GhostWhite }
  {Entry.highlightBackground gray }
  {ListBox.Background GhostWhite }
  {Menu.background red}
  {Menu.foreground white}
  {Label.background "steel blue"}
  {Label.foreground white}
  {Button.background "dark khaki"}
  {Button.borderWidth 2}
  {Button.highlightThickness 0}
  {Button.relief raised}
  {Menubutton.background "dark khaki"}
  {Menubutton.borderWidth 2}
  {Menubutton.highlightThickness 0}
  {Menubutton.relief raised}
  {Entry.font      -adobe-courier-bold-r-normal-*-14-*}
  {Message.font    -adobe-courier-bold-r-normal-*-14-*}
  {Listbox.font    -adobe-courier-bold-r-normal-*-14-*}
  {Button.font     -adobe-helvetica-medium-r-normal-*-12-*}
  {Menubutton.font -adobe-helvetica-medium-r-normal-*-12-*}
} {
  set option [lindex $spec 0]
  set value  [lindex $spec 1]
  eval option add *$option \"$value\" widgetDefault
}
wm withdraw .
pack [frame .display] \
  -side top -fill x
pack [frame .states] \
  -side top -fill x
pack [frame .buttons] \
  -side top -fill both -expand yes
pack [entry .display.e  -bd 2 -relief sunken -state disabled] \
  -side top -fill both -expand yes -padx 1 -pady 1
foreach state {a h d m s} {
  pack [label .states.$state -width 4] \
    -side left -fill x -expand yes
}
set i -1
foreach button $buttons {
  incr i
  set binding [lindex $bindings $i]
  set x [expr ($i%$NCOL)*1.0/$NCOL]
  set y [expr ($i/$NCOL)*1.0/$NROW]
  if {$button=="MENU"} {
    menubutton .buttons.$i -text $button -menu .buttons.$i.menu \
      -padx 2 -pady 2 -width 5 -height 1
    menu .buttons.$i.menu 
    foreach entry $menuentries {
      .buttons.$i.menu add command \
        -label   [lindex $entry 0] \
        -command [lindex $entry 1]
    }
  } else {
    button .buttons.$i -text $button -command [list PUNCH $button] \
      -padx 1 -pady 1 -width 5 -height 1
  }
  place .buttons.$i -relx $x -rely $y
  bind . <$binding> "PUNCH $button"
}
update idletasks
set wid [winfo reqwidth  .buttons.0]
set hgt [winfo reqheight .buttons.0]
.buttons configure -width [expr $wid*$NCOL] -height [expr $hgt*$NROW]
wm deiconify .
foreach w {. .display.e} {
  bind $w <Return>          {PUNCH =}
  bind $w <space>           {PUNCH =}
  bind $w <BackSpace>       {PUNCH BS}
  bind $w <Delete>          {PUNCH BS}
  bind $w <Double-Button-2> {STX [selection get];PUNCH =}
}
#============================================================================
# LOG: toggle logging
#============================================================================
proc LOG {} {
  global LOGFID
  set LOGFILE calc.tk.log
  if {$LOGFID==""} {
    if {[catch {set LOGFID [open $LOGFILE w]}]} {
      message-box "ERROR OPENING LOGGING FILE $LOGFILE"
      set LOGFID ""
    } else {
      message-box "LOGGING FILE $LOGFILE OPENED"
    }
  } else {
    catch {close $LOGFID}
    message-box "LOGGING FILE $LOGFILE CLOSED"
    set LOGFID ""
  } 
}
#============================================================================
# PSH: push token on stack
#============================================================================
proc PSH {token} {
  global STK PTR
  incr PTR
  set STK($PTR) $token
}
#============================================================================
# POP: pop token from stack
#============================================================================
proc POP {var} {
  global STK PTR 
  upvar $var V
  set V $STK($PTR)
  if {$PTR>0} {
    incr PTR -1
  }
}
#============================================================================
# STX: set x to expression
#============================================================================
proc STX {expression} {
  global x MODE LOG_ LOGFID
  set x [expr $expression]
  set MODE >
  if {$LOGFID!=""} {
    puts $LOGFID "$expression: $x"
    flush $LOGFID
  }
}
#============================================================================
# STM: set memory to expression
#============================================================================
proc STM {expression} {
  global m MODE MEM
  set m [expr $expression]
  set MODE >
  set MEM  1
}
#============================================================================
# PTX: put decimal point on end of x if still in integer mode before further
# processing
#============================================================================
proc PTX {} {
  global MODE x
  if {$MODE=="I"} {
    append x .
    set MODE F
  }
}
#============================================================================
# POW: process powers in stack (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) " "
      set STK($k) " "
    }
  }
}
#============================================================================
# PUNCH: process calculator keys
#============================================================================
proc PUNCH {key} {
  global x m MEM ARC HYP DRG MODE STK PTR constants tcl_precision
  switch -glob -- $key {
    [0-9] {
      switch -- $MODE {
        > {
          set MODE I
          set x $key
        }
        I -
        F {
          append x $key
        }
        E -
        X {
          set L [string length $x]
          set e [string index  $x   [expr $L-1]]
          set x [string range  $x 0 [expr $L-3]]$e$key
          set MODE X
        }
      }
    } 
    . {
      switch -- $MODE {
        > {
          set MODE F
          set x 0.
        }
        I {
          set MODE F
          append x .
        }
      }
    }
    EE {
      switch -- $MODE {
        I -
        F {
          set MODE E
          append x E+00
        }
      }
    }
    +/- {
      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 L [string length $x]
          set s [string index  $x  [expr $L-3] ]
          if {$s=="+"} {
            set s -
          } else {
            set s +
          }
          set M [string range $x 0 [expr $L-4] ] 
          set E [string range $x   [expr $L-2] end]
          set x  $M$s$E
        }
      }
    }
    BS {
      if {$MODE!=">"} {
        set L [string length $x]
        if {$L==1} {
          set MODE >
          set x 0
        } else {
          if {$MODE=="X"||$MODE=="E"} {
            if {[string first "." $x]>0} {
              set MODE F
            } else {
              set MODE I
            }
            set x [string range $x 0 [expr $L-5] ]
          } else {
            set c [string index $x [expr $L-2]]
            if {$MODE=="F"} {
              if {$c=="."} {
                set MODE I
                set x [string range $x 0 [expr $L-3] ]
              } else {
                set x [string range $x 0 [expr $L-2] ]
              }
            } else {
              if {$c=="+"||$c=="-"} {
                set MODE >
                set x 0
              } else {
                set x [string range $x 0 [expr $L-2]]
              }
            }
          }
        }
      }
    }
    OFF {
      destroy .
      return
    }
    CE {
      STX 0
    }
    AC {
      STX 0
      set m 0
      set PTR 0
      set ARC 0
      set HYP 0
      set DRG 0
      set MEM 0
      set tcl_precision 16
    }
    pi {
      STX [expr atan(1)*4]
    }
    e {
      STX [expr exp(1)]
    }
    const {
      set u [constant]
      if {$u!=""} {
        STX $u
      }
    }
    put {
      lappend constants $x
    }
    1/x {
      PTX
      if {$x==0} {
        message-box "error: x=0"
      } else {
        STX 1.0/$x
      }
    }
    x^2 {
      PTX
      STX $x*$x
    }
    sqrt {
      PTX
      if {$x<0} {
        message-box "error: x<0"
      } else {
        STX sqrt($x)
      }
    }
    x! {
      PTX
      if {$x<0||$x>180} {
        message-box "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
      }
    }
    sin -
    cos -
    tan {
      PTX
      set pi [expr atan(1)*4]
      set f [lindex "[expr $pi/180.0] 1.0 [expr $pi/200.0]" $DRG]
      if {!$HYP} {
        if {!$ARC} {
          STX [expr ${key}($f*$x)]
        } else {
          STX [expr a${key}($x)/$f]
        }
      } else {
        if {!$ARC} {
          STX [expr ${key}h($x)]
        } else {
          STX [a${key}h $x]
        }
      }
      set HYP 0
      set ARC 0
    }
    log {
      PTX
      if {$x<=0} {
        message-box "error: x<=0"
      } else {
        STX log10($x)
      }
    }
    ln {
      PTX
      if {$x<=0} {
        message-box "error: x<=0"
      } else {
        STX log($x)
      }
    }
    10^x {
      PTX
      STX pow(10.0,$x)
    }
    exp {
      PTX
      STX exp($x)
    }
    [-+] {
      if {$MODE=="E"} {
        set L [string length $x]
        set M [string range $x 0 [expr $L-4] ]
        set E [string range $x   [expr $L-2] end]
        set x  $M$key$E
      } else {
        PTX
        PSH $x
        POW
        set e ""
        while {$PTR>0} {
          POP t
          if {$t=="("} {
            PSH $t
            break
          }
          set e $t$e
        }
        STX $e
        PSH $x
        PSH $key
      }
    }
    [*/] {
      PTX
      PSH $x
      POW
      set e ""
      while {$PTR>0} {
        POP t
        if {[string match \[-+(\] $t]} {
          PSH $t
          break
        }
        set e $t$e
      }
      STX $e
      PSH $x
      PSH $key
    }
    y^x {
      PTX
      PSH $x
      PSH **
      set MODE >
    }
    ( {
      if {$MODE==">"} {
        PSH $key
      }
    }
    ) {
      PTX
      PSH $x
      POW
      set e ""
      while {$PTR>0} {
        POP t
        if {$t=="("} {
          break
        }
        set e $t$e
      }
      STX $e
    }
    = {
      PTX
      PSH $x
      POW
      set e ""
      while {$PTR>0} {
        POP t
        set e $t$e
      }
      STX $e
    }
    RCL {
      STX $m
    }
    STO {
      PTX
      STM $x
    }
    M+ {
      PTX
      STM $m+$x
    }
    M- {
      PTX
      STM $m-$x
    }
    XCH {
      set u $x
      set x $m
      STM $u
    }
    CLR {
      set m 0
      set MEM 0
    }
    ARC {
      set ARC [expr !$ARC]
    }
    HYP {
      set HYP [expr !$HYP]
    }
    DRG {
      set DRG [expr ($DRG+1)%3]
    }
    PREC {
      if {$x<1||$x>=18} {
        message-box "error: x<1 or x>=18"
      } else {
        set p [expr int($x)]
        set tcl_precision $p
        message-box "PRECISION = $p"
      }
    }
    stk? {
      set text "LOC:\tVALUE:\nX:\t$x\n"
      for {set i $PTR} {$i>0} {incr i -1} {
        append text "$i:\t$STK($i)\n"
      } 
      message-box $text
    }
    HELP {
      global buttons bindings
      set buts $buttons
      set bnds $bindings
      lappend buts = =
      lappend bnds <Return> <space>
      set text ""
      append text [format "%-10s %-9s  |  " button: binding:]
      append text [format "%-10s %-9s  |  " button: binding:]
      append text [format "%-10s %-9s\n"    button: binding:]
      append text "======================|=="
      append text "======================|=="
      append text "======================\n"
      set i -1
      foreach button $buts {
        incr i
        set binding [lindex $bnds $i]
        append text [format "%5s %-14s" $button $binding]
        if {$i%3==2} {
          append text "\n"
        } else {
          append text "  |  "
        }
      }
      message-box $text
    }
  }
  .display.e configure -state normal
  .display.e delete 0 end
  .display.e insert end $x
  .display.e configure -state disabled
  .states.d  configure -text [lindex "DEG RAD GRD" $DRG]
  .states.a  configure -text [lindex "{} ARC" $ARC]
  .states.h  configure -text [lindex "{} HYP" $HYP]
  .states.m  configure -text [lindex "{} MEM" $MEM]
  .states.s  configure -text $MODE
}
#============================================================================
# additional 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 {
  return [expr log(sqrt((1.0+$u)/(1.0-$u)))]
}
#==============================================================================
# message-box: print messages
#==============================================================================
proc message-box {text} {
  set win .message
  catch {destroy $win}
  toplevel $win
  pack [frame $win.text -bd 2 -relief raised] \
    -side top -fill x
  pack [frame $win.cntl -bd 2 -relief raised] \
    -side top -fill x
  pack [message $win.text.msg -justify left -aspect 400 -text $text] \
    -side top -expand yes -fill x
  pack [frame $win.cntl.button -bd 2 -relief sunken] \
    -side top
  pack [button $win.cntl.button.ok -text "ok" -command "destroy $win"] \
    -side top -padx 10 -pady 10
  wm title $win "message"
  wm geometry    $win "+[winfo rootx .]+[winfo rooty .]"
  update
  focus $win
  tkwait window  $win 
  focus .
}
#============================================================================
# constant: constant selection
#============================================================================
proc constant {} {
  global constants selection
  set win .constants
  catch {destroy $win}
  toplevel $win
  pack [label $win.title -text "select constant with <Double-Button-1>"] \
    -side top -fill x
  pack [button $win.cancel  -width 10 -text "cancel" \
    -command "set selection {};destroy $win" ] \
    -side top
  pack [scrollbar $win.scrollx -command "$win.list xview" -orient horizontal] \
    -side top -fill x
  pack [scrollbar $win.scrolly -command "$win.list yview" -orient vertical] \
    -side right -fill y
  pack [listbox $win.list    -relief raised -height 15 -width 60 \
    -yscroll "$win.scrolly set" -xscroll "$win.scrollx set" ] \
    -side left -expand yes -fill both
  regsub -all -- WIN {
    set selection [selection get]
    after 200
    destroy WIN
  } $win cmd
  bind $win.list <Double-Button-1> $cmd
  foreach constant $constants {
    $win.list insert end $constant
  }
  wm title $win "constants"
  update
  focus $win
  tkwait window  $win 
  focus .
  return [lindex $selection 0]
}
#==============================================================================
# mort: fixed-rate mortgage calculator
#==============================================================================
proc mort {} {
  global mortInfo
  set win .mort
  set title "fixed rate mortgage"
  catch {destroy $win}
  toplevel $win
  pack [frame $win.text -bd 2 -relief raised] \
    -side top -expand 1 -fill x
  pack [frame $win.pars -bd 2 -relief raised] \
    -side top -expand 1 -fill both
  pack [message $win.text.msg -justify center -text $title] \
    -side left -expand 1 -fill x
  pack [button  $win.text.but -text quit] \
    -side left -padx 10 -pady 10 -expand 1 -fill x
  $win.text.msg configure -aspect 800
  $win.text.but configure -command "destroy $win"
  foreach parameter {
    {principal Principal 100000}
    {years Years 30}
    {rate "Rate (%)" 8.00}
    {payments_year "Payments per year" 12}
    {payment Payment 733.76}
  } {
    set name  [lindex $parameter 0]
    set label [lindex $parameter 1]
    set value [lindex $parameter 2]
    lappend mortInfo($win-names) $name
    pack [frame $win.pars.$name] \
      -side top
    pack [label $win.pars.$name.l -text $label] \
      -side left -padx 5 -pady 5
    pack [entry $win.pars.$name.e] \
      -side right -padx 5 -pady 5
    $win.pars.$name.l configure -width 20 -bg "slate blue" -fg black
    $win.pars.$name.e configure -width 20 -bg "wheat" -relief sunken
    $win.pars.$name.e insert 0 $value
    bind $win.pars.$name.e <Return> "mort:recalculate $win $name"
  }
  wm title $win $title
  update
  focus $win
  tkwait window $win
  focus .
}
#==============================================================================
# mort:recalculate : mortgage recalculation
#==============================================================================
proc mort:recalculate {win name} {
  global mortInfo
  foreach parameter $mortInfo($win-names) {
    set $parameter [$win.pars.$parameter.e get]
  }
  switch -- $name {
    principal -
    years -
    rate -
    payments_year {
      set a            [expr 1.0E-2*$rate/$payments_year]
      set n            [expr 1.0*$payments_year*$years]
      set per_thousand [expr 1.0E+3*$a/(1-pow(1+$a,-$n))]
      set payment      [format "%-10.2f" [expr 1.0E-3*$principal*$per_thousand]]
    }
    payment {
      set a            [expr 1.0E-2*$rate/$payments_year]
      set n            [expr 1.0*$payments_year*$years]
      set per_thousand [expr 1.0E+3*$a/(1-pow(1+$a,-$n))]
      set principal    [format "%-10.2f" [expr 1.0E+3*$payment/$per_thousand]]
    }
    default {
      puts "huh?"
    }
  }
  foreach parameter $mortInfo($win-names) {
    $win.pars.$parameter.e delete 0 end
    $win.pars.$parameter.e insert 0 [set $parameter]
  }
}
#==============================================================================
# compound: compound interest calculations
#==============================================================================
proc compound {} {
  global compInfo
  set win .comp
  set title "compound interest"
  catch {destroy $win}
  toplevel $win
  pack [frame   $win.text -bd 2 -relief raised] \
    -side top -expand 1 -fill x
  pack [frame   $win.pars -bd 2 -relief raised] \
    -side top -expand 1 -fill x
  pack [message $win.text.msg -justify center -text $title] \
    -side left -expand 1 -fill x
  pack [button  $win.text.but -text quit] \
    -side left -padx 10 -pady 10 -expand 1 -fill x
  $win.text.msg configure -aspect 800
  $win.text.but configure -command "destroy $win"
  foreach parameter {
    {starting_balance "Starting Balance" 100000}
    {years "Years" 30}
    {rate  "Rate (%)" 4.0}
    {monthly_payment "Monthly Payment" 200}
    {yearly_payment "Yearly Payment" 1000}
    {comp1 "Starting balance compounded" 0}
    {comp2 "Monthly payment compounded" 0}
    {comp3 "Yearly payment compounded" 0}
    {ending_balance "Ending Balance" 0}
  } {
    set name  [lindex $parameter 0]
    set label [lindex $parameter 1]
    set value [lindex $parameter 2]
    lappend compInfo($win-names) $name
    pack [frame $win.pars.$name] \
      -side top
    pack [label $win.pars.$name.l -text $label] \
      -side left -padx 5 -pady 5
    pack [entry $win.pars.$name.e] \
      -side right -padx 5 -pady 5
    $win.pars.$name.l configure -width 20 -bg "slate blue" -fg black
    $win.pars.$name.e configure -width 20 -bg "wheat" -relief sunken
    $win.pars.$name.e insert 0 $value
    bind  $win.pars.$name.e <Return> "comp:recalculate $win $name"
  }
  wm title $win $title
  update 
  focus $win
  tkwait window $win
  focus .
}
#==============================================================================
# comp:recalculate : compound interest recalculation
#==============================================================================
proc comp:recalculate {win name} {
  global compInfo
  foreach parameter $compInfo($win-names) {
    set $parameter [$win.pars.$parameter.e get]
  }
  switch -- $name {
    starting_balance -
    years -
    rate -
    monthly_payment -
    yearly_payment {
      set a  [expr 0.01*$rate/12.0]
      set an [expr pow(1.0+$a,$years*12.0)]
      set A  [expr 0.01*$rate]
      set AN [expr pow(1.0+$A,$years)]
      set comp1 [expr 1.0*$starting_balance*$an]
      set comp2 [expr 1.0*$monthly_payment*($an-1)/$a]
      set comp3 [expr 1.0*$yearly_payment*($AN-1)/$A]
      set comp1 [format "%-10.2f" $comp1]
      set comp2 [format "%-10.2f" $comp2]
      set comp3 [format "%-10.2f" $comp3]
      set ending_balance [expr $comp1+$comp2+$comp3]
      set ending_balance [format "%-10.2f" $ending_balance]
    }
    default {
      puts "huh?"
    }
  }
  foreach parameter $compInfo($win-names) {
    $win.pars.$parameter.e delete 0 end
    $win.pars.$parameter.e insert 0 [set $parameter]
  }
}
#============================================================================
# initialize
#============================================================================
PUNCH AC
