#!/bin/sh
# -*- tcl -*- \
    exec wish "$0" "$@"

# Copyright (C) 1998-2004 Robert Widhopf-Fenk
#
# Author:      Robert Widhopf-Fenk
# X-URL:       http://www.robf.de/Hacking/tcltk.html
# X-RCS:       $Id: tkcalc.tk,v 1.8 2004/12/30 23:15:44 fenk Exp $

# This code is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 1, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

set debug 1
set debug 0

proc debug {msg} {
  global debug
  if {$debug} {
    puts stderr $msg
  }
}

array set vars {
  e  2.7182818
  pi 3.1415927
  g 9.80665
}

set history {}

array set funs {
  {log2}  {{x}	{log(x)/log(2)}}
  {pow2}  {{x}	{pow(2,x)}}
}

set calc(buttons) {
  {{1/x}  {x^2}  {Sqr}  {CE/C}  {AC}}
  {{INV}  {sin}  {cos}  {tan}	{DRG}}
  {{e}    {EE}	 {log}	{ln}    {y^x}}
  {{PI}	  {x!}   "("	")"	"/"}
  {{STO}  {7}	 {8}	{9}	{*}}
  {{RCL}  {4}	 {5}	{6}	{-}}
  {{SUM}  {1}    {2}    {3}     {+}}
  {{EXC}  {0}    {.}    {+/-}   {=}}
}

proc matchParen {direction lp rp} {
  set i 0

  if {$direction=="-forward"} {
    set pos [.display index "insert -1 char"]
  } else {
    set pos insert
  }

  while {$pos!={} && $i<10} {
    if {$direction=="-forward"} {
      set pos [.display search -regexp $direction -count len -- \
		   "\\$lp|\\$rp" "$pos +1 char" end]
    } else {
      set pos [.display search -regexp $direction -count len -- \
		   "\\$lp|\\$rp" $pos 1.0]
    }
    
    if {[string length $pos]} {
      if {[string compare [.display get $pos] $lp]} {
	incr i -1
	if {$i<0} {
	  bell
	  .display tag remove paren 1.0 end
	  break 
	} elseif {$i>0} {
	  
	} else {
	  if {$direction=="-forward"} {
	    .display tag add paren insert "$pos +1 char"
	  } else {
	    .display tag add paren $pos insert
	  }
	  break 
	}
      } else {
	incr i
      }
    }
  }
  if {$i>0}   {bell}
}

