[0816]  daemon@ATHENA.MIT.EDU (richard.v.h.booth) Tcl_info 02/16/93 17:46 (266 lines)
Subject: calculator
Date: 16 Feb 93 15:28:50 GMT
From: pacbell.com!att-out!cbnewsj!booth@ames.arc.nasa.gov  (richard.v.h.booth)
To: tcl-from-news@allspice.Berkeley.EDU

Here is a simple TCL/TK calculator.  Does anyone have a nice drawing 
application?


#!/usr/local/bin/wish -f
#############################################################################
#
# TCL/TK CALCULATOR:
#
# AUTHOR: Richard Booth
# DATE:   Fri Feb 12 18:03:37 EST 1993
#
#############################################################################
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# initialize lists,globals
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
set BUTTONS {
  1/x  x^2  sqrt ce/c ac   \
  INV  sin  cos  tan  DRG  \
  M+   EE   log  ln   y^x  \
  M-   x!   (    )    /    \
  sto  7    8    9    *    \
  rcl  4    5    6    -    \
  mclr 1    2    3    +    \
  exch 0    .    +/-  =    \
  HELP stk? const pi  e    \
}
set BINDINGS { 
  o                   S           r           X           C           \
  i                   s           c           t           d           \
  Control-Key-p       e           L           l           asciicircum \
  Control-Key-m       f           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-c       Key-1       Key-2       Key-3       plus        \
  Control-Key-x       Key-0       period      asciitilde  equal       \
  H                   question    T           P           E           \
}
set W 40   ;# pixel reference width  of a button
set H 20   ;# pixel reference height of a button
set NROW 9 ;# number of button rows
set NCOL 5 ;# number of button cols
set PI   3.141592653
set E_   2.718281828
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)"
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# set up display
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
frame       .display -width [expr ($NCOL-1)*$W] -height [expr 2*$H]
frame       .buttons -width [expr ($NCOL)*$W]   -height [expr $NROW*$H]
frame       .states  
pack append . \
            .display {top fillx} \
            .states  {top fillx} \
            .buttons {top expand fill}
label       .display.e  -bd 5 -relief raised
pack append .display \
            .display.e {top padx 5 pady 5 expand fill} 
