#!/usr/bin/env wish
# Calculator: A Desktop Calculator.
#
# BSD Copyright 2005 - Peter MacDonald.   (See http://pdqi.com/)
# $Id$

image create photo image:calc -data {\
R0lGODlhEAAVAKUAAAICBI7+/Hr29HLy7F7q5E7i3ELa3DrW1DLS1CbOzBbG
xArCxAK+vIb69AaalAaWlAaSjAJCRAJmZHr+fALCxGru7AaOjAKKhMbKxL6+
vLKytL6+xFZWVEZGRHJydAKGhDIyNAKChB7KzMrKxMrKzAJ+fP7CxOaurNKe
nP4CBFYiJP//////////////////////////////////////////////////
/////////////////////////////////yH5BAEKAD8ALAAAAAAQABUAAAa4
wB9gSCwWhQGBYEAoFAwHREKxYAwbjoc2+3BwIZGhwBEpm80S8HDwCAMm7/eE
ogZU2sQJ/M2wuAlkRXB6FH5DBQ8SDIuMjBduBVxaEJQQFhaPQwYOGBkaGBsa
n56ZAAcPGRwdqR6rqh9uCRAdIAC0Q7chbiIQI54knhrAGrpDChaprq3JJW59
t7e2tc1DDBe+GtgaJico1ADWyawdJykq3wwf0LUAKkPoIfEl8/T0bmf4Z0NC
Rv37QQA7}

namespace eval ::lib::calculator {
  variable _
  variable Opts {
    { -trace	0	"Trace debugging flag"}
    { -oneshot	0	"One shot"}
    { -command	{}	"Command to callback with result"}
    { -parent	{}	"Parent window"}
    { -value	{}	"Value to initialize window with."}
    { -simple	0	"Simple calculator, no scientific"}
    { -toplevel	{}	"Toplevel widget."}
    { -bg	{} }
  }

  variable pc
  array set pc [list app calculator App {Calculator} version 1.0]
  set pc(copymsg) "$pc(App) $pc(version)\nBSD Copyright 2003\nPeter MacDonald\nhttp://pdqi.com/\npeter@pdqi.com"
  set pc(exprcmds) { abs acos asin atan ceil cos cosh double exp floor int log log10 pow rand round sin sinh sqrt srand tan tanh}
  array set pc [list pi [expr {atan(1)*4}] e [expr {exp(1)}]]

  set pc(buttons) {
    {MENU   pi e    CE AC  }
    {HEX  DEC  OCT   BIN   DGR }
    {ARC HYP cos sin tan }
    {abs ceil double exp floor}
    {int log log10 rand round}
    {sqrt srand EE & | }
    {1/x y^x   x!    10^x x^2   }
    {M+   <<   >>    ~    ^   }
    {M-   (    )     %    /   }
    {STO  7    8     9    *   }
    {RCL  4    5     6    -   }
    {XCH  1    2     3    +   }
    {CLR  0    .     +/-  =   }
  }

  set pc(bindings) { 
    {M  {} {}  I R }
    {Alt-h Alt-d  Alt-o Alt-b d}
    {A H Alt-C Alt-S Alt-T}
    {Control-A Control-C Control-D Control-E Control-F}
    {Control-I Control-L Control-1 {} Control-R}
    {Control-S {} colon ampersand bar}
    {Control-slash Control-asciicircum Control-exclam Control-R Control-r}
    {Control-p  less greater asciitilde asciicircum}
    {Control-m  parenleft  parenright  percent slash       }
    {Control-s  Key-7     Key-8      Key-9       asterisk    }
    {Control-r  Key-4     Key-5      Key-6       minus       }
    {Control-x  Key-1     Key-2      Key-3       plus        }
    {Control-c  Key-0     period     {}  equal       }
  }

  set pc(menuentries) {
    {"About"            "about"       }
    {"Help"             "showdoc"       }
    {"Close"            "close"       }
  }
  set pc(widx) 0

  set pc(help) \
{Wiz Calculator

Wiz Calculator is simply a Tk interface to Tcl "expr" command.

Non-obvious key/mouse bindings are are as follows:

KEY         BUT    FUNCTION  
----------------------------------
 R          AC     Clear All/Reset  
 I          CE     Clear Input  
 M          MENU   Popup menu.  
 :          EE     Enter exponent.  
 G          DGR    Switch between Degrees, minutes seconds.  
 <          <<     Shift left binary value.  
 >          >>     Shift right binary value.  
 Control-p  M+     Add to memory.  
 Control-m  M-     Subtract from memory.  
 Control-s  STO    Store to memory.  
 Control-r  RCL    Recall memory.  
 Control-x  XCH    Exchange memory.  
 Control-c  CLR    Clear memory.  
 Alt-h      HEX    Convert to hex.  
 Alt-d      DEC    Convert to decimal.  
 Alt-o      OCT    Convert to octal.  
 Alt-b      BIN    Convert to binary.  
 Alt-s      sin  
 Alt-c      cos  
 Alt-t      tan  
 Control-A  abs  
 Control-C  ceil  
 Control-D  double  
 Control-E  exp  
 Control-F  floor  
 Control-I  int  
 Control-L  log  
 Control-1  log10  
 Control-R  round  
 Control-S  sqrt 
}
 
 