# This is a funny trick: in order to avoid parsing the parens structure
# we transform it into a list and iterate that one 
proc yammFun {expr {level {}}} {
  global funs
  debug "$level$expr<<input"
  set name ""

  for {set i 0} {$i < [llength $expr]} {incr i} {
    set e [string trim [lindex $expr $i]]
    debug "$level$e<<token"
    switch -regexp -- $e {
      {^[A-Za-z][A-Za-z0-9]*$} {
	if {![regexp "^@" [lindex $expr [expr $i + 1]]]} {
	  global vars 
	  if {[info exist vars($e)]} {
	    set e $vars($e)
	  } else {
#	    error "No variable with name `$var'"
	  }
	} else {
	  set name [lindex $expr $i]
	  debug "funname $name"
	}
      }
      {^\[ } {
	# sub expression
	set e [yammFun [string range $e 2 end] "$level\t"]
	debug "$level<eval<$e>"
	set expr [eval $e]
      }
      {^@ } {
	# sub expression
	set e [yammFun [string range $e 2 end] "$level\t"]
#	regsub -all -- "\[\t \]+" $e "" e
	set fun $name
	# we car only for the one just before
#	set name ""
	debug "$level<fun<$fun<$e<newexpr>[info exist funs($fun)]"
	global funs vars
	if {[info exist funs($fun)]} {
	  set args [split $e ","]
	  set fargs [lindex $funs($fun) 0]
	  set fexpr [lindex $funs($fun) 1]
	  debug "$level>>$fun=$funs($fun)>$args<<args"
	  if {$fargs != ""} {
	    # setup of function vars
	    foreach varname $fargs varvalue $args {
	      set fvars($varname) $varvalue
	      debug "$level$varname=$varvalue<vars"
	    }
	    debug "${level}fexpr=$fexpr"
	    set feval [regexp "^\\\[" $fexpr]
	    if {$feval} {
	      while {[regexp -- {\$([A-Za-z][A-Za-z0-9]*)} $fexpr junk var]} {
		debug "$level <<\[\]<var>$var<$fexpr<<<<<<<<<<"
		if {[info exists fvars($var)]} {
		  regsub -all -- "\\\$$var" $fexpr "$fvars($var)" fexpr
		} elseif {[info exists vars($var)]} {
		  regsub -all -- "\\\$$var" $fexpr "$vars($var)" fexpr
		}
	      }
	    } else {
	      while {[regexp -- {([A-Za-z][A-Za-z0-9]*) *([^\(A-Za-z0-9]|$)} \
			  $fexpr junk var]} {
		debug "$level <<~~<var>$var<$fexpr<"
		if {[info exists fvars($var)]} {
		  regsub -all -- "$var *(\[^\(a-z\]|\$)" $fexpr \
		      "$fvars($var)\\1" fexpr
		} elseif {[info exists vars($var)]} {
		  regsub -all -- "$var *(\[^\(a-z\]|\$)" $fexpr \
		      "$vars($var)\\1" fexpr
		}
	      }
	    }
	    debug "${level}fexpr=$fexpr"
	  }
	  global debug
	  if {$debug} {
	    set expr [lreplace $expr [expr $i - 1] $i "($fexpr)"]
	  } else {
	    if {$feval} {
	      set expr [lreplace $expr [expr $i - 1] $i [subst $fexpr]]
	    } else {
	      set expr [lreplace $expr [expr $i - 1] $i [eval expr $fexpr]]
	    }
	  }
	} else {
	  global debug
	  if {1 || $debug} {
	    set expr [lreplace $expr $i $i "($e)"]
	  } else {
	    ## todo do we need this?
	    set expr [lreplace $expr $i $i [eval expr $e]]
	  }
	}
      }
    }
  }
#  regsub -all -- "\[\t \]+" $expr "" expr
  debug "$level<$expr<result"
  return $expr
}

proc funSubst {expr} {
  debug ">>$expr<<"
  regsub -all "\\(" $expr " {@ " expr
  regsub -all "\\)" $expr " } " expr
  regsub -all "\\\[" $expr " {\[ " expr
  regsub -all "\\\]" $expr " } " expr
  debug ">>$expr<<"
  set expr [yammFun $expr]
  return $expr
}

proc calcLine {} {
  regsub {\..*} [.display index "insert linestart"] {} i
  while {$i > 0} {
    set expr [.display get "$i.0" "insert lineend"]
    if {[info complete $expr]} {break}
    incr i -1
  }
  if {[info complete $expr] || [regexp {sum} $expr]} {
    set doeval  1
    set nohist  0
    regsub -- {^ *\$[0-9]+ = } $expr "" expr
    switch -regexp -- $expr {
      {^sum } {
	set sum 0
	regsub {^sum} $expr {} expr
	foreach v $expr {
	  incr sum $v
	}
	set doeval 0
	set expr $sum
      }
      {^cls$} {
	.display delete 1.0 end
	return 
      }
      {^history$} {
	global history
	set expr ""
	set i 0
	foreach h $history {
	  append expr [format "%3s = %s\n" "\$$i" $h]
	  incr i
	}
	set doeval 0
	set nohist 1
      }
      {^vars$} {
	global vars 
	set expr [lsort -dictionary [array names vars]]
	set doeval 0
	set nohist 1
      }
      {^debug$} {
	global debug 
	set expr [set debug [expr !$debug]]
	set doeval 0
	set nohist 1
      }
      {^quit$} {
	exit
      }
      {^funs$} {
	global funs 
	set expr [lsort -dictionary [array names funs]]
	set doeval 0
	set nohist 1
      }
      {^\[.*\]$} {
	debug tcleval
	set expr [uplevel \#0 subst $expr]
	set doeval 0
      }
      {[A-Za-z][A-Za-z0-9]* *\([^\(]*\) *=} {
	# function assignment
	debug funset
	regexp -- {([A-Za-z][A-Za-z0-9]*) *\(([^\(]*)\) *= *(.*)} \
	    $expr junk fun args expr
	global funs
	set funs($fun) [list [split $args ","] $expr]
	.message insert end "\nfunction $fun saved"
	.message see end
	.display insert insert "\n"
	return
      }
      {[A-Za-z][A-Za-z0-9]* *\([^\(]*\)} {
	# function substitution 
	debug funsubst
	set expr [funSubst $expr]
	global debug
	if {$debug} {
	  .display mark set insert "insert lineend"
	  .display insert "insert" "\n"
	  .display insert "insert" "$expr" subst
	}
      }
      {[A-Za-z][A-Za-z0-9]* *= *} {
	# variable assignment 
	debug varset
	regexp -- {([A-Za-z][A-Za-z0-9]*) *= *(.*)} $expr junk var expr
	global vars
	set expr [set vars($var) [expr $expr]]
	.message insert end "\nvariable $var saved"
	.message see end
	.display insert insert "\n"
	return 
      }
      {[A-Za-z][A-Za-z0-9]* *([^\(A-Za-z0-9.]|$)} {
	# variable substitution
	debug varsubst
	global vars
	while {[regexp -- {(^|[*/+()-])([A-Za-z][A-Za-z0-9]*)([*/+()-]|$)} \
		    $expr junk junk var]} {
	  if {[info exist vars($var)]} {
	    regsub -- {(^|[*/+()-])([A-Za-z][A-Za-z0-9]*)([*/+()-]|$)} \
		$expr "\\1$vars($var)\\3" expr
	  } else {
	    error "No variable with name `$var'"
	  }
	}
      }
      {\$-?[0-9]+} {
	while {[regexp -- {\$(-?[0-9]+)} $expr junk pos]} {
	  global history
	  set pos [expr $pos < 0 ? [llength $history] - $pos : $pos]
	  if {$pos >= 0 && $pos < [llength $history]} {
	    regsub -- {\$(-?[0-9]+)} $expr [lindex $history $pos] expr
	  } else {
	    error "No history element $pos"
	  }
	}
      }
      default {
	# do nothing 
      }
    }
    puts $expr
    if {$doeval} {
      set expr [expr $expr]
    }
    .display mark set insert "insert lineend"
    .display insert "insert" "\n"
    set pos [.display index insert]
    if {$nohist} {
      .display insert "insert" $expr
    } else {
      global history
      .display insert "insert" [format "%4s = %s" "\$[llength $history]" $expr]
      lappend history $expr
    }
    .display tag add result $pos insert
    .display see insert
  } else {
    .display insert insert "\n"
  }
}

proc getLine {{offset 0}} {
  set line [.display get \
		"insert -$offset lines linestart" \
		"insert -$offset lines lineend"]
  regsub -- { +\$[0-9]+ = } $line {} line
  return $line
}

proc putLine {{expr {}} {args {}}} {
#  .display insert insert "\n"
  if {$expr!={}} {
    global history
#    puts $expr
    .display insert "insert" [format "\n%4s = %s" \
				  "\$[llength $history]" $expr]
    
    lappend history $expr
    .display mark set insert end 
    .display see insert
  }
}

proc mathFac {n} {
  if {int($n) != $n} {
    .message "WARNING: $n is no integer!" error
    set n [expr int($n)]
  }
  if {$n < 1} {
    error "ERROR: $i is negative!"
  } else {
    for {set i [expr $n - 1]} {$i > 0} {incr i -1} {
      set n [expr $n*$i]
    }
  }
  return $n
}

proc mathSwitchSign {} {
  set i [.display index insert]
  set pos [.display search -regexp -backwards -count len\
	       {[^0-9][^0-9]} insert {insert linestart}]
  
  if {![llength $pos]} {
    set pos [.display search -regexp -backwards -count len \
		 {[^0-9]} insert {insert linestart}]
  }    
  
  if {[llength $pos]} {
    set c [.display get $pos "$pos +$len char"]
    switch -regexp -- $c {
      {\+}    {.display delete $pos; .display insert $pos -}
      {.-}    {.display delete "$pos +1 char"}
      {-}     {.display delete $pos; .display insert $pos +}
      default {.display insert "$pos +[string length $c] char" -}
    }
  }
}

proc calc {fun} {
  global M
  
  .message delete 1.0 end
  
  set code [catch {
    switch -exact -- $fun {
      {1/x}  {putLine [expr 1/[getLine]]}
      {x^2}  {putLine [expr [getLine]*[getLine]]}
      {Sqr}  {putLine [expr sqrt([getLine])]}
      {CE/C} {.display delete "insert linestart" "insert lineend"}
      {AC}   {.display delete 1.0 end; set M 0}
      {INV}  {putLine [expr [getLine]]}
      {sin}  {putLine [expr sin([getLine])]}
      {cos}  {putLine [expr cos([getLine])]}
      {tan}  {putLine [expr tan([getLine])]}
      {DRG}  {putLine [error "ERROR: no supported"]}
      {e}    {.display insert insert "2.7182818"}
      {EE}   {.display insert insert "E"}
      {log}  {putLine [expr log([getLine])]}
      {ln}   {putLine [expr log([getLine])/log(2.7182818)]}
      {y^x}  {putLine [expr pow([getLine 1],[getLine])]}
      {PI}   {.display insert insert  "3.1415927"}
      {x!}   {putLine [mathFac [getLine]]}
      "("    {.display insert insert "("}
      ")"    {.display insert insert ")"}
      {/}    {.display insert insert "/"}
      {STO}  {set M [getLine]}
      {7}    {.display insert insert "7"}
      {8}    {.display insert insert "8"}
      {9}    {.display insert insert "9"}
      {*}    {.display insert insert "*"}
      {RCL}  {putLine $M}
      {4}    {.display insert insert "4"}
      {5}    {.display insert insert "5"}
      {6}    {.display insert insert "6"}
      {-}    {.display insert insert "-"}
      {SUM}  {putLine [set M [expr $M+[getLine]]]}
      {1}    {.display insert insert "1"}
      {2}    {.display insert insert "2"}
      {3}    {.display insert insert "3"}
      {+}    {.display insert insert "+"}
      {EXC}  {set dummy $M; set M [getLine]; putLine $dummy}
      {0}    {.display insert insert "0"}
      {.}    {.display insert insert "."}
      {+/-}  {mathSwitchSign}
      {=}    {calcLine}
      default {putLine "\nUnknown command!" error}
    }
  } err]

  if {$code && [string length $err]} {
    global errorInfo
    .message insert end "\n$err\n$errorInfo" error
    .message see end
    bell
  }
}

############################################################################

if {![winfo exists .dframe]} {
  frame .dframe
  text .display -bg white -width 40 -height 16 -setgrid 1 \
      -yscrollcommand {.scrollbar set}
  .display tag configure paren -background darkseagreen
  .display tag configure result -foreground blue
  .display tag configure subst -foreground green
  scrollbar .scrollbar -command {.display yview}
  
  frame .messv
  text .message -bg grey80 -width 36 -height 4
  .message tag configure error -foreground red
  .message insert end "See the TCL manpages on `expr' for \nvalid expressions!"
  set buttons "v"
  button .v -textvariable buttons -command {
    if {$buttons == "^"} {
      set buttons v
      pack forget .buttons 
    } else {
      set buttons ^
      update 
      pack .buttons -fill both -side bottom
    }
  }


  pack .scrollbar -side right -fill y -in .dframe
  pack .display -fill both -expand 1 -in .dframe
  pack .dframe -pady 2 -padx 2 -fill both -expand 1

  pack .v -side right -in .messv
  pack .message -fill x -in .messv
  pack .messv -fill x 

  frame .buttons
  set buttonnr 0
  set linenr 0
  foreach l $calc(buttons) {
    incr linenr
    frame .buttons$linenr
    pack .buttons$linenr -in .buttons  -fill x
    foreach b $l { 
      incr buttonnr
      button .button$buttonnr -font fixed -width 2 -pady 0 \
	  -text $b -command "calc $b"
      pack .button$buttonnr -side left -in .buttons$linenr -fill x -expand 1
    }
  }

  bindtags .display "before Text .display . all"

  # state of entering numbers
  set RET 0
  
  bind before <Control-q> {exit}
  bind before <Control-Return> {source $argv0; debug "$argv sourced"}
  bind before <Shift-Return> {calcLine}
  bind before <Return> {calcEnter}
  bind before <KP_Enter> {calcEnter}
  bind before <KP_Separator> {%W insert insert "."; break}

  set selection ""
  bind before <Control-c> {getSelection}
  bind before <Control-x> {getSelection 1}
  bind before <Control-v> {insertSelection}

  focus .display
  wm title . "Tk Calculator: (c) 1998-2002 by Robert Fenk"

  bind .display  <Any-Key> {
    .display delete 1.0 end
    .display insert end "%A"
    bind .display <Any-Key> {
      .display tag remove paren 1.0 end
      
      if {[.display compare insert > 1.0] && \
	      [.display get "insert -1c"]==")"} {
	matchParen -backward ")" "("
      } elseif {[.display get insert]=="("} {
	matchParen -forward  "(" ")"
      }
      
      set RET 1 
    }
  }
  .display insert end {
This calculation is intended to be used
like a sheet of paper, i.e. enter the
expressions, scroll backward and forward,
use earlier results, modify calculations
...
    
Valid commands are:
    cls			clear screen
    sum N1 N2 ...	calculate sum 
    history		show history
    vars		list variables
    funs		list functions
    quit		Servus
    debug		enable debug

Valid variables are:
    pi, e
    
Valid functions are:
    pow2, log2

Define an own variable by:
    VARNAME = value

Define an own function:
    FUNNAME(VARS) = FORMULAR

Use the calculation history results:
    $NUMBER

Keybindings:
    RET   calculate result, hit it twice to get an empty line 
    C-c   copy last result to clipboard
    C-x   cut last result to clipboard
    C-v   paste from clipboard
    
Example Session:
1+2 RETURN
  $0 = 3  RETURN
pgsize=1024 RETURN 
mb(pgcount)=pgsize*pgcount RETURN 
mb(10) RETURN
  $1 = 10240/87
  $2 = 117
  $3 = 1198080.0/3
  $4 = 399360.0
}
}

proc calcEnter {} {
  global RET
  puts "RET=$RET"
  if {$RET} {
    calc {=}
    set RET 0
    .display see insert
    return -code break
  } else {
    putLine
  }
}

proc getSelection {{delete 0}} {
  global selection
  if {[.display tag ranges sel] == ""} {
    set rselection [.display get "insert linestart" "insert lineend"]
    regsub -- {^ +\$[0-9]+ = } $rselection "" selection
    set start [expr [string length $rselection] - [string length $selection]]
    .display tag add sel "insert linestart + $start chars " "insert lineend"
  } else {
    set selection ""
    foreach {s e} [.display tag ranges sel] {
      append selection [.display get $s $e]
      regsub -- {^ *\$[0-9]+ = } $selection "" selection
    }
  }
  if {$delete} {
    foreach {s e} [.display tag ranges sel] {
      .display delete $s $e 
    }
  }
  selection own -command "set selection"
}

proc insertSelection {} {
  global selection
  if {[catch {.display insert insert [selection get -type STRING]}]} {
    .display insert insert $selection
  }
}