应该还有Bug……
#!/usr/local/bin/wish8.5
# author: [email protected]
package require Tk
set w .
set width 230
set height 200
wm title $w Calculator
set sheight [ winfo screenheight . ]
set swidth [ winfo screenwidth . ]
wm geometry $w +[ format %.0f [ expr {($swidth-$width)/2} ]]+[ format %.0f [ expr {($sheight-$height)*0.382} ]]
wm minsize $w $width $height
wm maxsize $w $width $height
wm resizable $w 0 0
set fra [ frame $w.top -borderwidth 2 -relief ridge ]
pack $fra -side top -pady 5
set fraNum [ frame $w.num -borderwidth 0 -relief ridge ]
pack $fraNum -side top
set lab [ entry $fra.l -width 32 -justify right -relief flat -vcmd { string is integer 0 } ]
pack $lab -side top -anchor se -ipadx 10 -ipady 1
foreach i { 1 2 3 4 5 6 7 8 9 } {
button $fraNum.$i -text $i -command "insertNum $i" -relief groove
bind $fraNum <Key-$i> "insertNum $i"
}
button $fraNum.0 -text 0 -command "insertZero" -relief groove
button $fraNum.n -text n! -command "compute2 jc" -relief groove -width 3
button $fraNum.negater -text \ub1 -command "negater" -relief groove -width 3
button $fraNum.plus -text + -command "symbol +" -relief groove
button $fraNum.sub -text - -command "symbol -" -relief groove
button $fraNum.mult -text \ud7 -command "symbol *" -relief groove
button $fraNum.div -text \uf7 -command "symbol /" -relief groove
button $fraNum.c -text C -command "click_C" -relief groove -width 3
button $fraNum.equal -text = -command "compute" -relief groove
button $fraNum.sqrt -text \u221a -command "compute2 sqrt" -relief groove
button $fraNum.dot -text . -command "insertDot" -relief groove
button $fraNum.recip -text 1/x -command "compute2 recip" -relief groove
button $fraNum.square -text x\ub2 -command "compute2 square" -relief groove
button $fraNum.back -text \u2190 -command "backspace" -relief groove -width 3
button $fraNum.ce -text CE -command "click_CE" -relief groove -width 3
checkbutton $fraNum.ms -text MS -command "MS" -indicatoron 0 -variable calc(MS) -onvalue 1 -offvalue 0 -width 1
button $fraNum.mr -text MR -command "MR" -relief groove
button $fraNum.mc -text MC -command "MC" -relief groove
button $fraNum.mplus -text M+ -command "Mplus" -relief groove
button $fraNum.msub -text M- -command "Msub" -relief groove
grid $fraNum.ms $fraNum.back $fraNum.ce $fraNum.c $fraNum.negater $fraNum.n -sticky nsew -padx 3 -pady 3
grid $fraNum.mr $fraNum.7 $fraNum.8 $fraNum.9 $fraNum.div $fraNum.sqrt -sticky nsew -padx 3 -pady 3
grid $fraNum.mc $fraNum.4 $fraNum.5 $fraNum.6 $fraNum.mult $fraNum.square -sticky nsew -padx 3 -pady 3
grid $fraNum.mplus $fraNum.1 $fraNum.2 $fraNum.3 $fraNum.sub $fraNum.recip -sticky nsew -padx 3 -pady 3
grid $fraNum.msub -sticky nsew -padx 3 -pady 3
grid $fraNum.0 -sticky nsew -padx 3 -pady 3 -row 4 -column 1 -columnspan 2
grid $fraNum.dot -sticky nsew -padx 3 -pady 3 -row 4 -column 3
grid $fraNum.plus -sticky nsew -padx 3 -pady 3 -row 4 -column 4
grid $fraNum.equal -sticky nsew -padx 3 -pady 3 -row 4 -column 5
bind $fraNum <Key-0> "insertZero"
bind $fraNum + "symbol +"
bind $fraNum - "symbol -"
bind $fraNum * "symbol *"
bind $fraNum / "symbol /"
bind $fraNum . "insertDot"
bind $fraNum <Escape> exit
bind $fraNum <Return> "compute"
bind $fraNum <BackSpace> "backspace"
set font [ $fraNum.0 cget -font ]
foreach val [ winfo children $fraNum ] {
bind $val <Enter> [ list $val configure -relief ridge -activeforeground white -activebackground lightblue -font "$font 9 bold" ]
bind $val <Leave> [ list $val configure -relief groove -font "$font" ]
}
focus -force $fraNum
set calc(x) ""
set calc(y) ""
set calc(symbol) ""
set calc(MSv) 0
set calc(clear) 0
proc insertDot { } {
global lab calc
if {[ string length [ regsub {\.} [ string trimleft [ $lab get ] 0 ] "" ]] == 32 \
|| [ regexp {[^\d\.]+$]} [ $lab get ]]} {
return
}
if { $calc(clear) == 1 } {
clear
Ins 0
}
if {[ regexp -all {\.} [ $lab get ]] == 0 } {
Ins .
set calc(clear) 0
}
}
proc insertZero { } {
global lab calc
if {[ string length [ regsub {\.} [ string trimleft [ $lab get ] 0 ] "" ]] == 32 \
|| [ regexp {[^\d\.]+$]} [ $lab get ]]} {
return
}
if { $calc(clear) == 1 } {
clear
Ins 0
}
if {[ $lab get ] ne 0 } {
Ins 0
set calc(clear) 0
}
}
proc insertNum { value } {
global lab calc
if { $calc(clear) == 1 } {
clear
Ins 0
}
if {[ string length [ regsub {\.} [ string trimleft [ $lab get ] 0 ] "" ]] == 32 \
|| [ regexp {[^\d\.]+$]} [ $lab get ]] } {
return
}
if {[ $lab get ] eq 0 } {
clear
Ins $value
set calc(clear) 0
} else {
Ins $value
set calc(clear) 0
}
}
proc symbol { symbol } {
global calc lab
set calc(clear) 1
if { $calc(symbol) != "" && $calc(y) == "" } {
set calc(y) [ $lab get ]
compute 0
} elseif { $calc(symbol) != "" && $calc(y) != "" } {
set calc(y) ""
} else {
set calc(x) [ $lab get ]
}
set calc(symbol) $symbol
}
proc click_C { } {
global calc
clear
Ins 0
set calc(x) ""
set calc(y) ""
set calc(symbol) ""
}
proc click_CE { } {
clear
Ins 0
}
proc compute2 { value } {
global lab calc
if {[ regexp {[^\d]+$} [ $lab get ]]} {
return
}
set calc(clear) 1
switch $value {
sqrt {
if {[ $lab get ] >= 0 } {
set result [ sqrt [ $lab get ] ]
} else {
clear
Ins "Invalid input";
return
}
}
recip {
if {[ $lab get ] != 0 } {
set result [ recip [ $lab get ] ]
} else {
clear
Ins "Denominator can't be zero";
return
}
}
square { set result [ X2 [ $lab get ] ]}
jc { set result [ fact [ $lab get ] ]}
default { return }
}
clear
set result [ formatStr $result ]
Ins $result
}
proc compute {{ y 1 }} {
global calc lab
set calc(clear) 1
if { $calc(y) == "" && $y == 1 } {
set calc(y) [ $lab get ]
}
switch $calc(symbol) {
+ { set result [ plus $calc(x) $calc(y)]}
- { set result [ sub $calc(x) $calc(y)]}
* { set result [ mult $calc(x) $calc(y)]}
/ {if {$calc(y) != 0 } {
set result [ div $calc(x) $calc(y) ]
} else {
clear
Ins "Denominator can't be zero";
return
}}
default { return }
}
if { $y == 0 } {
set calc(symbol) ""
set calc(y) ""
}
clear
set result [ formatStr $result ]
set calc(x) $result
Ins $result
return $result
}
proc Ins { val { pos end}} {
global lab
$lab configure -state normal
$lab insert $pos $val
$lab configure -state disabled
return [ $lab get ]
}
proc clear {{ start 0 } { end end }} {
global lab
$lab configure -state normal
$lab delete $start $end
$lab configure -state disabled
}
proc popErr { str } {
tk_messageBox -type ok -title "Error" -icon error -message "$str"
}
proc plus { x y } {
set x [ re $x ]
set y [ re $y ]
regexp {(-)?(\d+)\.?(\d+)?} $x match A(symbol) A(int) A(dec)
regexp {(-)?(\d+)\.?(\d+)?} $y match B(symbol) B(int) B(dec)
set A(dec) [ string trimright $A(dec) 0 ]
set B(dec) [ string trimright $B(dec) 0 ]
set length(int) [ expr {[ string length $A(int) ] > [ string length $B(int) ] ? [ string length $A(int) ] : [ string length $B(int) ]}]
set length(dec) [ expr {[ string length $A(dec) ] > [ string length $B(dec) ] ? [ string length $A(dec) ] : [ string length $B(dec) ]}]
# format string
set A(dec) [ format %0-$length(dec)s $A(dec) ]
set B(dec) [ format %0-$length(dec)s $B(dec) ]
set A(int) [ format %0$length(int)s $A(int) ]
set B(int) [ format %0$length(int)s $B(int) ]
# connect int and dec without dot
append A(int) $A(dec)
append B(int) $B(dec)
set carry 0
if { $A(symbol) == $B(symbol) } {
foreach Ax [ lreverse [ split $A(int) "" ]] Bx [ lreverse [ split $B(int) "" ]] {
set tmp [ expr { $Ax + $Bx + $carry } ]
lappend result [ string index $tmp end ]
set carry [ expr { $tmp > 9 ? 1 : 0 }]
}
set result [ string reverse [ join [ linsert $result $length(dec) . ] "" ]$carry ]
set result [ regsub {^0+(\d+)} [ regsub {\.$} [ regsub {0+$} $result {} ] {} ] {\1} ]
if { $result != 0 } {
return $A(symbol)$result
} else {
return $result
}
} else {
return [ sub $x $A(symbol)[ string trimleft $y - ]]
}
}
proc sub { x y } {
set x [ re $x ]
set y [ re $y ]
regexp {(-)?(\d+)\.?(\d+)?} $x match A(symbol) A(int) A(dec)
regexp {(-)?(\d+)\.?(\d+)?} $y match B(symbol) B(int) B(dec)
set A(dec) [ string trimright $A(dec) 0 ]
set B(dec) [ string trimright $B(dec) 0 ]
set length(dec) [ expr {[ string length $A(dec) ] > [ string length $B(dec) ] ? [ string length $A(dec) ] : [ string length $B(dec) ]}]
set length(int) [ expr {[ string length $A(int) ] > [ string length $B(int) ] ? [ string length $A(int) ] : [ string length $B(int) ]}]
# format string
set A(dec) [ format %0-$length(dec)s $A(dec) ]
set B(dec) [ format %0-$length(dec)s $B(dec) ]
set A(int) [ format %0$length(int)s $A(int) ]
set B(int) [ format %0$length(int)s $B(int) ]
# connect int and dec without dot
append A(int) $A(dec)
append B(int) $B(dec)
set carry 0
if { $A(symbol) == $B(symbol) } {
foreach Ax [ lreverse [ split [ max $A(int) $B(int) ] "" ]] Bx [ lreverse [ split [ min $A(int) $B(int) ] "" ]] {
if { $Ax < $Bx+$carry } {
incr Ax 10
lappend result [ string index [ expr { $Ax - $Bx - $carry }] end ]
set carry 1
} else {
lappend result [ string index [ expr { $Ax - $Bx - $carry }] end ]
set carry 0
}
}
if { [ max $x $y ] == $x && $A(symbol) == "-" \
|| [ max $x $y ] == $y && $A(symbol) == "" } {
set symbol -
} else {
set symbol ""
}
set result [ string reverse [ join [ linsert $result $length(dec) . ] "" ]$carry ]
set result [ regsub {^0+(\d+)} [ regsub {\.$} [ regsub {0+$} $result {} ] {} ] {\1} ]
if { $result != 0 } {
return $symbol$result
} else {
return $result
}
} else {
return [ plus $x $A(symbol)[ string trimleft $y - ]]
}
}
proc max { x y } {
set x [ re $x ]
set y [ re $y ]
regexp {(-)?(\d+)\.?(\d+)?} $x match A(symbol) A(int) A(dec)
regexp {(-)?(\d+)\.?(\d+)?} $y match B(symbol) B(int) B(dec)
set A(dec) [ string trimright $A(dec) 0 ]
set B(dec) [ string trimright $B(dec) 0 ]
set length(dec) [ expr {[ string length $A(dec) ] > [ string length $B(dec) ] ? [ string length $A(dec) ] : [ string length $B(dec) ]}]
# format string
set A(dec) [ format %0-$length(dec)s $A(dec) ]
set B(dec) [ format %0-$length(dec)s $B(dec) ]
# connect int and dec without dot
append A(int) $A(dec)
append B(int) $B(dec)
if {[ string length $A(int) ] > [ string length $B(int) ]} {
return $x
} elseif {[ string length $A(int) ] < [ string length $B(int) ]} {
return $y
} else {
foreach Ax [ split $A(int) "" ] Bx [ split $B(int) "" ] {
if { $Ax > $Bx } {
return $x
} elseif { $Ax < $Bx } {
return $y
}
}
return $x
}
}
proc min { x y } {
set x [ re $x ]
set y [ re $y ]
regexp {(-)?(\d+)\.?(\d+)?} $x match A(symbol) A(int) A(dec)
regexp {(-)?(\d+)\.?(\d+)?} $y match B(symbol) B(int) B(dec)
set A(dec) [ string trimright $A(dec) 0 ]
set B(dec) [ string trimright $B(dec) 0 ]
set length(dec) [ expr {[ string length $A(dec) ] > [ string length $B(dec) ] ? [ string length $A(dec) ] : [ string length $B(dec) ]}]
# format string
set A(dec) [ format %0-$length(dec)s $A(dec) ]
set B(dec) [ format %0-$length(dec)s $B(dec) ]
# connect int and dec without dot
append A(int) $A(dec)
append B(int) $B(dec)
if {[ string length $A(int) ] > [ string length $B(int) ]} {
return $y
} elseif {[ string length $A(int) ] < [ string length $B(int) ]} {
return $x
} else {
foreach Ax [ split $A(int) "" ] Bx [ split $B(int) "" ] {
if { $Ax > $Bx } {
return $y
} elseif { $Ax < $Bx } {
return $x
}
}
return $x
}
}
proc mult { x y } {
set x [ re $x ]
set y [ re $y ]
regexp {(-)?(\d+)\.?(\d+)?} $x match A(symbol) A(int) A(dec)
regexp {(-)?(\d+)\.?(\d+)?} $y match B(symbol) B(int) B(dec)
set A(dec) [ string trimright $A(dec) 0 ]
set B(dec) [ string trimright $B(dec) 0 ]
set length(dec) [ expr {[ string length $A(dec) ] + [ string length $B(dec) ]}]
append A(int) $A(dec)
append B(int) $B(dec)
set result 0
for { set i 0; set carry 0 } { $i < [ string length $B(int) ]} { incr i; set carry 0; unset row } {
set Bx [ string index $B(int) end-$i ]
foreach Ax [ lreverse [ split $A(int) "" ]] {
set tmp [ expr { $Bx * $Ax + $carry } ]
lappend row [ string index $tmp end ]
set carry [ expr { $tmp > 9 ? [ string index $tmp 0 ] : 0 }]
}
set row [ join [ lreverse [ lappend row $carry ]] "" ][ format %0$i\s "" ]
set result [ plus $result $row ]
}
set result [ regsub {^\.} [ join [ linsert [ split [ format %0$length(dec)s $result ] "" ] end-$length(dec) . ] "" ] {0.} ]
set result [ regsub {^0+(\d+)} [ regsub {\.$} [ regsub {0+$} $result {} ] {} ] {\1} ]
if { $A(symbol) == $B(symbol) } {
return $result
} else {
return -$result
}
}
proc div { x y } {
set x [ re $x ]
set y [ re $y ]
set result [ mult $x [ recip $y ]]
return $result
}
proc fact { x } {
if { $x == 1 } {
return 1
} else {
return [ mult $x [ fact [ sub $x 1 ]]]
}
}
proc X2 { x } {
return [ mult $x $x ]
}
proc recip { a } {
set a [ re $a ]
set expect 0.00000000000000000000000000000000001; #35
regexp {(-)?(\d+)\.?(\d+)?} $a match A(symbol) A(int) A(dec)
set A(dec) [ string trimright $A(dec) 0 ]
set length(dec) [ expr {[ string length $A(dec) ]}]
if { $A(int) == 0 && $A(dec) == "" } {
return "Cannot divide by zero."
}
set x [ format %.64f [ expr 1.0/$a ]]
set func [ mult $x [ sub 2 [ mult $a $x ]]]
set actual [ sub $x $func ]
while {[ max $actual $expect ] != $expect } {
set x [ string range $func 0 64 ]
set func [ mult $x [ sub 2 [ mult $a $x ]]]
set actual [ sub $x $func ]
}
return $func
}
proc sqrt { a } {
set a [ re $a ]
set expect 0.00000000000000000000000000000000001; #35
regexp {(-)?(\d+)\.?(\d+)?} $a match A(symbol) A(int) A(dec)
set A(dec) [ string trimright $A(dec) 0 ]
set length(dec) [ expr {[ string length $A(dec) ]}]
set x [ format %.64f [ expr {sqrt($a)}]]
set func [ plus [ mult $x 0.5 ] [ mult 0.5 [ div $a $x ]]]
set actual [ sub $x $func ]
while {[ max $actual $expect ] != $expect } {
set x [ string range $func 0 64 ]
set func [ plus [ mult $x 0.5 ] [ mult 0.5 [ div $a $x ]]]
set actual [ sub $x $func ]
}
return $func
}
proc negater { } {
global lab
if {[ regexp {[^\d\.+]} [ $lab get ]]} {
return
}
set tmp [ $lab get ]
if { $tmp ne 0 } {
if {[ string index $tmp 0 ] == "-" } {
clear 0 1
} else {
Ins - 0
}
}
}
proc backspace { } {
global lab
if {[ regexp {(-)?([\d\.]+)e[\-|\+](\d+)} [ $lab get ]] || [ regexp {[^\d\.]+$} [ $lab get ]]} {
return
}
$lab config -state normal
$lab delete [ expr {[ string length [ $lab get ]]-1} ]
$lab config -state disabled
if {[ $lab get ] == "-" || [ $lab get ] == "" } {
clear
Ins 0
}
}
proc MS { } {
global calc lab
if {[ regexp {[^\d\.]+$]} [ $lab get ]]} {
return
}
set calc(clear) 1
if { $calc(MS) == 1 } {
set calc(MSv) [ $lab get ]
} else {
set calc(MSv) 0
}
}
proc MR { } {
global calc lab
set calc(clear) 1
clear
Ins $calc(MSv)
}
proc MC { } {
global calc
if { $calc(MS) == 1 } {
set calc(MS) 0
set calc(MSv) 0
}
}
proc Mplus { } {
global calc lab
if {[ regexp {[^\d\.]+$} [ $lab get ]]} {
return
}
set calc(clear) 1
if { $calc(MS) != 1 } {
set calc(MS) 1
}
set calc(MSv) [ formatStr [ plus $calc(MSv) [ $lab get ]]]
}
proc Msub { } {
global calc lab
if {[ regexp {[^\d\.]+$} [ $lab get ]]} {
return
}
set calc(clear) 1
if { $calc(MS) != 1 } {
set calc(MS) 1
}
set calc(MSv) [ formatStr [ sub $calc(MSv) [ $lab get ]]]
}
proc formatStr { str } {
regexp {(-)?([\d\.]+)} $str match symbol A
regexp {(\d+)\.?(\d+)?} $str match int dec
if {[ max $str 0.0001 ] eq 0.0001 && [ string length $dec ] > 32 } {
set str [ split $A "" ]
set pos [ expr {[ lsearch -regexp $str {[^0\.]} ] + 1 }]
set str [ string trimleft [ join [ linsert $str $pos . ] "" ] .0 ]
set e e-[ expr $pos - 2 ]
set str [ string trimright [ string range $str 0 33-[ string length $e ]] 0. ]$e
} elseif {[ string length $int ] > 32 } {
set str [ split $A "" ]
set str [ join [ linsert [ split $int "" ] 1 . ] "" ]
set e e+[ expr [ string length $int ] - 1 ]
set str [ string trimright [ string range $str 0 32-[ string length $e ]] 0. ]$e
} elseif { $int == 0 && [ string length $A ] > 33 } {
set str [ string range $A 0 33 ]
if {[ string index $A 34 ] > 4 } {
set str [ plus $str 0.[ format %032s 1 ]]
}
} elseif {[ string length $A ] > 33 && [ string length $int ] == 32 } {
set str [ string range $A 0 32 ]
if {[ string index $A 33 ] > 4 } {
set str [ plus $str 1 ]
}
} elseif {[ string length $A ] > 33 } {
set str [ string range $A 0 32 ]
if {[ string index $A 33 ] > 4 } {
set pos [ lsearch [ split $str "" ] . ]
set str [ plus $str 0.[ format %0[ expr 32 - $pos ]s 1 ]]
}
}
if { [ regexp {\d+\.(\d+0)?$} $str ] } {
set str [ string trimright $str .0 ]
}
set tmp [ regsub {e[\+|\-]\d+$} $str {}]
if { [ regexp {e[\+|\-]\d+$} $str e ] && [ regexp {\d\.\d+99999+$} $tmp ]} {
set str [ regsub {e[\+|\-]\d+$} $str {}]
regexp {(\d+)\.?(\d+)?} $str match int dec
set carry 0.[ format %0[ string length $dec ]s 1 ]
set str [ re [ plus $carry $str ]$e ]
}
return $symbol[ string trimleft $str - ]
}
proc re { str } {
set symbol ""
if {[ regexp {(-)?([\d\.]+)e\-(\d+)} $str match symbol A B ]} {
set str [ join [ linsert [ split [ format %0$B\s 0 ][ regsub {\.} $A "" ] "" ] 1 . ] "" ]
} elseif {[ regexp {([\d\.]+)e\+(\d+)} $str match A B ]} {
set B [ expr {$B + 1} ]
set str [ string trimright [ join [ linsert [ split [ format %0-$B\s [ regsub {\.} $A "" ]] "" ] $B . ] "" ] . ]
}
return $symbol$str
}
Ins 0