  proc init {} {}

  proc new {__ args} {
    variable pc
    upvar $__ pv
    foreach i [array names pc -*] { set p($i) $pc($i) }
    array set pv $args
    if {$pv(-toplevel) != {}} {
      if {$pv(-toplevel) == {.}} { set w {}; set tl .}
    } else {
      toplevel [set pv(-toplevel) .calculator[set n [incr pc(widx)]]]
      set w [set tl $pv(-toplevel)]
    }
    set pv(base) $tl
    wm protocol [winfo toplevel $pv(base)] WM_DELETE_WINDOW "$__ close"
    array set pv {num 0 stack {} error 0 mem 0 stackvar {} evaled 1}
    if {$pv(-parent) != {}} {
      catch {wm transient $w $pv(-parent)} 
    }          
    wm title $tl $pc(App)
    pack [frame $w.display] -side top -fill x
    pack [frame $w.states] -side top -fill x
    entry $w.display.e  -bd 2 -relief sunken -state disabled -textvariable ${__}(num)
    catch { $w.display.e conf -disabledforeground black -disabledbackground white}
    pack $w.display.e -side top -fill both -expand yes -padx 1 -pady 1
    foreach state {e h a d} {
      pack [label $w.states.$state -width 1 -textvariable ${__}(state:$state) -relief sunken] -side right -fill x
      set pv(state:$state) {}
    }
    set pv(state:d) D
    pack [label $w.states.stack -textvariable ${__}(stackvar) -relief sunken] -side left -fill x -expand y
    #update
    bind $tl <Return>	"$__ ="
    bind $tl <space>	"$__ ="
    bind $tl <BackSpace>	"$__ bs"
    bind $tl <Delete>	"$__ bs"
    bind $tl <Up>		"$__ histmove -1"
    bind $tl <Down>	"$__ histmove 1"
    bind $tl <2>	"$__ paste"
    pack [frame $w.buttons] -side top -fill both -expand yes
    set r -1
    set i -1
    foreach button $pc(buttons) binding $pc(bindings) {
      incr r
      if {$pv(-simple) && $r >= 1 && $r<=6} continue
      set c -1
      foreach but $button bind $binding {
        incr c
        incr i
        if {[string equal MENU $but]} {
          menubutton $w.buttons.$i -text $but -menu $w.buttons.$i.menu -relief raised -bd 2
  	  set pv(menubutton) $w.buttons.$i
  	  set pv(menu) $w.buttons.$i.menu
          menu $w.buttons.$i.menu 
          foreach entry $pc(menuentries) {
  	  foreach {mlbl mcmd} $entry break
            $w.buttons.$i.menu add command -label $mlbl -command "$__ $mcmd" -underline 0
          }
        } else {
          button $w.buttons.$i -text $but -command [list $__ $but] -padx 2 -pady 0 -width 5 -height 1
        }
        if {$pv(-bg) != {}} {
          $w.buttons.$i conf -bg $pv(-bg)
        }
        grid conf $w.buttons.$i -column $c -row $r -sticky news
        if {$bind != {}} {
          bind $tl <$bind> "$__ $but"
        }
      }
    }
    foreach bind {a b c d e f x} {
      bind $tl <Key-$bind> "$__ $bind"
    }
    if {$pv(-command) != {}} {
      bind $pv(base) <Escape> "$__ close"
    }
    if {$pv(-value) != {}} {
      set pv(num) $pv(-value)
    }
  }
  
