tcl/calculator.tcl

   1 ## calculator.tcl
   2 ##
   3 ## Jeffrey Hobbs, jeff.hobbs@acm.org
   4 ##
   5 ## WORK IN PROGRESS - NOT FUNCTIONAL
   6 ##
   7
   8 set tcl_precision 15
   9
  10 array set Calculator {
  11     type        frame
  12     base        frame
  13     components  {
  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}}
  25         {frame modef}
  26         {frame buttons}
  27         {label label lbl {-fg \#0000FF -textvariable ${w}(message)}}
  28     }
  29
  30     -base       {base           Base    DEC}
  31     -degree     {degree         Degree  RAD}
  32     -menubar    {menuBar        MenuBar 1}
  33     -mode       {mode           Mode    Trig}
  34     -status     {status         Status  0}
  35     -type       {type           Type    REG}
  36 }
  37 proc Calculator args {}
  38 proc calculator args {}
  39 widget create Calculator
  40
  41 ;proc Calculator:construct w {
  42     upvar \#0 $w data
  43
  44     array set data {
  45         version         1.0
  46         index           end
  47         constants       {
  48             pi          3.141592654
  49             e           2.718281828
  50         }
  51         modes           {Scientific Logical Financial}
  52     }
  53
  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)
  64
  65     Calculator:menus $w
  66
  67     set b $data(buttons)
  68     for {set i 0} {$i < 10} {incr i} {
  69         button $b.$i -text $i -width 3 \
  70                 -bg \#d9d9FF -command [list ]
  71     }
  72     foreach i {A B C D E F} {
  73         button $b.[string tolower $i] -text $i -width 3 \
  74                 -bg \#d9d9FF -command [list ]
  75     }
  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 /]
  91
  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
 103
 104     ## Standard bindings
 105     ##
 106     foreach i {+ - * /} {
 107         bind Calculator $i [list Calculator_binary $i]
 108     }
 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]
 117
 118     bind Calculator <Shift-BackSpace>   [list Calculator_drop $w]
 119     bind Calculator <BackSpace>         [list Calculator_backspace $w]
 120
 121     Calculator:dobind $w
 122 }
 123
 124 ;proc Calculator:init w {
 125     upvar \#0 $w data
 126 }
 127
 128 ;proc Calculator:configure {w args} {
 129     upvar \#0 $w data
 130
 131     set truth {^(1|yes|true|on)$}
 132     foreach {key val} $args {
 133         switch -- $key {
 134             -base       {
 135                 if {![regexp -nocase {^(DEC|HEX|OCT|BIN)$} $val]} {
 136                     return -code error "bad value \"$val\", must be one of:\
 137                             dec, hex, oct, bin"
 138                 }
 139                 set val [string toupper $val]
 140             }
 141             -degree     {
 142                 if {![regexp -nocase {^(RAD|GRAD|DEG)$} $val]} {
 143                     return -code error "bad value \"$val\",\
 144                             must be one of: rad, grad, deg"
 145                 }
 146                 set val [string toupper $val]
 147             }
 148             -menubar    {
 149                 if {[set val [regexp -nocase $truth $val]]} {
 150                     grid $data(menubar)
 151                 } else {
 152                     grid remove $data(menubar)
 153                 }
 154             }
 155             -mode       {
 156                 if {![regexp -nocase ^([join $data(modes) |])\$ $val]} {
 157                     return -code error "bad value \"$val\",\
 158                             must be one of: [join $data(modes) {, }]"
 159                 }
 160                 set val [string toupper $val]
 161             }
 162             -status     {
 163                 if {[set val [regexp -nocase $truth $val]]} {
 164                     grid $data(label)
 165                 } else {
 166                     grid remove $data(label)
 167                 }
 168             }
 169             -type       {
 170                 if {![regexp -nocase ^([join $data(types) |])\$ $val]} {
 171                     return -code error "bad value \"$val\",\
 172                             must be one of: [join $data(types) {, }]"
 173                 }
 174                 set val [string toupper $val]
 175             }
 176         }
 177         set data($key) $val
 178     }
 179 }
 180
 181 ;proc Calculator:dobind w {
 182     foreach c [winfo children $w] {
 183         bindtags $c [concat [bindtags $c] Calculator]
 184         Calculator:dobind $c
 185     }
 186 }
 187
 188 ;proc Calculator:menus w {
 189     upvar \#0 $w data
 190
 191     ## File Menu
 192     ##
 193     set m $data(menubar).file
 194     pack [menubutton $m -text "File" -underline 0 -menu $m.m] -side left
 195     set m [menu $m.m]
 196     $m add command -label "Save" -underline 0
 197
 198     ## Math Menu
 199     ##
 200     set m $data(menubar).math
 201     pack [menubutton $m -text "Math" -underline 0 -menu $m.m] -side left
 202     set m [menu $m.m]
 203     $m add cascade -label "Constants" -menu $m.const
 204
 205     ## Constants Menu
 206     ##
 207     menu $m.const -postcommand [list Calculator:winConst $w $m.const]
 208
 209     ## Help Menu
 210     ##
 211     set m $data(menubar).help
 212     pack [menubutton $m -text "Help" -underline 0 -menu $m.m] -side right
 213     set m [menu $m.m]
 214     $m add command -label "About" -command [list Calculator_about $w]
 215 }
 216
 217 ;proc Calculator:error {w args} {
 218     upvar \#0 $w data
 219
 220     if {[string compare $args {}]} {
 221         tk_dialog $w.error "Calculator Error" $args error 0 Oops
 222     }
 223 }
 224
 225 ;proc Calculator_constant {w type} {
 226     upvar \#0 $w data
 227
 228     array set const $data(constants)
 229     Calculator_push $w {}
 230 }
 231
 232 ;proc Calculator_convert {w from to args} {
 233     upvar \#0 $w data
 234
 235     foreach num $args {
 236     }
 237 }
 238
 239 ;proc Calculator_changesign w {
 240     upvar \#0 $w data
 241
 242     set arg1 [Calculator_pop $w]
 243     if {[string match {} $arg1]} { return 0 }
 244     Calculator_push $w [expr 0 - $arg1]
 245     Calculator_push $w {}
 246 }
 247
 248 ;proc Calculator_drop w {
 249     upvar \#0 $w data
 250
 251     Calculator_pop $w
 252     Calculator_push $w {}
 253 }
 254
 255 ;proc Calculator_backspace w {
 256     upvar \#0 $w data
 257
 258     if {[string match {} [Calculator_peek $w]]} {
 259         Calculator_pop $w
 260         Calculator_push $w {}
 261         return
 262     }
 263     set arg1 [Calculator_pop $w]
 264     set arg2 [string trimright $arg1 .]
 265     Calculator_push $w $arg2
 266 }
 267
 268 ;proc Calculator_binary {w op} {
 269     upvar \#0 $w data
 270
 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 {} }
 276         return
 277     }
 278     Calculator_push $w [expr double($arg2) $op $arg1]
 279     Calculator_push $w {}
 280 }
 281
 282 ;proc Calculator:commify {w ip} {
 283     upvar \#0 $w data
 284
 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 }
 291         }
 292         set ip [string trimright $ip ,]
 293     }
 294     return $ip
 295 }
 296
 297 ;proc Calculator_decimal w {
 298     upvar \#0 $w data
 299
 300     if [string match {} [$data(data) get $data(index)]] {
 301         Calculator_push $w 0.
 302     } else {
 303         set arg1 [Calculator_pop $w]
 304         Calculator_push $w [string trimright $arg1 .].
 305     }
 306 }
 307
 308 ;proc Calculator_enter w {
 309     upvar \#0 $w data
 310
 311     set Calculator_push $w 0
 312     if {[string match {} [$data(data) get $data(index)]]} {
 313         set Calculator_push $w 1
 314     }
 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 {}
 320 }
 321
 322 ;proc Calculator_func {w op} {
 323     upvar \#0 $w data
 324
 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 {} }
 330         return 0
 331     }
 332     Calculator_push $w [expr $op ($arg2, $arg1)]
 333     Calculator_push $w {}
 334 }
 335
 336 ;proc Calculator_invert w {
 337     upvar \#0 $w data
 338
 339     if {[string match {} [set arg1 [Calculator_pop $w]]} { return 0 }
 340     if {$arg1 == 0} {
 341         Calculator:error $w "Division by 0 error"
 342         return 0
 343     }
 344     Calculator_push $w [expr 1.0 / $arg1]
 345     Calculator_push $w {}
 346 }
 347
 348 ;proc Calculator_num {w val} {
 349     upvar \#0 $w data
 350
 351     set idx $data(index)
 352     if {[string match {} [$data(data) get $idx]]} {
 353         $data(data) delete $idx
 354         set stk {}
 355     } else {
 356         set stk [Calculator_pop $w $idx]
 357     }
 358     Calculator_push $w $stk$val $idx
 359 }
 360
 361 ;proc Calculator_swap w {
 362     upvar \#0 $w data
 363
 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 {} }
 369         return 0
 370     }
 371     Calculator_push $w $arg1
 372     Calculator_push $w $arg2
 373     Calculator_push $w {}
 374 }
 375
 376 ;proc Calculator_unary {w op} {
 377     upvar \#0 $w data
 378
 379     set arg1 [Calculator_pop $w]
 380     if {[llength $arg1]} {
 381         Calculator_push $w [expr $op ($arg1)]
 382         Calculator_push $w {}
 383     } else { return 0 }
 384 }
 385
 386 ;proc Calculator_peek {w {idx {}}} {
 387     upvar \#0 $w data
 388
 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
 392     return $val
 393 }
 394
 395 ;proc Calculator_pop {w {idx {}}} {
 396     upvar \#0 $w data
 397
 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"
 403         return
 404     }
 405     $data(data) delete $idx
 406     regsub -all {,} $val {} val
 407     $data(data) selection clear 0 end
 408     $data(data) selection set $idx $idx
 409     $data(data) see $idx
 410     if {[string compare end $data(index)]} {
 411         set data(index) [expr $idx+1]
 412     }
 413     return $val
 414 }
 415
 416 ;proc Calculator_push {w val {idx {}}} {
 417     upvar \#0 $w data
 418
 419     if {[string match {} $idx]} { set idx $data(index) }
 420     if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx }
 421
 422     switch $data(-base) {
 423         DEC {
 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
 432             } else {
 433                 #if [scan $val %d]
 434             }
 435         }
 436         OCT {
 437             if {![regsub -all {^0+} $val {0} val]} {
 438                 set val 0$val
 439             }
 440         }
 441         HEX {  }
 442         BIN {  }
 443     }
 444     $data(data) insert $idx $val
 445     $data(data) selection clear 0 end
 446     $data(data) selection set $idx $idx
 447     $data(data) see $idx
 448     #set data(index) $idx
 449 }
 450
 451 # validate --
 452 # This procedure validates particular types of numbers/formats
 453 #
 454 # Arguments:
 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
 458 #
 459 # Returns:      0 or 1 (whether or not it resembles the type)
 460 #
 461 # Switches:
 462 # -strict       - enable more precise (strict) pattern matching on number
 463 #
 464 # Example use:  validate real 55e-5
 465 #               validate -strict integer -505
 466 #
 467
 468 ;proc Calculator_validate {w args} {
 469     set strict 0
 470     if [string match "-s*" [lindex $args 0]] {
 471         set strict 1
 472         set args [lreplace $args 0 0]
 473     }
 474
 475     if {[llength $args] == 2} {
 476         set type [lindex $args 0]
 477         set val  [lindex $args 1]
 478     } else {
 479         return -code error \
 480                 "wrong # args: should be \"$w validate ?-strict? type value\""
 481     }
 482
 483     switch -glob -- $type {
 484         alphab* {
 485             #alphabetic
 486             return [regexp -nocase [expr {$strict?{^[a-z]+$}:{^[a-z]*$}}] $val]
 487         }
 488         alphan* {
 489             #alphanumeric
 490             return [regexp -nocase [expr \
 491                     {$strict?{^[a-z0-9]+$}:{^[a-z0-9]*$}}] $val]
 492         }
 493         d*      {
 494             #date
 495             return [expr ![catch {clock scan $val}]]
 496         }
 497         h*      {
 498             #hexadecimal
 499             return [regexp -nocase [expr \
 500                     {$strict?{^(0x)?[0-9a-f]+$}:{^(0x)?[0-9a-f]*$}}] $val]
 501         }
 502         i*      {
 503             #integer
 504             return [regexp [expr \
 505                     {$strict?{^[-+]?[0-9]+$}:{^[-+]?[0-9]*$}}] $val]
 506         }
 507         n*      {
 508             #numeric
 509             return [regexp [expr {$strict?{^[0-9]+$}:{^[0-9]*$}}] $val]
 510         }
 511         r*      {
 512             #real
 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]
 516         }
 517         default {
 518             return -code error "unknown type \"$type\", must be one of: \
 519                     alphabetic, alphanumeric, date, hexadecimal,\
 520                     integer, numeric or real"
 521         }
 522     }
 523 }