foreach B {i d m s} {pack append .states [label .states.$B -width 5] {left} }
for {set i 0} {$i<[llength $BUTTONS]} {incr i} {
  set B [lindex $BUTTONS  $i]
  set K [lindex $BINDINGS $i]
  set x [expr rint($i%$NCOL)/$NCOL]
  set y [expr rint($i/$NCOL)/$NROW]
  button    .buttons.$i -text $B -command "PUNCH $B" -width 5 -height 1
  place     .buttons.$i -relx $x -rely $y
  eval bind all <$K> \"PUNCH $B\"
}
bind all <Return>        "PUNCH ="
bind all <space>         "PUNCH ="
bind all <Control-Key-q> "destroy ."
#============================================================================
proc PUSH {token} {
#============================================================================
  global STK PTR
  incr   PTR
  set    STK($PTR) $token
}
#============================================================================
proc POP  {var} {
#============================================================================
  global STK PTR
  uplevel set $var $STK($PTR)
  if {$PTR>0} {set PTR [expr $PTR-1]}
}
#============================================================================
proc setx {expression} {
#============================================================================
  global x MODE
  set x [expr $expression]
  set MODE >
}
#============================================================================
proc setm {expression} {
#============================================================================
  global m MODE MEM
  set m [expr $expression]
  set MODE >
  set MEM  1
}
#============================================================================
proc PUNCH {key} {
#============================================================================
  global x m MEM INV DRG MODE STK PTR PI E_
  case $key {
  [0-9]  {if {$MODE==">"}             {set x ""      ;set MODE I}
          if {$MODE=="I"||$MODE=="F"} {set x $x$key}
          if {$MODE=="E"} {
            set L [string length $x]
            set e [string index  $x   [expr $L-1] ]
            set x [string range  $x 0 [expr $L-3] ]$e$key
         }} 
  .      {if {$MODE==">"}             {set x 0       ;set MODE I}
          if {$MODE=="I"}             {set x $x$key  ;set MODE F}}
  EE     {if {$MODE=="I"||$MODE=="F"} {set x ${x}E+00;set MODE E}}
  +/-    {if {$MODE!="E"} { 
            set x [expr -$x]
          } else {
            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
         }}
  ce/c   {setx 0}
  ac     {setx 0;set m 0;set PTR 0;set INV 0;set DRG 0;set MEM 0}
  pi     {setx $PI}
  e      {setx $E_}
  const  {set u [CONSTANT];if {$u!="NULL"} {setx $u}}
  1/x    {setx 1/$x}
  x^2    {setx $x*$x}
  sqrt   {setx sqrt($x)}
  x!     {if {$x>=0&&$x<=14} {
            for {set u [set i 1]} {$i<=$x} {incr i} {set u [expr $u*$i]};setx $u
          } else {
            puts stdout "factorial range error: x<0 or x>14"
         }}
  {sin 
   cos 
   tan}  {set f [lindex "[expr $PI/180] 1.0 [expr $PI/200]"  $DRG]
          if {!$INV} {setx ${key}($f*$x)} {setx a${key}($x)/$f;set INV 0} }
  log    {if {!$INV} {setx log10($x)    } {setx 10**($x)      ;set INV 0} }
  ln     {if {!$INV} {setx log($x)      } {setx exp($x)       ;set INV 0} }
  [-+]   {set e $x
          while {$PTR>0} {
            POP t;if {$t=="("}                 {PUSH $t;break};set e $t$e}
          setx $e;PUSH $x;PUSH $key}
  [*/]   {set e $x
          while {$PTR>0} {
            POP t;if {[string match [-+(] $t]} {PUSH $t;break};set e $t$e}
          setx $e;PUSH $x;PUSH $key}
  y^x    {PUSH $x;PUSH **;set MODE >}
  (      {if {$MODE==">"} {PUSH $key}}
  )      {set e $x$key;while {$PTR>0} {POP t;set e $t$e;if {$t=="("} {break}}
          setx $e}
  =      {set e $x;while {$PTR>0} {POP t;set e $t$e};setx $e}
  sto    {setm $x}
  rcl    {setx $m}
  M+     {setm $m+$x}
  M-     {setm $m-$x}
  exch   {set u $x;set x $m;setm $u}
  mclr   {set m 0;set MEM 0}
  INV    {set INV [expr !$INV]}
  DRG    {set DRG [expr ($DRG+1)%3]}
  stk?   {puts stdout "LOC: VALUE:"
          for {set i 1} {$i<=$PTR} {incr i} {puts stdout "$i: $STK($i)"} }
  HELP   {global BUTTONS BINDINGS
          set text "BUTTON:\tKEY-BINDING:\n"
          for {set i 0} {$i<[llength $BUTTONS]} {incr i} {
            set text "$text\t[lindex $BUTTONS $i]\t\t[lindex $BINDINGS $i]\n"
          }
          set text "$text\t=\t\t<Return>\n"
          set text "$text\t=\t\t<space>\n"
          set text "$text\tquit\t\t<Control-Key-q>\n"
          MESSAGE $text
         }
  } ;# end case
  .display.e configure -text $x -anchor e
  .states.d  configure -text [lindex "DEG RAD GRD" $DRG]
  .states.i  configure -text [lindex "{} INV" $INV]
  .states.m  configure -text [lindex "{} MEM" $MEM]
  .states.s  configure -text $MODE
} ;# end proc
#==============================================================================
proc MESSAGE {text} {
# print error messages, etc.
#==============================================================================
  set top .message
  catch {destroy $top}
  toplevel       $top
  frame          $top.text        -borderwidth 2 -relief raised
  message        $top.text.msg    -justify left -aspect 400 -text $text
  pack append    $top.text \
                 $top.text.msg {top expand fillx}
  frame          $top.cntl        -borderwidth 2 -relief raised
  frame          $top.cntl.button -borderwidth 2 -relief sunken
  button         $top.cntl.button.ok -text "ok" -command "destroy $top"
  pack append    $top.cntl.button \
                 $top.cntl.button.ok {frame c}
  pack append    $top.cntl \
                 $top.cntl.button {frame c padx 10 pady 10}
  pack append    $top \
                 $top.text {top fillx} \
                 $top.cntl {top fillx}
  wm title       $top "MESSAGE BOX"
  wm geometry    $top "+[expr [winfo width .]+[winfo rootx .]]+[winfo rooty .]"
  tkwait window  $top
}
#============================================================================
proc CONSTANT {} {
# constant toplevel
#============================================================================
  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 -geometry 60x15 \
                              -yscroll "$top.scrolly set" \
                              -xscroll "$top.scrollx set" \
  -font -adobe-courier-bold-r-normal--14-100-100-100-m-90-iso8859-1
# or some other constant-width font
  pack append    $top \
                 $top.title   {top   fillx} \
                 $top.cancel  {top} \
                 $top.scrollx {top   fillx} \
                 $top.scrolly {right filly} \
                 $top.list    {left expand fill}
  bind           $top.list <Double-Button-1> \
                 "set SELECTION \[selection get\];destroy $top"
  focus          $top.list
  for {set i 0} {$i<=[llength $CONSTANTS]} {incr i} {
    $top.list insert end [lindex $CONSTANTS $i]
  }
  wm title       $top "CONSTANTS"
  wm geometry    $top "+[expr [winfo width .]+[winfo rootx .]]+[winfo rooty .]"
  grab           $top 
  focus          $top 
  tkwait window  $top 
  return [lindex [string trim $SELECTION "{}"] 0]
}
#============================================================================
# initialize
#============================================================================
wm geometry . +1+1 ;# or other convenient location
PUNCH ac
--[0816]--