  proc __ {__ args} {
    upvar $__ pv
    variable pc
    foreach {cmd _a1} $args break
    switch -- $cmd {
      close {
        catch {destroy $pv(base)}
        unset pv
        return
      }
      CE {
        set pv(error) 0
        set pv(num) 0
        set pv(evaled) 1
        return
      }
      AC {
        foreach s {e h a} { set pv(state:$s) {} }
        set pv(state:d) D
        set pv(error) 0
        set pv(num) 0
        set pv(stack) {}
        set pv(stackvar) {}
        catch {unset pv(pow)}
        return
      }
      MENU {
        set w $pv(menubutton)
        set x [winfo rootx $w]
        set y [winfo rooty $w]
        incr y [winfo height $pv(menubutton)]
        tk_popup $pv(menu) $x $y
        return
      }
      bs {
        if {![string length $pv(num)]} {
          set send [expr {[llength $pv(stack)]-2}]
          set slast [lindex $pv(stack) end]
          set pv(stack) [lrange $pv(stack) 0 $send]
          set pv(stackvar) [join $pv(stack) {}]
          if {[string length $slast] == 1} return
          set pv(num) $slast
        }
        set pv(num) [string range $pv(num) 0 [expr {[string length $pv(num)]-2}]]
        set pv(evaled) 0
        return
      }
    }
    if {$pv(error)} {
      bell
      return
    }
    set match 1
    switch -- $cmd {
      about {
        tk_messageBox -type ok -message $pc(copymsg) -parent $pv(base)
      }
      showdoc {
        toplevel [set w $pv(base)help[set n [incr pc(widx)]]]
        catch {wm transient $w $pv(base)}
        wm title $w "$pc(App): Calculator Help"
        pack [scrollbar $w.s -command "$w.t yview"] -fill y -side right
        pack [text $w.t -yscrollc "$w.s set" -wrap word] -fill both -expand y -side right
        $w.t insert end $pc(help)
        bind $w <Escape> "destroy $w"
      }
      HYP - ARC - EE {
        set c [string index $cmd 0]
        set s [string tolower $c]
        if {$pv(state:$s) == $c} { set pv(state:$s) {} } else { set pv(state:$s) $c }
        if {$cmd == {EE}} {
  	set pp [string first . $pv(num)]
          $__ eval
          if {$pp>=0} {
            set pv(num) [format %e $pv(num)]
  	} else {
  	  set pv(num) [expr {int($pv(num))}]E+
  	}
        }
      }
      DGR {
        switch $pv(state:d) {
          D { set pv(state:d) G }
          G { set pv(state:d) R }
          R { set pv(state:d) D }
        }
      }
      pi { set pv(num) $pc(pi) }
      OOOOe { set pv(num) $pc(e) }
      eval {
        if {$pv(num) != {}} { lappend pv(stack) $pv(num) }
        if {[catch {expr double([join $pv(stack) {}])} rc]} {
  	return [$__ err $rc]
        }
        set pv(num) $rc
        set pv(stack) {}
        set pv(stackvar) {}
      }
      Eval {
        if {$pv(num) != {}} { lappend pv(stack) $pv(num) }
        set rc [expr double([join $pv(stack) {}])]
        set pv(num) {}
        set pv(stack) {}
        set pv(stackvar) {}
        return $rc
      }
      err {
          tk_messageBox -type ok -message [join $args {}]
      }
      error {
  #      set pv(num) ERROR
  #      set pv(stack) {}
  #      set pv(stackvar) {}
        # set pv(error) 1
        puts "ERROR: $args\n$::errorInfo"
        tk_messageBox -type ok -message [join $args {}]
      }
      % - & - | - ^ {
        if {$pv(num) != {}} {
          $__ stack [expr {int($pv(num))}]
  	set pv(num) {}
        }
        $__ stack $cmd
      }
      stack {
        lappend pv(stack) $_a1
        set pv(stackvar) [join $pv(stack) {}]
      }
      _x! - _10^x {
        foreach {cmd sub n lst} $args break
        set m $n
        if {[string equal 10^x $sub]} {
  	set m 10
        }
        if {$lst == {}} {
          set lst $m
        } else {
          append lst *$m
        }
        if {[incr n -1]>0} {
          return [$__ $cmd $sub $n $lst]
        }
        if {[catch {expr $lst} rc]} {
  	return [$__ err $n]
        }
        return $rc
      }
      STO { set pv(mem) $pv(num); set pv(state:m) MEM }
      M+  { set pv(mem) [expr {$pv(mem)+$pv(num)}]; set pv(state:m) MEM }
      M-  { set pv(mem) [expr {$pv(mem)-$pv(num)}]; set pv(state:m) MEM }
      XCH { set x $pv(mem); set pv(mem) $pv(num); set pv(num) $x; set pv(state:m) MEM }
      RCL { set pv(num) $pv(mem); set pv(state:m) MEM }
      CLR { set pv(mem) 0; set pv(state:m) {} }
      + - - - * - / - ( - ) - | - & {
        if {$cmd == {-} && $pv(stack) == {}} {
          append pv(num) $cmd
  	return
        }
        if {$pv(num) != {}} {
          if {$cmd == {/} && [string is integer $pv(num)]} {
  	  append pv(num) .
  	}
          $__ stack $pv(num)
  	set pv(num) {}
        }
        $__ stack $cmd
      }
     paste {
       if {[catch {selection get} dat]} return
       foreach i [split $dat {}] { $__ $i }
     }
     histmove {
       if {![set ll [llength $pv(history)]]} return
       set pv(hpos) [expr {($pv(hpos)+$_a1)%$ll}]
       set pv(num) {}
       set pv(stack) [lindex $pv(history) $pv(hpos)]
       set pv(stackvar) [join $pv(stack) {}]
       set pv(evaled) 0
     }
     histadd {
       if {$pv(num) != {}} { lappend pv(stack) $pv(num) }
       set pv(num) {}
       lappend pv(history) $pv(stack)
       set pv(hpos) 0
     }
      default { set match 0 }
    }
    if {$match} return
    set match 1
    switch -- $cmd {
      0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - . - b - x - a - c - d - e - f {
        if {$pv(evaled)} { set pv(num) {} }
        append pv(num) $cmd
      }
      default { set match 0 }
    }
    set pv(evaled) 0
    if {$match} return
    set match 1
    switch -- $cmd {
      = {
        $__ histadd
        if {[info exists pv(pow)]} {
          set b $pv(pow)
  	unset pv(pow)
          set pv(num) [expr {pow($b,$pv(num))}]
        } else {
          $__ eval
        }
        foreach i {h a e} {
          set pv($i) {}
        }
        if {$pv(-command) != {}} {
  	eval $pv(-command) $pv(num)
        }
        if {$pv(-oneshot)} { $__ close }
      }
      y^x {
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        }
        set pv(pow) $n
      }
      x! - 10^x {
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        }
        set n [expr {int($n)}]
        if {$n < 0} { return [$__ err $n] }
        set pv(num) [$__ _$cmd $cmd $n]
        set pv(stack) {}
        set pv(stackvar) {}
      }
      x^2 {
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        }
        set pv(num) $n*$n
        $__ eval
      }
      1/x {
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        }
        set pv(num) 1.0/$n
        $__ eval
      }
      ! - ~ {
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        }
        set pv(num) $cmd[expr int($n)]
        $__ eval
      }
      +/- {
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        }
        set pv(num) -$n
        $__ eval
      }
      << - >> {
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        } else {
          set pv(num) [expr [expr int($n)]${cmd}1]
        }
      }
      bincvt {
          if {[string index $pv(num) 0] != {b}} return
         set x [string range $pv(num) 1 end]
         while {[string length $x]<32} {
           set x 0$x
         }
         set x [binary format B* $x]
         binary scan $x I x
         return $x
      }
      HEX {
        if {[string index $pv(num) 0] == {b}} {
          set pv(num) [$__ bincvt]
        }
        set pv(num) [format 0x%x [expr int($pv(num))]]
      }
      DEC {
        if {[string index $pv(num) 0] == {b}} {
          set pv(num) [$__ bincvt]
        }
        set pv(num) [format %d [expr int($pv(num))]]
      }
      OCT {
        if {[string index $pv(num) 0] == {b}} {
          set pv(num) [$__ bincvt]
        }
        set pv(num) [format 0%o [expr int($pv(num))]]
      }
      BIN {
        if {[string index $pv(num) 0] == {b}} return
        binary scan [binary format I [expr int($pv(num))]] B* x
        while {[string index $x 0] == {0}} {
  	set x [string range $x 1 end]
        }
        set pv(num) b$x
      }
      sin - cos - tan {
        switch $pv(state:d) {
          D {set f [expr {$pc(pi)/180}]}
          G {set f 1.0}
          R {set f [expr {$pc(pi)/200}]}
        }
        if {[catch {$__ Eval} n]} {
  	return [$__ err $n]
        }
        set ncmd "[string tolower $pv(state:a)]$cmd[string tolower $pv(state:h)]"
        if {"$pv(state:a)$pv(state:h)" == {AH}} {
          set pv(num) [$ncmd [expr {$f*$n}]]
        } else {
          set pv(num) [expr ${ncmd}($f*$n)]
        }
        set pv(state:h) {}
        set pv(state:a) {}
      }
      rand {
        set pv(num) [expr {rand()}]
      }
      srand {
        expr srand([clock seconds])
        set pv(num) 0
      }
      default {
        if {[lsearch $pc(exprcmds) $cmd]>=0} {
          if {[catch {$__ Eval} n]} {
  	  return [$__ err $n]
          }
          set pv(num) [expr ${cmd}($n)]
          set pv(evaled) 1
          return
        }
        error "unknown calc cmd: $cmd"
      }
    }
    set pv(evaled) 1
  }

  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)))}] }

  proc CallObj {_ cmd args} {
    set ccmd [namespace current]::$cmd
    if {[namespace which $ccmd] != {}} {
       return [uplevel 1 [list $ccmd $_] $args]
    }
    return [eval __ $_ $cmd $args]
  }
  
  if {[info script] == $::argv0} {
     set o [namespace current]::_1
     upvar $o V
     foreach i $Opts { set V([lindex $i 0]) [lindex $i 1] }
     interp alias {} $o {} [namespace current]::CallObj $o
     new $o -toplevel .
  }

}