3 ## Jeffrey Hobbs, jeff.hobbs@acm.org
5 ## WORK IN PROGRESS - NOT FUNCTIONAL
10 array set Calculator {
14 {frame menubar mbar {-relief raised -bd 1}}
15 {listbox data data {-height 5 -bg white \
16 -yscrollcommand [list $data(yscrollbar) set] \
17 -xscrollcommand [list $data(xscrollbar) set] \
18 -selectbackground yellow -selectborderwidth 0 \
19 -selectmode single -takefocus 1}}
20 {scrollbar yscrollbar sy {-takefocus 0 -bd 1 -orient v \
21 -command [list $data(data) yview]}}
22 {scrollbar xscrollbar sx {-takefocus 0 -bd 1 -orient h \
23 -command [list $data(data) xview]}}
24 {entry entry e {-bg white -takefocus 1}}
27 {label label lbl {-fg \#0000FF -textvariable ${w}(message)}}
31 -degree {degree Degree RAD}
32 -menubar {menuBar MenuBar 1}
33 -mode {mode Mode Trig}
34 -status {status Status 0}
37 proc Calculator args {}
38 proc calculator args {}
39 widget create Calculator
41 ;proc Calculator:construct w {
51 modes {Scientific Logical Financial}
54 grid $data(menubar) - -sticky ew
55 grid $data(data) $data(yscrollbar) -sticky news
56 grid $data(xscrollbar) -sticky ew
57 grid $data(entry) - -sticky ew
58 grid $data(modef) - -sticky ew
59 grid $data(buttons) - -sticky news
60 grid $data(label) - -sticky ew
61 grid columnconfig $w 0 -weight 1
62 grid rowconfigure $w 1 -weight 1
63 grid remove $data(yscrollbar) $data(xscrollbar) $data(label)
68 for {set i 0} {$i < 10} {incr i} {
69 button $b.$i -text $i -width 3 \
70 -bg \#d9d9FF -command [list ]
72 foreach i {A B C D E F} {
73 button $b.[string tolower $i] -text $i -width 3 \
74 -bg \#d9d9FF -command [list ]
76 button $b.del -text DEL -command [list Calculator_backspace $w]
77 button $b.clr -text CLR -command [list Calculator_clear $w]
78 button $b.drop -text Drop -command [list Calculator_drop $w]
79 button $b.swap -text Swap -command [list Calculator_swap $w]
80 button $b.sign -text +/- -command [list Calculator_changesign $w]
81 button $b.inv -text 1/x -command [list Calculator_invert $w]
82 button $b.xtoy -text x^y -command [list Calculator_func $w pow]
83 button $b.sqr -text x^2 -command [list Calculator_sqr $w]
84 button $b.sqrt -text Sqrt -command [list Calculator_sqrt $w]
85 button $b.perc -text % -command [list Calculator_percent $w]
86 button $b.dot -text . -command [list Calculator_decimal $w]
87 button $b.add -text + -bg yellow -command [list Calculator_binary $w +]
88 button $b.sub -text - -bg yellow -command [list Calculator_binary $w -]
89 button $b.mul -text * -bg yellow -command [list Calculator_binary $w *]
90 button $b.div -text / -bg yellow -command [list Calculator_binary $w /]
92 grid $b.inv $b.sqr $b.sqrt $b.perc -sticky news
93 grid $b.d $b.e $b.f $b.clr -sticky nsew
94 grid $b.a $b.b $b.c $b.del -sticky nsew
95 grid $b.7 $b.8 $b.9 $b.add -sticky nsew
96 grid $b.4 $b.5 $b.6 $b.sub -sticky nsew
97 grid $b.1 $b.2 $b.3 $b.mul -sticky nsew
98 grid $b.sign $b.0 $b.dot $b.div -sticky nsew
99 grid columnconfig $b 0 -weight 1
100 grid columnconfig $b 1 -weight 1
101 grid columnconfig $b 2 -weight 1
102 grid columnconfig $b 3 -weight 1
106 foreach i {+ - * /} {
107 bind Calculator $i [list Calculator_binary $i]
109 bind Calculator <KP_Add> [list Calculator_binary $w +]
110 bind Calculator <KP_Subtract> [list Calculator_binary $w -]
111 bind Calculator <KP_Multiply> [list Calculator_binary $w *]
112 bind Calculator <KP_Divide> [list Calculator_binary $w /]
113 bind Calculator <Return> [list Calculator_enter $w]
114 bind Calculator <KP_Enter> [list Calculator_enter $w]
115 bind Calculator <KP_Decimal> [list Calculator_decimal $w]
116 bind Calculator . [list Calculator_decimal $w]
118 bind Calculator <Shift-BackSpace> [list Calculator_drop $w]
119 bind Calculator <BackSpace> [list Calculator_backspace $w]
124 ;proc Calculator:init w {
128 ;proc Calculator:configure {w args} {
131 set truth {^(1|yes|true|on)$}
132 foreach {key val} $args {
135 if {![regexp -nocase {^(DEC|HEX|OCT|BIN)$} $val]} {
136 return -code error "bad value \"$val\", must be one of:\
139 set val [string toupper $val]
142 if {![regexp -nocase {^(RAD|GRAD|DEG)$} $val]} {
143 return -code error "bad value \"$val\",\
144 must be one of: rad, grad, deg"
146 set val [string toupper $val]
149 if {[set val [regexp -nocase $truth $val]]} {
152 grid remove $data(menubar)
156 if {![regexp -nocase ^([join $data(modes) |])\$ $val]} {
157 return -code error "bad value \"$val\",\
158 must be one of: [join $data(modes) {, }]"
160 set val [string toupper $val]
163 if {[set val [regexp -nocase $truth $val]]} {
166 grid remove $data(label)
170 if {![regexp -nocase ^([join $data(types) |])\$ $val]} {
171 return -code error "bad value \"$val\",\
172 must be one of: [join $data(types) {, }]"
174 set val [string toupper $val]
181 ;proc Calculator:dobind w {
182 foreach c [winfo children $w] {
183 bindtags $c [concat [bindtags $c] Calculator]
188 ;proc Calculator:menus w {
193 set m $data(menubar).file
194 pack [menubutton $m -text "File" -underline 0 -menu $m.m] -side left
196 $m add command -label "Save" -underline 0
200 set m $data(menubar).math
201 pack [menubutton $m -text "Math" -underline 0 -menu $m.m] -side left
203 $m add cascade -label "Constants" -menu $m.const
207 menu $m.const -postcommand [list Calculator:winConst $w $m.const]
211 set m $data(menubar).help
212 pack [menubutton $m -text "Help" -underline 0 -menu $m.m] -side right
214 $m add command -label "About" -command [list Calculator_about $w]
217 ;proc Calculator:error {w args} {
220 if {[string compare $args {}]} {
221 tk_dialog $w.error "Calculator Error" $args error 0 Oops
225 ;proc Calculator_constant {w type} {
228 array set const $data(constants)
229 Calculator_push $w {}
232 ;proc Calculator_convert {w from to args} {
239 ;proc Calculator_changesign w {
242 set arg1 [Calculator_pop $w]
243 if {[string match {} $arg1]} { return 0 }
244 Calculator_push $w [expr 0 - $arg1]
245 Calculator_push $w {}
248 ;proc Calculator_drop w {
252 Calculator_push $w {}
255 ;proc Calculator_backspace w {
258 if {[string match {} [Calculator_peek $w]]} {
260 Calculator_push $w {}
263 set arg1 [Calculator_pop $w]
264 set arg2 [string trimright $arg1 .]
265 Calculator_push $w $arg2
268 ;proc Calculator_binary {w op} {
271 set arg1 [Calculator_pop $w]
272 set arg2 [Calculator_pop $w]
273 if {[string match {} $arg2]} {
274 Calculator_push $w $arg1
275 if {[string compare $arg1 {}]} { Calculator_push $w {} }
278 Calculator_push $w [expr double($arg2) $op $arg1]
279 Calculator_push $w {}
282 ;proc Calculator:commify {w ip} {
285 if {[string len $ip] > 3} {
286 set fmt {([0-9])([0-9])([0-9])}
287 switch [expr [string len $ip]%3] {
288 0 { regsub -all $fmt $ip {\1\2\3,} ip }
289 1 { regsub -all $fmt $ip {\1,\2\3} ip }
290 2 { regsub -all $fmt $ip {\1\2,\3} ip }
292 set ip [string trimright $ip ,]
297 ;proc Calculator_decimal w {
300 if [string match {} [$data(data) get $data(index)]] {
301 Calculator_push $w 0.
303 set arg1 [Calculator_pop $w]
304 Calculator_push $w [string trimright $arg1 .].
308 ;proc Calculator_enter w {
311 set Calculator_push $w 0
312 if {[string match {} [$data(data) get $data(index)]]} {
313 set Calculator_push $w 1
315 set stk [Calculator_pop $w]
316 if {[string match {} $stk]} { return 0 }
317 Calculator_push $w $stk
318 if $push { Calculator_push $w $stk }
319 Calculator_push $w {}
322 ;proc Calculator_func {w op} {
325 set arg1 [Calculator_pop $w]
326 set arg2 [Calculator_pop $w]
327 if {[string match {} $arg2]} {
328 Calculator_push $w $arg1
329 if {[string compare $arg1 {}]} { Calculator_push $w {} }
332 Calculator_push $w [expr $op ($arg2, $arg1)]
333 Calculator_push $w {}
336 ;proc Calculator_invert w {
339 if {[string match {} [set arg1 [Calculator_pop $w]]} { return 0 }
341 Calculator:error $w "Division by 0 error"
344 Calculator_push $w [expr 1.0 / $arg1]
345 Calculator_push $w {}
348 ;proc Calculator_num {w val} {
352 if {[string match {} [$data(data) get $idx]]} {
353 $data(data) delete $idx
356 set stk [Calculator_pop $w $idx]
358 Calculator_push $w $stk$val $idx
361 ;proc Calculator_swap w {
364 set arg1 [Calculator_pop $w]
365 set arg2 [Calculator_pop $w]
366 if {[string compare $arg2 {}]} {
367 Calculator_push $w $arg1
368 if {[string compare $arg1 {}]} { Calculator_push $w {} }
371 Calculator_push $w $arg1
372 Calculator_push $w $arg2
373 Calculator_push $w {}
376 ;proc Calculator_unary {w op} {
379 set arg1 [Calculator_pop $w]
380 if {[llength $arg1]} {
381 Calculator_push $w [expr $op ($arg1)]
382 Calculator_push $w {}
386 ;proc Calculator_peek {w {idx {}}} {
389 if {[string match {} $idx]} { set idx [$data(data) curselection] }
390 if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx }
391 regsub -all {,} [$data(data) get $idx] {} val
395 ;proc Calculator_pop {w {idx {}}} {
398 if {[string match {} $idx]} { set idx [$data(data) curselection] }
399 if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx }
400 set val [$data(data) get $idx]
401 if {[string match {} $val]} {
402 Calculator:error $w "Not enough arguments"
405 $data(data) delete $idx
406 regsub -all {,} $val {} val
407 $data(data) selection clear 0 end
408 $data(data) selection set $idx $idx
410 if {[string compare end $data(index)]} {
411 set data(index) [expr $idx+1]
416 ;proc Calculator_push {w val {idx {}}} {
419 if {[string match {} $idx]} { set idx $data(index) }
420 if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx }
422 switch $data(-base) {
424 regsub -all {^0+} $val {} val
425 ## break into sign, integer, fractional and exponent parts
426 if {[regexp {^([-+])?([0-9]*)(\.)?([0-9]*)?(e[-+]?[0-9]+)?$} \
427 $val full sign ip dec fp ee]} {
428 if {[string match {} $ip]} {
429 if {[string compare $full {}]} { set ip 0 }
430 } else { set ip [Calculator:commify $w $ip] }
431 set val $sign$ip$dec$fp$ee
437 if {![regsub -all {^0+} $val {0} val]} {
444 $data(data) insert $idx $val
445 $data(data) selection clear 0 end
446 $data(data) selection set $idx $idx
448 #set data(index) $idx
452 # This procedure validates particular types of numbers/formats
455 # type - The type of validation (alphabetic, alphanumeric, date,
456 # hex, integer, numeric, real). Date is always strict.
457 # val - The value to be validated
459 # Returns: 0 or 1 (whether or not it resembles the type)
462 # -strict - enable more precise (strict) pattern matching on number
464 # Example use: validate real 55e-5
465 # validate -strict integer -505
468 ;proc Calculator_validate {w args} {
470 if [string match "-s*" [lindex $args 0]] {
472 set args [lreplace $args 0 0]
475 if {[llength $args] == 2} {
476 set type [lindex $args 0]
477 set val [lindex $args 1]
480 "wrong # args: should be \"$w validate ?-strict? type value\""
483 switch -glob -- $type {
486 return [regexp -nocase [expr {$strict?{^[a-z]+$}:{^[a-z]*$}}] $val]
490 return [regexp -nocase [expr \
491 {$strict?{^[a-z0-9]+$}:{^[a-z0-9]*$}}] $val]
495 return [expr ![catch {clock scan $val}]]
499 return [regexp -nocase [expr \
500 {$strict?{^(0x)?[0-9a-f]+$}:{^(0x)?[0-9a-f]*$}}] $val]
504 return [regexp [expr \
505 {$strict?{^[-+]?[0-9]+$}:{^[-+]?[0-9]*$}}] $val]
509 return [regexp [expr {$strict?{^[0-9]+$}:{^[0-9]*$}}] $val]
513 return [regexp -nocase [expr {$strict?\
514 {^[-+]?([0-9]+\.?[0-9]*|[0-9]*\.?[0-9]+)(e[-+]?[0-9]+)?$}:\
515 {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}}] $val]
518 return -code error "unknown type \"$type\", must be one of: \
519 alphabetic, alphanumeric, date, hexadecimal,\
520 integer, numeric or real"