1#! /bin/sh
2# the next line restarts with tclsh \
3exec tclsh "$0" ${1+"$@"}
4
5set scriptDir [file dirname [info script]]
6
7########################################################################
8# BigFloat for Tcl
9# Copyright (C) 2003-2005  ARNOLD Stephane
10#
11# BIGFLOAT LICENSE TERMS
12#
13# This software is copyrighted by Stephane ARNOLD, (stephanearnold <at> yahoo.fr).
14# The following terms apply to all files associated
15# with the software unless explicitly disclaimed in individual files.
16#
17# The authors hereby grant permission to use, copy, modify, distribute,
18# and license this software and its documentation for any purpose, provided
19# that existing copyright notices are retained in all copies and that this
20# notice is included verbatim in any distributions. No written agreement,
21# license, or royalty fee is required for any of the authorized uses.
22# Modifications to this software may be copyrighted by their authors
23# and need not follow the licensing terms described here, provided that
24# the new terms are clearly indicated on the first page of each file where
25# they apply.
26#
27# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
28# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
29# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
30# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
31# POSSIBILITY OF SUCH DAMAGE.
32#
33# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
34# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
35# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
36# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
37# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
38# MODIFICATIONS.
39#
40# GOVERNMENT USE: If you are acquiring this software on behalf of the
41# U.S. government, the Government shall have only "Restricted Rights"
42# in the software and related documentation as defined in the Federal
43# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
44# are acquiring the software on behalf of the Department of Defense, the
45# software shall be classified as "Commercial Computer Software" and the
46# Government shall have only "Restricted Rights" as defined in Clause
47# 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
48# authors grant the U.S. Government and others acting in its behalf
49# permission to use and distribute the software in accordance with the
50# terms specified in this license.
51#
52########################################################################
53
54package require Tk
55
56package require math::bigfloat
57namespace import ::math::bigfloat::*
58
59set nbButtons 0
60proc addButton {command} {
61    global nbButtons
62    set ::buttons($nbButtons,command) _$command
63    set ::buttons($nbButtons,texte) $command
64    incr nbButtons
65}
66
67proc addButtonTwo {commande} {
68    addButton $commande
69    proc _$commande {} "if {\[catch {pop a} msg\]} {tk_messageBox -message \$msg;return}
70    if {\[catch {pop b} msg\]} {push \$a
71        tk_messageBox -message \$msg;return}
72    if {\[catch {set result \[$commande \$a \$b\]} msg\]} {
73        push \$b
74        push \$a
75        tk_messageBox -message \$msg
76        return}
77    push \$result"
78}
79
80
81proc addButtonOne {commande} {
82    addButton $commande
83    proc _$commande {} "if {\[catch {pop a} msg\]} {tk_messageBox -message \$msg;return}
84    if {\[catch {set result \[$commande \$a\]} msg\]} {push \$a
85        tk_messageBox -message \$msg
86        return}
87    push \$result"
88}
89
90
91proc drawButtons {} {
92    global nbButtons
93    set nbLines [expr {int(sqrt($nbButtons))}]
94    for {set i 0} {$i<$nbButtons} {incr i} {
95        set col [expr {$i%$nbLines}]
96        set line [expr {$i/$nbLines}]
97        set commande $::buttons($i,command)
98        set texte $::buttons($i,texte)
99        button .functions.$commande -text $texte -command $commande -width 10
100        grid .functions.$commande -column $col -row $line -in .functions
101
102    }
103}
104
105proc initStack {} {
106    foreach i {1 2 3 4} {
107        label .stack.l$i -text "[expr {5-$i}] :" -foreground #079 -width 5
108        grid .stack.l$i -in .stack -row $i -column 1
109        label .stack.n$i -text "Empty" -foreground #097 -width 85
110        grid .stack.n$i -in .stack -row $i -column 2
111    }
112    set ::stack [list]
113}
114
115proc Push {} {
116    set x [fromstr $::bignum]
117    if {![isInt $x]} {
118        set x [fromstr $::bignum $::zeros]
119    }
120    lappend ::stack $x
121    set ::bignum 1.00
122    set ::zeros 0
123}
124
125
126proc toStr {n} {
127    set n [math::bigfloat::tostr $n]
128    set resultat ""
129    while {[string length $n]>80} {
130        append resultat "[string range $n 0 79]...\n"
131        set n [string range $n 80 end]
132    }
133    append resultat $n
134}
135
136
137proc drawStack {args} {
138    set l [lrange $::stack end-3 end]
139    for {set i 4} {$i>[llength $l]} {incr i -1} {
140        .stack.n[expr {5-$i}] configure -text "Empty" -foreground #097
141    }
142    for {set i 0} {$i<[llength $l]} {incr i} {
143        set number [lindex $::stack end-$i]
144        .stack.n[expr {4-$i}] configure -text [toStr $number] -foreground #000
145    }
146}
147
148proc init {} {
149    wm title . "BigFloatDemo 1.2"
150    # the stack (for RPN)
151    frame .stack
152    pack .stack
153    initStack
154    # the commands for input
155    set c [frame .commands]
156    pack $c -padx 10 -pady 10
157    set ::bignum 1.00
158    entry $c.bignum -textvariable ::bignum -width 16
159    pack $c.bignum -in $c -side left
160    label $c.labelZero -text "append zeros"
161    pack $c.labelZero -in $c -side left
162    set ::zeros 0
163    entry $c.zeros -textvariable ::zeros -width 4
164    pack $c.zeros -in $c -side left
165    button $c.fenter -text "Push" -command Push
166    pack $c.fenter -in $c -side left
167    # the functions for numbers
168    frame .functions
169    pack .functions
170    set f .functions
171    # chaque fonction est associ�e, d'une part,
172    # � un bouton portant un libell�, et d'autre part
173    # � une commande Tcl
174    # ici nous associons le bouton "add" � la commande "add"
175    addButtonTwo add
176    # toutes ces commandes se trouvent � la fin de ce fichier
177    addButtonTwo sub
178    addButtonTwo mul
179    addButtonTwo div
180    addButtonTwo mod
181    addButtonOne opp
182    addButtonOne abs
183    addButtonOne round
184    addButtonOne ceil
185    addButtonOne floor
186    addButtonTwo pow
187    addButtonOne sqrt
188    addButtonOne log
189    addButtonOne exp
190    addButtonOne cos
191    addButtonOne sin
192    addButtonOne tan
193    addButtonOne acos
194    addButtonOne asin
195    addButtonOne atan
196    addButtonOne cotan
197    addButtonOne cosh
198    addButtonOne sinh
199    addButtonOne tanh
200    addButtonOne pi
201    addButtonOne rad2deg
202    addButtonOne deg2rad
203    addButtonOne int2float
204    addButton del
205    addButton swap
206    addButton dup
207    addButton help
208    addButton save
209    addButton exit
210    drawButtons
211    raise .
212}
213
214################################################################################
215# procedures that corresponds to functions (add,mul,etc.)
216################################################################################
217
218proc _save {} {
219    set fichier [tk_getSaveFile -filetypes {{{Text Files} {.txt}}} -title "Save the stack as ..."]
220    if {$fichier == ""} {
221        error "You should give a name to the file. Aborting saving operation. Sorry."
222    }
223    if {[lindex [split $fichier .] end]!="txt"} {
224        append fichier .txt
225    }
226    if {[catch {set file [open $fichier w]}]} {
227        error "Write impossible on file : '$fichier'"
228    }
229    foreach valeur $::stack {
230        puts $file [::math::bigfloat::tostr $valeur]
231    }
232    close $file
233}
234
235proc ShowFile {filename buttonText} {
236    if {[catch {toplevel .help}]} {
237        tk_messageBox -message "Unable to create the window ; please close the current help window"
238        return
239    }
240    frame .help.licence
241    text .help.licence.t -yscrollcommand {.help.licence.s set}
242    scrollbar .help.licence.s -command {.help.licence.t yview}
243    grid .help.licence.t .help.licence.s -sticky nsew
244    grid columnconfigure .help.licence 0 -weight 1
245    grid rowconfigure .help.licence 0 -weight 1
246
247    pack .help.licence -in .help
248    set fd [open $filename]
249    .help.licence.t insert 0.0 [read $fd]
250    close $fd
251    .help.licence.t configure -state disabled
252    button .help.bouton -text $buttonText -command {destroy .help;raise .}
253    pack .help.bouton -in .help
254    focus -force .help
255}
256
257proc _help {args} {
258    # display some help
259    ShowFile [file join $::scriptDir bigfloat.help] Close
260}
261
262proc _del {} {
263    if {[llength $::stack]<=1} {
264        set ::stack {}
265    } else  {
266        set ::stack [lrange $::stack 0 end-1]
267    }
268}
269
270proc _swap {} {
271    set last [lindex $::stack end]
272    lset ::stack end [lindex $::stack end-1]
273    lset ::stack end-1 $last
274}
275
276# duplicate the last value
277proc _dup {} {
278    lappend ::stack [lindex $::stack end]
279}
280
281
282
283proc pop {varname} {
284    if {[llength $::stack]==0} {
285        error "too few arguments in the stack"
286    }
287    upvar $varname out
288    set out [lindex $::stack end]
289    set ::stack [lrange $::stack 0 end-1]
290    return
291}
292
293
294proc push {x} {
295    lappend ::stack $x
296}
297
298proc _exit {} {
299    update
300    exit
301}
302
303
304
305# initialize the calculator and create the widgets (GUI)
306init
307# chaque fois qu'une commande modifie la pile de nombres,
308# la commande drawStack sera appel�e pour la r�actualiser
309trace add variable ::stack write drawStack
310