/[ascend]/trunk/tcltk/TK/ScriptProc.tcl
ViewVC logotype

Annotation of /trunk/tcltk/TK/ScriptProc.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 659 - (hide annotations) (download) (as text)
Sun Jun 4 20:01:04 2006 UTC (17 years, 10 months ago) by ben.allan
File MIME type: text/x-tcl
File size: 80363 byte(s)
added File->Open everywhere equivalent to File->Read ...  to resolve pye request.
At a 1.0 release of tcltk, we should consider getting rid of
the file reads, but not before. existing users have muscle memories
that are not to be toyed with.
1 johnpye 571 # ScriptProc.tcl: Tcl code for Script window
2     # by Benjamin A. Allan and Kirk A. Abbott
3     # Created: January 1994
4     # Part of ASCEND
5     # Revision: $Revision: 1.89 $
6     # Last modified on: $Date: 2003/03/20 21:26:19 $
7     # Last modified by: $Author: aw0a $
8     # Revision control file: $RCSfile: ScriptProc.tcl,v $
9     #
10     # This file is part of the ASCEND Tcl/Tk Interface.
11     #
12     # Copyright (C) 1994-1998 Carnegie Mellon University
13     #
14     # The ASCEND Tcl/Tk Interface is free software; you can redistribute
15     # it and/or modify it under the terms of the GNU General Public
16     # License as published by the Free Software Foundation; either
17     # version 2 of the License, or (at your option) any later version.
18     #
19     # The ASCEND Tcl/Tk Interface is distributed in hope that it will be
20     # useful, but WITHOUT ANY WARRANTY; without even the implied warranty
21     # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22     # GNU General Public License for more details.
23     #
24     # You should have received a copy of the GNU General Public License
25     # along with the program; if not, write to the Free Software
26     # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the
27     # file named COPYING. COPYING is found in ../compiler.
28    
29     #
30     # proc ascconsole_open {}
31     #------------------------------------------------------------------------
32     # opens up a console, if it can.
33     #------------------------------------------------------------------------
34     proc ascconsole_open {} {
35     global ascScripVect
36     if {[catch {console show} err]} {
37     asctk_dialog .consolerr $ascScripVect(font) FYI \
38     "This version was not built with a console" "" 0 OK
39     return
40     }
41     console title {Ascend console}
42     }
43    
44     #
45     # ascresort_filetypes {arrayname extelt}
46     #------------------------------------------------------------------------
47     # This function takes the name of a global array and, assuming the elements
48     # $extelt, basefiletypes, and filetypes appear, reorders the
49     # definition of filetypes so that the entry of basefiletypes
50     # indicated in lastextension comes
51     # first while all the others come in the order of basefiletypes.
52     # This is so tk_GetOpen/SaveFile can 'remember' where they last were.
53     # This implementation is very ugly.
54     #------------------------------------------------------------------------
55     proc ascresort_filetypes {an extelt} {
56     global $an
57     set le [set ${an}($extelt)]
58     set firsttype ""
59     if {$le == ""} { return }
60     foreach i [set ${an}(basefiletypes)] {
61     set elist [lindex $i 1]
62     if {[lsearch -exact $elist $le] != -1} {
63     set firsttype $i
64     break
65     }
66     }
67     if {[string compare $firsttype ""] == 0} {
68     # this ought not be possible, but sometimes happens.
69     set firsttype [lindex [set ${an}(basefiletypes)] 0]
70     }
71     set ${an}(filetypes) ""
72     lappend ${an}(filetypes) $firsttype
73     foreach i [set ${an}(basefiletypes)] {
74     lappend ${an}(filetypes) $i
75     }
76     }
77    
78     #
79     # clears the interrupt flag of the script.
80     #
81     proc Script_ClearInterrupt {} {
82     global ascScripVect
83     set ascScripVect(menubreak) 0
84     }
85     #
86     # proc Script_CheckInterrupt {}
87     #------------------------------------------------------------------------
88     # returns an error (do not surround this call with catch)
89     # if the user interrupt has been detected. Clears that interrupt, too.
90     # All script that want to play nice should start with this call.
91     #------------------------------------------------------------------------
92     proc Script_CheckInterrupt {} {
93     global ascScripVect
94     if {$ascScripVect(menubreak) != 0} {
95     Script_ClearInterrupt
96     error "User interrupted the script"
97     }
98     }
99    
100     proc Toggle_Remote {a} {
101     global $a
102     if {[info exists ${a}(window.open)] == 0} {
103     trace vdelete ${a}(window.open) w Toggle_Window
104     if {[winfo ismapped [set ${a}(windowname]]} {
105     set ${a}(window.open) 1
106     } else {
107     set ${a}(window.open) 0
108     }
109     trace variable ${a}(window.open) w Toggle_Window
110     }
111     if {[set ${a}(window.open)]} {
112     set ${a}(window.open) 0
113     } else {
114     set ${a}(window.open) 1
115     }
116     }
117    
118     proc Toggle_Window {a s m} {
119     global $a
120     do_raise_lower [set ${a}(windowname)]
121     }
122    
123     #
124     # proc set_Script_Defaults {}
125     #------------------------------------------------------------------------
126     # standard startup once window is created
127     #
128     # ascScripVect is also home to script window state information.
129     # in particular file menu data.
130     # ascScripVect(curbufnum) is the presently viewed buffer. -1 is the
131     # bogus initialization value.
132     # ascScripVect(maxbufnum) is the highest available buffer num.
133     # ascScripVect(buffile.$c) is the filename corresponding to buffer $c
134     # ascScripVect(bufopen.$c) is the closed/open status of the buffer.
135     # note we need some file menu reconstruction if close is to be used.
136     #------------------------------------------------------------------------
137     proc set_Script_Defaults {} {
138     # puts "setting script buttons"
139     global ascScripVect env ascToolVect
140     set ascScripVect(filename) "[pwd]/."
141     Script_ClearInterrupt
142     # ascScripVect(menubreak) is a linked to C int variable.
143     set ascScripVect(Record) 0
144     trace variable ascScripVect(Record) w Script_record_label
145     set ascScripVect(executing) 0
146     set ascScripVect(count) 0
147     set ascScripVect(initialized) "FALSE"
148     set ascScripVect(keywords) ""
149     set ascScripVect(lastimportextension) ".s"
150     set ascScripVect(lastreadextension) ".a4s"
151     set ascScripVect(basefiletypes) {
152     {{ASCEND scripts} {.a4s .s} }
153     {{Tcl scripts} {.t .tcl} }
154     {{Most} {.*} }
155     {{All} {*} }
156     }
157     global ascLibrVect ascSimsVect ascBrowVect ascProbVect
158     global ascSolvVect ascDispVect ascUnitVect ascToolVect
159     trace variable ascLibrVect(window.open) w Toggle_Window
160     trace variable ascSimsVect(window.open) w Toggle_Window
161     trace variable ascBrowVect(window.open) w Toggle_Window
162     trace variable ascProbVect(window.open) w Toggle_Window
163     trace variable ascSolvVect(window.open) w Toggle_Window
164     trace variable ascDispVect(window.open) w Toggle_Window
165     trace variable ascUnitVect(window.open) w Toggle_Window
166     trace variable ascToolVect(window.open) w Toggle_Window
167    
168     set ascScripVect(filetypes) $ascScripVect(basefiletypes)
169    
170     set ascScripVect(fileBtn) .script.menubar.file
171     set ascScripVect(editBtn) .script.menubar.edit
172     set ascScripVect(execBtn) .script.menubar.execute
173     set ascScripVect(RecordBtn) .script.check_frm.record_btn
174     set ascScripVect(fileentry) .script.check_frm.file_entry
175     # check for cmu. normally unset outside cmu.
176     if {[string first cmu.edu [info hostname]] != -1 || \
177     [string first gams.com [info hostname]] != -1} {
178     set ascScripVect(developer) 1
179     }
180     # set ascScripVect(scripBox) now done in ScriptSwitchBuf
181     # buffer manager inits
182     set ascScripVect(mainframe) .script.main_frm
183     set ascScripVect(curbufnum) -1
184     set ascScripVect(maxbufnum) 0
185     ScriptSwitchToNewBuf 0 "License-Warranty.tcl"
186     Script_Read_File $env(ASCENDTK)/License-Warranty.tcl
187     Configure_Script
188     }
189    
190     #
191     # proc Configure_Script {}
192     #------------------------------------------------------------------------
193     # set script bindings and some other misc stuff like the keywords list
194     #------------------------------------------------------------------------
195     proc Configure_Script {} {
196     global ascScripVect
197     if {$ascScripVect(initialized) == "TRUE"} {
198     return;
199     }
200    
201     bind $ascScripVect(fileentry) <F3> ScriptFile_do_Copy
202    
203     # Update Enabled/Disabled entries when a menu is posted
204     #
205     $ascScripVect(editBtn) configure \
206     -postcommand Script_Update_Edit_Buttons
207    
208     $ascScripVect(execBtn) configure \
209     -postcommand Script_Update_Exec_Buttons
210    
211     $ascScripVect(fileBtn) configure \
212     -postcommand Script_Update_File_Buttons
213    
214     .script.menubar.view configure \
215     -postcommand Script_Update_View_Buttons
216    
217     # ScriptAddRightMenu
218    
219     $ascScripVect(scripBox) insert 1.0 "\n"
220     # All registered keywords are expected to call Script_CheckInterrupt
221     # as they start execution.
222    
223     set ascScripVect(keywords) [list \
224     READ \
225     COMPILE \
226     DISPLAY \
227     RUN \
228     PRINT \
229     DELETE \
230     SOLVE \
231     INTEGRATE \
232     RESTORE \
233     WRITE \
234     MERGE \
235     REFINE \
236     RESUME \
237     SAVE \
238     PLOT \
239     SHOW \
240     OBJECTIVE \
241     BROWSE \
242     DISPVAL \
243     DISPATTR \
244     ASSIGN \
245     PROBE \
246     ASCPLOT \
247     EXIT]
248     }
249    
250     proc ScriptAddRightMenu {} {
251     global ascScripVect
252     # build right popup menu
253     ascRightMouseAddCommand $ascScripVect(scripBox) ScriptSelectState \
254     command -label "Execute selected statements" \
255     -underline -1 -command Script_do_ExecuteStats
256    
257     ascRightMouseAddCommand $ascScripVect(scripBox) ScriptSelectState \
258     command -label "Step through statements selected" \
259     -underline -1 -command {Script_do_ExecuteStats 0}
260    
261     ascRightMouseAddCommand $ascScripVect(scripBox) normal \
262     checkbutton -variable ascScripVect(Record) \
263     -offvalue {0} \
264     -onvalue {1} \
265     -label {Record actions} \
266     -underline -1
267    
268     ascRightMouseAddCommand $ascScripVect(scripBox) normal \
269     command -label "Select all" \
270     -underline -1 -command Script_do_SelectAll
271    
272     ascRightMouseAddCommand $ascScripVect(scripBox) ScriptSaveState \
273     command -label "Save" \
274     -underline -1 -command Script_do_WriteBuf
275    
276     ascRightMouseAddCommand $ascScripVect(scripBox) normal \
277     command -label "Exit ASCEND..." \
278     -underline -1 -command Script_do_Exit
279     }
280    
281     proc Script_do_SaveOptions {} {
282     global ascScripVect
283     # since its appearance only, just do it.
284     View_Save_Interface_Values
285     # ascParPage ascViewSaveVect [setpos $ascScripVect(windowname) 0 0] 1 0
286     }
287     #
288     #---------------------------------------------------------------------------
289     #buffer management stuff
290     #---------------------------------------------------------------------------
291    
292     proc ScriptSwitchBuf {num {fname ""}} {
293     ScriptSwitchToNewBuf $num $fname
294     }
295     #
296     # proc ScriptSwitchToNewBuf {num {fname ""}}
297     #---------------------------------------------------------------------------
298     # valid num are 1..infinity integer.
299     # caller is expected to keep track of what good nums are.
300     # Expected to be set unless num is new:
301     # ascScripVect(bufopen.$num) open/closed status of prior buffers.
302     # could be used to make a reopen menu...
303     # ascScripVect(buffile.$num) the filename of numbered buffer
304     # ascScripVect(mainframe) the name of the parent for all script_box widgets
305     # ascScripVect(curbufnum) the number of the buffer in use currently
306     #
307     # switches to the numbered buffer. if the buffer isn't open,
308     # creates it. If fname is given != "" on a closed buffer,
309     # will read the buffer from disk, eventually...
310     # as we can see, this function needs to be decomposed.
311     #---------------------------------------------------------------------------
312     proc ScriptSwitchToNewBuf {num fname} {
313     global ascScripVect ascGlobalVect
314     if {$ascScripVect(curbufnum) == $num} {
315     return
316     }
317     set filename "foobar"
318     set parentname $ascScripVect(mainframe)
319     if {$fname == ""} {
320     set filename NoName$num.s
321     set ascScripVect(buffile.$num) $filename
322     set ascScripVect(bufopen.$num) 0
323     } else {
324     set filename $fname
325     }
326     set oldnum $ascScripVect(curbufnum)
327     set oldbufname .script_box_$oldnum
328     catch {pack forget $parentname$oldbufname}
329     set ascScripVect(curbufnum) $num
330     set ascScripVect(scripBox) $parentname.script_box_$num.text2
331    
332     build_scriptbox $parentname $num $ascScripVect(font)
333    
334     # pack widget $parentname
335     pack append $parentname \
336     $parentname.script_box_$num {top frame center expand fill}
337     $ascScripVect(fileBtn) add command \
338     -command "ScriptSwitchToOldBuf $num \{$filename\}" \
339     -label $filename
340     set ascScripVect(bufopen.$num) 1
341     $parentname.script_box_$num.text2 insert end {}
342    
343     incr ascScripVect(maxbufnum)
344     ScriptAddRightMenu
345     update
346     update idletasks
347     }
348    
349    
350     proc ScriptSwitchToOldBuf {num fname} {
351    
352     global ascScripVect
353    
354     set parentname $ascScripVect(mainframe)
355     set oldnum $ascScripVect(curbufnum)
356     set oldbufname .script_box_$oldnum
357     catch {pack forget $parentname$oldbufname}
358     set ascScripVect(curbufnum) $num
359     set ascScripVect(filename) "$fname"
360     set ascScripVect(scripBox) $parentname.script_box_$num.text2
361     pack append $parentname \
362     $parentname.script_box_$num {top frame center expand fill}
363    
364     update
365     update idletasks
366     }
367    
368     #
369     #---------------------------------------------------------------------------
370     # ASCEND Script keyword implementations:
371     # Script keywords are commands defined for ASCEND (in CAPS) which may be
372     # used on the commandline or in the Script. Keywords are actually Tcl
373     # functions which encapsulate 1 or more of the C primitives and other
374     # Tcl procedures so the user can conveniently emulate button presses.
375     # Each keyword takes 0 or more arguments.
376     #
377     # <arg> indicates the use of arg is NOT optional.
378     # <a1,a2> indicates that the use of either a1 or a2 is required
379     # <a1 a2> indicates use of both a1 and a2 required. Usually written <a1> <a2>
380     # [a1] indicate the use of a1 is optional.
381     # [a,b] indicates that either a or b is optional but not both.
382     #
383     # qlfdid is short for 'QuaLiFieD IDentifier'
384     # qlfpid is short for 'QuaLiFied Procedure IDentifier'
385     #
386     # OF, WITH, TO, and other args in all CAPS are modifiers to the keyword
387     # which make it do different things.
388     #
389     # It is generally best to enclose all object names and units in {braces} to
390     # prevent Tcl from performing string substitution or otherwise operating
391     # on the arguments before passing them to the keyword function.
392     #
393     # Quick reference:
394     # ASSIGN set the value of something atomic
395     # ASCPLOT generate a defaulted graph from input file
396     # BROWSE export an object to the browser
397     # COMPILE compile a simulation of a given type
398     # DELETE delete a simulation or the type library or the solver MODEL
399     # * DISPLAY display something
400     # EXIT exit ascend
401     # INTEGRATE run an IVP integrator
402     # MERGE perform an ARE_THE_SAME
403     # PLOT create a plot file
404     # PRINT print one of the printable windows
405     # PROBE export an object to the probe
406     # READ read in a model, script, or values file.
407     # REFINE perform an IS_REFINED_TO
408     # * RESTORE read a simulation from disk.
409     # RESUME resume compiling a simulation
410     # RUN run a procedure
411     # * SAVE write a simulation to disk
412     # SHOW call a unix plot program on a file from PLOT
413     # SOLVE run the solver
414     # WRITE write values in Tcl format to disk
415     #
416     #---------------------------------------------------------------------------
417     #
418     # proc ASSIGN <qlfdid> <value> [units]
419     #------------------------------------------------------------------------
420     # set the value of atom 'qlfdid' from the script. If value is real, give a set
421     # of units compatible with the dimensions of the variable. If the variable
422     # has no dimensions yet, ASSIGN will fix the dimensions.
423     #------------------------------------------------------------------------
424     proc ASSIGN {qlfdid args} {
425     Script_CheckInterrupt
426     set argc [llength $args]
427     switch $argc {
428     {1} {set val $args; set units ""}
429     {2} {set val [lindex $args 0]
430     set units [lindex $args 1]
431     }
432     default {error "ASSIGN expected: qlfdid value \[units\]"}
433     }
434     qassgn3 $qlfdid $val $units
435     if {$val=="FALSE" || $val =="TRUE" || $val=="false" || $val =="true" } {
436     HUB_Message_to_HUB WHENVARUPDATED $qlfdid
437     HUB_Message_to_HUB BOOLEANUPDATED $qlfdid
438     } else {
439     HUB_Message_to_HUB VARIABLEUPDATED $qlfdid
440     }
441     HUB_Message_to_HUB VALUESET $qlfdid $val $units
442     }
443    
444     #
445     # proc BROWSE <qlfdid>
446     #------------------------------------------------------------------------
447     # export qlfdid to the browser
448     #------------------------------------------------------------------------
449     proc BROWSE {qlfdid} {
450     Script_CheckInterrupt
451     global ascBrowVect
452     if {$ascBrowVect(visibility)} {newraise .browser}
453     Brow_Export_Any_2Browser $qlfdid
454     }
455    
456    
457     #
458     # proc READ [FILE,<VALUES,SCRIPT>] <filename>
459     #------------------------------------------------------------------------
460     # Load a file from disk.
461     # Searches for files in directories (Working directory):.:$ASCENDLIBRARY
462     # unless a full path name is given for filename.
463     # FILE indicates ASCEND source code (.asc usually)
464     # VALUES indicates variable data written by WRITE VALUES (.values usually)
465     # SCRIPT indicates a file to load at the end of the Script window. (.a4s,.s)
466     # If neither VALUES nor SCRIPT found, FILE will be assumed.
467     #
468     # Note: You will get quite a spew from the parser if you leave out the
469     # SCRIPT or VALUES modifier by accident.
470     # Capitalization on file,script, and values will be ignored.
471     #
472     #------------------------------------------------------------------------
473     proc READ {args} {
474     Script_CheckInterrupt
475     global ascLibrVect env ascToolVect ascBrowVect
476     set argc [llength $args]
477     set type ""
478     set force 0
479     switch $argc {
480     {1} {
481     set file $args
482     set type file
483     set extension "[file extension $file]"
484     set found 0
485     if {$extension != ""} {
486     set found \
487     [expr [lsearch -exact [libr_query -filetypes] $extension] != -1]
488     }
489     if {!$found && $extension != ".patch"} {
490     set geom 200x120+480+200
491     set errmsg \
492     "File $file\n may not be a valid ASCEND model file.\nContinue ?"
493     set btn [Script_Raise_Alert $errmsg "Odd file name"]
494     if {$btn} {return}
495     }
496     }
497     {2} {
498     set file [lindex $args 1]
499     set type [lindex $args 0]
500     set type [string tolower $type]
501     if {$type != "file" && $type != "values" && $type != "script"} {
502     puts stderr "Non-fatal script error: [lindex $args 0] found."
503     puts stderr "FILE, SCRIPT or VALUES expected. FILE assumed."
504     set type FILE
505     }
506     }
507     {3} {
508     set file [lindex $args 1]
509     set type [lindex $args 0]
510     set type [string tolower $type]
511     set nc [string tolower [lindex $args 2]]
512     if {$type != "values"} {
513     error "READ expected VALUES <filename> NOCONFIRM"
514     }
515     if {[string compare $nc noconfirm]} {
516     error "READ expected VALUES <filename> NOCONFIRM"
517     }
518     set force 1
519     }
520     default {
521     error "READ expected [FILE,VALUES,SCRIPT] <filename> [NOCONFIRM]"
522     }
523     }
524     set badname $file
525     set file [ascFindFile $file first \
526     $ascToolVect(dirinput) "." $env(ASCENDLIBRARY)]
527     if {$file==""} {
528     set mesg "READ file \""
529     append mesg $badname
530     append mesg "\" not found in . or \n"
531     append mesg $ascToolVect(dirinput)
532     append mesg " or any of \n"
533     append mesg $env(ASCENDLIBRARY)
534     append mesg "\n Continue? "
535     set btn [Script_Raise_Alert $mesg]
536     if {$btn} {
537     error "Cannot continue without file."
538     }
539     } else {
540     puts -nonewline "READing file "
541     puts $file
542     }
543     switch $type {
544     {file} {
545     global ascLibrVect
546     if {$ascLibrVect(visibility)} {newraise .library}
547     set nok [catch {Libr_file_get $file} msg]
548     if {$nok} {
549     error "Problem reading $file: $msg"
550     }
551     }
552     {values} {
553     puts "Reading values from $file"
554     if {[catch {Brow_parse_values $file $force} err]} {
555     puts stderr "Problem reading values file:"
556     puts stderr "error>>>$err<<<"
557     }
558     set ascBrowVect(filename) $file
559     #
560     # here we should be grabbing the first line of filename, taking its
561     # second to last item, and issuing the updated calls with that sim name.
562     #
563     HUB_Message_to_HUB VARIABLEUPDATED
564     HUB_Message_to_HUB BOOLEANUPDATED
565     HUB_Message_to_HUB WHENVARUPDATED
566     HUB_Message_to_HUB DATAREAD $file
567     }
568     {script} {
569     set extension [file extension $file]
570     if {$extension != ".s" && \
571     $extension != ".tcl" && \
572     $extension != ".a4s"} {
573     set geom "200x120+480+200"
574     set errmsg \ "File\n"
575     append errmsg $file
576     append errmsg "\n may not be a valid ASCEND script\n Continue ?"
577     set btn [Script_Raise_Alert $errmsg]
578     if {$btn == "1"} {return}
579     }
580     Script_File_Get $file
581     }
582     }
583     }
584    
585     #
586     # proc ASCPLOT <filename>
587     #------------------------------------------------------------------------
588     # Build a graph from a .dat file.
589     # Assumes lots of things about the plot because there are lots
590     # of alternatives.
591     # If filename is close, closes the ascplot window.
592     # Returns the number of the last data set from the file read,
593     # or -1 if closing.
594     # should put a DELETE option in here to call _unload $args
595     #------------------------------------------------------------------------
596     proc ASCPLOT {filename args} {
597     global ascplotvect
598     switch [string tolower $filename] {
599     close {
600     ascplot_dook
601     return -1
602     }
603     default {
604     ascplot_open
605     set dset [ascplot_parse_file $filename]
606     if {$dset >= 0} {
607     ascplot_drawsets
608     ascplot_select_set_by_number $dset
609     set ilist {}
610     set len [$ascplotvect(varsname) index end]
611     for {set i 0} {$i < $len} {incr i} {
612     lappend ilist $i
613     }
614     ascplot_seldependent_list $ilist
615     ascplot_showdata 1
616     ascplot_setlegends
617     ascplot_viewgraph
618     return $dset;
619     } else {
620     error "ASCPLOT: bad input file \"$filename.\""
621     }
622     }
623     }
624     }
625    
626     #
627     # proc COMPILE <simname> [OF] <type>.
628     #------------------------------------------------------------------------
629     # Build a simulation of the type given with name simname.
630     # You can get away with leaving out OF or spelling it wrong.
631     #------------------------------------------------------------------------
632     proc COMPILE {args} {
633     Script_CheckInterrupt
634     global ascSimsVect
635     set argc [llength $args]
636     switch $argc {
637     {2} {
638     set sim [lindex $args 0]
639     set type [lindex $args 1]
640     }
641     {3} {
642     set sim [lindex $args 0]
643     set type [lindex $args 2]
644     if {[lindex $args 1] != "OF"} {
645     puts stderr \
646     "Non-fatal script error: [lindex $args 1] found. OF expected."
647     }
648     }
649     default {
650     error "COMPILE expected <simname> [OF] <type>."
651     }
652     }
653     if {$ascSimsVect(visibility)} {newraise .sims}
654     update
655     set ascSimsVect(instancetype) $type
656     if {![sim_unique $sim]} {
657     error "Simulation named $sim already exists!"
658     }
659     puts stdout "COMPILEing $sim OF $type"
660     set nok [catch "sim_instantiate $sim $type" err_msg]
661     if {$nok} {
662     error "$err_msg"
663     }
664     HUB_Message_to_HUB SIMCREATED $sim $type
665     Sims_update_SimsBox
666     }
667    
668     proc PATCH {args} {
669     Script_CheckInterrupt
670     global ascSimsVect
671     set argc [llength $args]
672     switch $argc {
673     {2} {
674     set sim [lindex $args 0]
675     set type [lindex $args 1]
676     }
677     {3} {
678     set sim [lindex $args 0]
679     set type [lindex $args 2]
680     if {[lindex $args 1] != "OF"} {
681     puts stderr \
682     "Non-fatal script error: [lindex $args 1] found. OF expected."
683     }
684     }
685     default {
686     error "PATCH expected <simname> [OF] <patch_type>."
687     }
688     }
689     if {$ascSimsVect(visibility)} {newraise .sims}
690     update
691     set ascSimsVect(instancetype) $type
692     if {![sim_unique $sim]} {
693     error "Simulation named $sim already exists!"
694     }
695     puts stdout "COMPILEing $sim PATCH for $type"
696     set nok [catch "sim_instantiate $sim $type -p" err_msg]
697     if {$nok} {
698     error "$err_msg"
699     }
700     HUB_Message_to_HUB SIMCREATED $sim $type
701     Sims_update_SimsBox
702     }
703    
704     #
705     # proc RUN <qlfpid>
706     #------------------------------------------------------------------------
707     # runs the procedure qlfpid as if from the browser Initialize button.
708     #------------------------------------------------------------------------
709     proc RUN {qlfpid} {
710     Script_CheckInterrupt
711     global ascLibrVect
712     set id [split $qlfpid .]
713     set len [llength $id]
714     set pid [lindex $id [expr $len -1]]
715     set id [lrange $id 0 [expr $len -2]]
716     set qlfdid [join $id .]
717     brow_runmethod -method $pid -qlfdid $qlfdid \
718     -backtrace $ascLibrVect(btuifstop) \
719     -stopOnErr $ascLibrVect(ignorestop)
720    
721     HUB_Message_to_HUB PROCRUN $qlfpid
722     HUB_Message_to_HUB VARIABLEUPDATED $qlfpid
723     HUB_Message_to_HUB WHENVARUPDATED $qlfpid
724     HUB_Message_to_HUB BOOLEANUPDATED $qlfpid
725     }
726    
727     #
728     # proc PRINT <PROBE,DISPLAY>
729     #------------------------------------------------------------------------
730     # Prints out the Probe or Display text in view.
731     #------------------------------------------------------------------------
732     proc PRINT {topid} {
733     Script_CheckInterrupt
734     switch $topid {
735     {PROBE} { Probe_do_Print; return}
736     {DISPLAY} { DispExecutePrint ; return}
737     default { error "PRINT <PROBE or DISPLAY>"}
738     }
739     }
740    
741     #
742     # proc CLEAR_VARS <qlfdid>
743     #------------------------------------------------------------------------
744     # Sets all fixed flags in qlfdid to FALSE
745     #------------------------------------------------------------------------
746     proc CLEAR_VARS {qlfdid} {
747     Script_CheckInterrupt
748     entertrace
749     Solve_do_Flush do_not_record
750     free_all_vars $qlfdid
751     leavetrace
752     }
753    
754     #
755     # proc PROTOTYPE <simulation name>
756     #------------------------------------------------------------------------
757     # Creates a PROTOTYPE of the given simulation name
758     #------------------------------------------------------------------------
759     proc PROTOTYPE {name} {
760     Script_CheckInterrupt
761     __sims_proto $name
762     }
763    
764    
765     #
766     # proc DELETE <TYPES,simname,SYSTEM>
767     #------------------------------------------------------------------------
768     # Delete all types or delete specified simulation, or flush solver.
769     # If you name a simulation TYPES or SYSTEM you get what you deserve.
770     #------------------------------------------------------------------------
771     proc DELETE {foo args} {
772     Script_CheckInterrupt
773     switch $foo {
774     {TYPES} {Libr_do_DeleteAll 1; return}
775     {SYSTEM} {Solve_do_Flush; return}
776     default {
777     Sims_Delete $foo
778     Sims_update_SimsBox
779     }
780     }
781     }
782    
783     #
784     # proc SOLVE <qlfdid> [WITH] [solvername]
785     #------------------------------------------------------------------------
786     # Fires off current solver unless another is specified. WITH optional.
787     # Whatever is in the solver window gets displaced.
788     # Solvername must be given as it appears on the menu buttons.
789     #------------------------------------------------------------------------
790     proc SOLVE {qlfdid args} {
791     Script_CheckInterrupt
792     entertrace
793     global ascSolvVect ascSolvStatVect
794     if {[slv_import_qlfdid $qlfdid test]} {
795     error "$qlfdid not solvable instance"
796     }
797     if {$ascSolvVect(visibility)} {newraise .solver}
798     set argc [llength $args]
799     switch $argc {
800     {0} {
801     Solve_Import_Any $qlfdid
802     Solve_do_Select QRSlv
803     Solve_do_Solve
804     leavetrace; return
805     }
806     {1} { set solname [lindex $args 0]
807     # go off of C structure here...
808     #
809     # Now we call solvers by name
810     #
811     switch $solname {
812     {Slv} -
813     {slv} {set solname Slv}
814     {MINOS} -
815     {minos} {set solname MINOS}
816     {QRSlv} -
817     {qrslv} {set solname QRSlv}
818     {LSSlv} -
819     {lsslv} {set solname LSSlv}
820     {NGSlv} -
821     {ngslv} {set solname NGSlv}
822     {CONOPT} -
823     {conopt} {set solname CONOPT}
824     {LRSlv} -
825     {lrslv} {set solname LRSlv}
826     {CMSlv} -
827     {cmslv} {set solname CMSlv}
828     default {error "SOLVE called with $solname. (Unrecognized)"}
829     }
830     set ascSolvVect(simname) [lindex [split $qlfdid .] 0]
831     slv_import_qlfdid $qlfdid
832     set ascSolvStatVect(menubreak) 0
833     slv_set_haltflag 0
834     set ascSolvStatVect(empty) 0
835     # Solve_do_Select $num
836     Solve_do_Select $solname
837     Solve_Update_Listbox
838     Solve_Update_MenuBar
839     Solve_Downdate_ParmBox
840     if {$ascSolvVect(debuggerup)} {
841     Debug_Trace on
842     }
843     if {$ascSolvVect(mtxup)} {
844     Solve_do_DispIncidence
845     }
846     Solve_do_Solve
847     leavetrace; return
848     }
849     {2} { set WITH [lindex $args 0]
850     set solname [lindex $args 1]
851     if {[string tolower $WITH] != "with"} {
852     puts stderr \
853     "Non-fatal script error: $WITH found. WITH expected."
854     }
855     #
856     # Now we call solvers by name
857     #
858     switch $solname {
859     {Slv} -
860     {slv} {set solname Slv}
861     {MINOS} -
862     {minos} {set solname MINOS}
863     {QRSlv} -
864     {qrslv} {set solname QRSlv}
865     {LSSlv} -
866     {lsslv} {set solname LSSlv}
867     {NGSlv} -
868     {ngslv} {set solname NGSlv}
869     {CONOPT} -
870     {conopt} {set solname CONOPT}
871     {LRSlv} -
872     {lrslv} {set solname LRSlv}
873     {CMSlv} -
874     {cmslv} {set solname CMSlv}
875     default {
876     error "SOLVE called with $solname. \
877     expected Slv, MINOS. QRSlv, LSSlv, NGSlv, LRSlv, CMSlv"
878     }
879     }
880     set ascSolvVect(simname) [lindex [split $qlfdid .] 0]
881     slv_import_qlfdid $qlfdid
882     set ascSolvStatVect(menubreak) 0
883     slv_set_haltflag 0
884     set ascSolvStatVect(empty) 0
885     # Solve_do_Select $num
886     Solve_do_Select $solname
887     Solve_Update_Listbox
888     Solve_Update_MenuBar
889     Solve_Downdate_ParmBox
890     if {$ascSolvVect(debuggerup)} {
891     Debug_Trace on
892     }
893     if {$ascSolvVect(mtxup)} {
894     Solve_do_DispIncidence
895     }
896     Solve_do_Solve
897     leavetrace; return
898     }
899     default {error "Syntax: SOLVE instance [WITH] [solvername]"}
900     }
901     }
902    
903     #
904     # proc OPTIMIZE <objname> <IN> <qlfdid> <WITH> <solvername>
905     #------------------------------------------------------------------------
906     # Fires off solvername on qlfdid with obj as the objective function.
907     # Whatever is in the solver window gets displaced.
908     # Solvername must be given as it appears on the menu buttons.
909     #------------------------------------------------------------------------
910     proc OPTIMIZE {objname in qlfdid with solname} {
911     Script_CheckInterrupt
912     entertrace
913     global ascSolvVect ascSolvStatVect
914     if {[slv_import_qlfdid $qlfdid test]} {
915     error "$qlfdid not solvable instance"
916     }
917    
918     if {$ascSolvVect(visibility)} {newraise .solver}
919     switch $solname {
920     {Slv} - {slv} {set solname Slv}
921     {MINOS} - {minos} {set solname MINOS}
922     {QRSlv} - {qrslv} {set solname QRSlv}
923     {LSSlv} - {lsslv} {set solname LSSlv}
924     {NGSlv} - {ngslv} {set solname NGSlv}
925     {CONOPT} - {conopt} {set solname CONOPT}
926     {LRSlv} - {lrslv} {set solname LRSlv}
927     {CMSlv} - {cmslv} {set solname CMSlv}
928     default {error "OPTIMIZE called with $solname. (Unrecognized)"}
929     }
930     set ascSolvVect(simname) [lindex [split $qlfdid .] 0]
931     slv_import_qlfdid $qlfdid
932     set ascSolvStatVect(menubreak) 0
933     slv_set_haltflag 0
934     set ascSolvStatVect(empty) 0
935     Solve_do_Select $solname
936     Solve_Update_Listbox
937     Solve_Update_MenuBar
938     Solve_Downdate_ParmBox
939    
940     set obj_num [Solve_GetObjRelNum $objname]
941     catch {slv_set_obj_by_num $obj_num}
942    
943     if {$ascSolvVect(debuggerup)} {
944     Debug_Trace on
945     }
946     if {$ascSolvVect(mtxup)} {
947     Solve_do_DispIncidence
948     }
949     Solve_do_Solve
950     leavetrace; return
951     }
952    
953     #
954     # proc INTEGRATE_syntax {qlfdid args}
955     #------------------------------------------------------------------------
956     # INTEGRATE_syntax error message
957     #------------------------------------------------------------------------
958     proc INTEGRATE_syntax {qlfdid args} {
959     Script_CheckInterrupt
960     puts stderr "Error parsing $args."
961     puts stderr "Integrator script syntax is:"
962     puts stderr "INTEGRATE $qlfdid (assumes range and BLSODE)"
963     puts stderr "INTEGRATE $qlfdid WITH integrator (assumes range)"
964     puts stderr "INTEGRATE $qlfdid FROM n1 TO n2 (assumes BLSODE)"
965     puts stderr "INTEGRATE $qlfdid FROM n1 TO n2 WITH integrator"
966     return "INTEGRATE miscalled."
967     }
968     #
969     # proc INTEGRATE {qlfdid args}
970     #------------------------------------------------------------------------
971     # Run an integrator on qlfdid. There are several permutations
972     # on the syntax. It is best to have solved qlfdid before hand to have
973     # good initial values.
974     # INTEGRATE qlfdid (assumes BLSODE and entire range)
975     # INTEGRATE qlfdid WITH (assumes entire range)
976     # INTEGRATE qlfdid FROM n1 TO n2 (assumes BLSODE)
977     # INTEGRATE qlfdid FROM n1 TO n2 WITH integrator
978     # Requires:
979     # n1 < n2
980     # qlfdid be of an integrable type (a refinement of ivp or blsode-ified.)
981     #------------------------------------------------------------------------
982     proc INTEGRATE {qlfdid args} {
983     Script_CheckInterrupt
984     global ascSolvVect ascSolvStatVect
985     if {[slv_import_qlfdid $qlfdid test]} {
986     error "$qlfdid not solvable instance"
987     }
988     qlfdid $qlfdid
989     # if {![integrate_able search ivp]} {error "$qlfdid not a refinement of ivp"}
990     if {$ascSolvVect(visibility)} {newraise .solver}
991     set argc [llength $args]
992     switch $argc {
993     {0} {
994     set ivpsolver BLSODE
995     set n1 first
996     set n2 last
997     Solve_do_Select QRSlv
998     }
999     {2} {
1000     set WITH [lindex $args 0]
1001     if {[string tolower $WITH]!="with"} {
1002     error "[INTEGRATE_syntax $qlfdid $args]"
1003     }
1004     set ivpsolver [lindex $args 1]
1005     set n1 first
1006     set n2 last
1007     }
1008     {4} {
1009     set FROM [lindex $args 0]
1010     if {[string tolower $FROM]!="from"} {
1011     error "[INTEGRATE_syntax $qlfdid $args]"
1012     }
1013     set TO [lindex $args 2]
1014     if {[string tolower $TO]!="to"} {
1015     error "[INTEGRATE_syntax $qlfdid $args]"
1016     }
1017     set ivpsolver BLSODE
1018     set n1 [lindex $args 1]
1019     set n2 [lindex $args 3]
1020     Solve_do_Select QRSlv
1021     }
1022     {6} {
1023     set FROM [lindex $args 0]
1024     if {[string tolower $FROM]!="from"} {
1025     error "[INTEGRATE_syntax $qlfdid $args]"
1026     }
1027     set TO [lindex $args 2]
1028     if {[string tolower $TO]!="to"} {
1029     error "[INTEGRATE_syntax $qlfdid $args]"
1030     }
1031     set WITH [lindex $args 4]
1032     if {[string tolower $WITH]!="with"} {
1033     error "[INTEGRATE_syntax $qlfdid $args]"
1034     }
1035     set ivpsolver [lindex $args 5]
1036     if {$ivpsolver == "LSODE" && ![integrate_able search ivp]} {
1037     error "$qlfdid not a refinement of lsode."
1038     }
1039     set n1 [lindex $args 1]
1040     set n2 [lindex $args 3]
1041     }
1042     default {error "[INTEGRATE_syntax $qlfdid $args]"}
1043     }
1044     puts "$qlfdid $n1 $n2 $ivpsolver"
1045     set ascSolvVect(simname) [lindex [split $qlfdid .] 0]
1046     slv_import_qlfdid $qlfdid
1047     set ascSolvStatVect(menubreak) 0
1048     set ascSolvStatVect(empty) 0
1049     Solve_Update_StatusBox;# <<< was missing from distributed version.
1050     # Solve_do_Select 0
1051     Solve_Update_Listbox
1052     Solve_Update_MenuBar
1053     Solve_Downdate_ParmBox
1054     if {$ascSolvVect(debuggerup)} {
1055     Debug_Trace on
1056     }
1057     if {$ascSolvVect(mtxup)} {
1058     Solve_do_DispIncidence
1059     }
1060     Solve_Integrate $ivpsolver $n1 $n2
1061     }
1062    
1063     #
1064     # proc RESTORE <file>
1065     #------------------------------------------------------------------------
1066     # reload a simulation from disk
1067     #------------------------------------------------------------------------
1068     proc RESTORE {filename} {
1069     Script_CheckInterrupt
1070     error "Restoring simulations not implemented yet.\n"
1071     }
1072    
1073     #
1074     # proc WRITE <kind> <qlfdid> <file> [args]
1075     #------------------------------------------------------------------------
1076     # Write something (what sort of write indicated by kind) about
1077     # qlfdid to a file. args may modify as determined by kind.
1078     # At present only VALUES is supported. SYSTEM (for solver dump) would be nice.
1079     # e.g. WRITE VALUES filename.
1080     #------------------------------------------------------------------------
1081     proc WRITE {kind inst filename args} {
1082     Script_CheckInterrupt
1083     set argc [llength $args]
1084     switch $kind {
1085     {VALUES} {
1086     set ascBrowVect(filename) $filename
1087     set sim [stripbraces [lindex [split $inst .] 0]]
1088     puts $sim
1089     if {[catch {qlfdid $inst} err_msg]} {
1090     error "WRITE failed to find instance specified to it.\n $err_msg"
1091     }
1092     bwritevalues $filename "qassgn3 \{" qualified $inst fast
1093     puts "Wrote values file $filename."
1094     }
1095     default {error "WRITE called with unknown output kind $kind"}
1096     }
1097     }
1098    
1099     #
1100     # proc MERGE <qlfdid1> [WITH] <qlfdid2>
1101     #------------------------------------------------------------------------
1102     # ARE_THE_SAME qlfdid1 and qlfdid2 if possible.
1103     #------------------------------------------------------------------------
1104     proc MERGE {qlf1 args} {
1105     Script_CheckInterrupt
1106     set argc [llength $args]
1107     switch $argc {
1108     {0} {
1109     error "MERGE requires an instance to merge with"
1110     }
1111     {1} {
1112     if {[lindex [split $qlf1 .] 0] != [lindex [split $args .] 0]} {
1113     error "MERGE requires two instances in the same simulation"
1114     }
1115     HUB_Message_to_HUB INSTANCEMOVED $qlf1
1116     HUB_Message_to_HUB INSTANCEMOVED $qlf2
1117     smerge $qlf1 $args
1118     HUB_Message_to_HUB INSTMERGED $qlf1 $qlf2
1119     return
1120     }
1121     {2} { set WITH [lindex $args 0]
1122     set qlf2 [lindex $args 1]
1123     if {[string tolower $WITH] != "with"} {
1124     puts stderr \
1125     "Non-fatal script error: $WITH found. WITH expected."
1126     }
1127     if {[lindex [split $qlf1 .] 0] != [lindex [split $qlf2 .] 0]} {
1128     error "MERGE requires two instances in the same simulation"
1129     }
1130     HUB_Message_to_HUB INSTANCEMOVED $qlf1
1131     HUB_Message_to_HUB INSTANCEMOVED $qlf2
1132     smerge $qlf1 $qlf2
1133     HUB_Message_to_HUB INSTMERGED $qlf1 $qlf2
1134     return
1135     }
1136     default {error "Syntax: MERGE instance [WITH] instance"}
1137     }
1138     }
1139    
1140     #
1141     # proc REFINE <qlfdid> [TO] <type>
1142     #------------------------------------------------------------------------
1143     # Refine qlfdid to given type if they are conformable.
1144     #------------------------------------------------------------------------
1145     proc REFINE {qlfdid args} {
1146     Script_CheckInterrupt
1147     set argc [llength $args]
1148     switch $argc {
1149     {0} {
1150     error "REFINE requires a type to refine the instance to"
1151     }
1152     {1} {
1153     if {![libr_query -exists -type $args]} {
1154     error "REFINE $qlfdid called with nonexistent type $args"
1155     }
1156     HUB_Message_to_HUB INSTANCEMOVED $qlfdid
1157     srefine $args search $qlfdid
1158     HUB_Message_to_HUB INSTREFINED $qlfdid $args
1159     return
1160     }
1161     {2} { set TO [lindex $args 0]
1162     set Type [lindex $args 1]
1163     if {$TO != "TO"} {
1164     puts stderr \
1165     "Non-fatal script error: $TO found. TO expected."
1166     }
1167     HUB_Message_to_HUB INSTANCEMOVED $qlfdid
1168     srefine $Type search $qlfdid
1169     HUB_Message_to_HUB INSTREFINED $qlfdid $Type
1170     return
1171     }
1172     default {error "Syntax: REFINE instance [TO] [typename]"}
1173     }
1174     }
1175    
1176     #
1177     # proc RESUME <simname>
1178     #------------------------------------------------------------------------
1179     # Reinvoke compiler on simname.
1180     #------------------------------------------------------------------------
1181     proc RESUME {args} {
1182     Script_CheckInterrupt
1183     set argc [llength $args]
1184     switch $argc {
1185     {0} {
1186     Browser_do_ResumeCompile
1187     }
1188     {1} { set sim [lindex [split [lindex $args 0] .] 0]
1189     puts stdout "RESUMEing compilation of $sim."
1190     HUB_Message_to_HUB INSTANCEMOVED $sim
1191     set i [sim_reinstantiate $sim]
1192     if {$i!="1"} {
1193     puts stderr \
1194     "Unable to find $sim."
1195     } else {
1196     HUB_Message_to_HUB INSTANCERESUMED $sim
1197     }
1198     }
1199     default {error "RESUME expected <simname>."}
1200     }
1201     }
1202    
1203     #
1204     # proc SAVE <sim> [TO] <filename>
1205     #------------------------------------------------------------------------
1206     # filename will be assumed to be in Working directory (on utils page)
1207     # unless it starts with a / or a ~
1208     #------------------------------------------------------------------------
1209     proc SAVE {sim args} {
1210     Script_CheckInterrupt
1211     error "Saving simulations not implemented yet.\n"
1212     }
1213    
1214     #
1215     # proc PLOT <qlfdid> [filename]
1216     #------------------------------------------------------------------------
1217     # Writes plot data from qlfdid, which must be a plottable instance,
1218     # to filename.
1219     #------------------------------------------------------------------------
1220     proc PLOT {qlfdid args} {
1221     Script_CheckInterrupt
1222     global ascScripVect ascUtilVect
1223     set filename ""
1224     set nok [catch {qlfdid $qlfdid} err_msg]
1225     if {$nok} {
1226     error "PLOT: Error in finding instance $qlfdid"
1227     }
1228     catch {set args [glob $args]}
1229     if {$args=="."} {set args ""}
1230     if {[llength $args]=="1"} {
1231     # if {[file exists $args]} {error "File $args already exists"}
1232     set filename $args
1233     } else {
1234     set username [ascwhoami]
1235     set file_prefix $ascUtilVect(asctmp)/asc$username
1236     set filename [FileUniqueName "$file_prefix.$ascUtilVect(plot_type)"]
1237     }
1238     if {[b_isplottable search]} {
1239     puts stdout "PLOTting to file: $filename"
1240     b_prepplotfile search $filename $ascUtilVect(plot_type)
1241     set ascScripVect(lastplot) $filename
1242     HUB_Message_to_HUB PLOTMADE $qlfdid $filename
1243     } else { error "$qlfdid is not a plottable kind."}
1244     }
1245    
1246     #
1247     # proc SHOW <filename,LAST>
1248     #------------------------------------------------------------------------
1249     # Invokes the plotter program on the filename given or on the file LAST
1250     # generated by PLOT.
1251     #------------------------------------------------------------------------
1252     proc SHOW {filename} {
1253     Script_CheckInterrupt
1254     global ascScripVect ascUtilVect
1255     if {$filename=="LAST"} {
1256     if {[catch {set ascScripVect(lastplot)} ] || \
1257     $ascScripVect(lastplot)==""} {
1258     error "SHOW LAST called without a previous plot existing."
1259     }
1260     set filename $ascScripVect(lastplot)
1261     }
1262     if {$ascUtilVect(plot_command) != ""} {
1263     Brow_InvokePlotProgram $filename $ascUtilVect(plot_command)
1264     } else {error "Plot command not set in utilities window!"}
1265     }
1266    
1267     #
1268     # proc OBJECTIVE
1269     #------------------------------------------------------------------------
1270     # semantics of OBJECTIVE that will be supported are unclear as no
1271     # OBJECTIVE other than the declarative one is yet supported
1272     #------------------------------------------------------------------------
1273     proc OBJECTIVE {qlfdid} {
1274     Script_CheckInterrupt
1275     error "Select objective not implemented yet.\n"
1276     }
1277    
1278     #
1279     # proc DISPLAY <kind> [OF] <qlfdid>
1280     #------------------------------------------------------------------------
1281     # How qlfdid is displayed varies with kind.
1282     # kinds are: VALUE ATTRIBUTES CODE ANCESTRY
1283     #------------------------------------------------------------------------
1284     proc DISPLAY {kind args} {
1285     Script_CheckInterrupt
1286    
1287     set argc [llength $args]
1288     switch $argc {
1289     {1} {set qlfdid $args}
1290     {2} { set OF [lindex $args 0]
1291     set qlfdid [lindex $args 1]
1292     if {$OF != "OF"} {
1293     puts stderr \
1294     "Non-fatal script error: $OF found. OF expected."
1295     }
1296     }
1297     default {error "DISPLAY called with unexpected number of args"}
1298     }
1299     switch $kind {
1300     {VALUE} -
1301     {ATTRIBUTES} -
1302     {CODE} -
1303     {ANCESTRY} {
1304     puts stderr "Script DISPLAY not implemented.\n"
1305     }
1306     default {error "DISPLAY called with unknown kind $kind."}
1307     }
1308     }
1309    
1310     #
1311     # proc PROBE <arg1 args>
1312     #------------------------------------------------------------------------
1313     # PROBE ONE qlfdid exports the item qlfdid to the Probe.
1314     # PROBE ALL qlfdid exports items found in qlfdid matching
1315     # all variables and relations by default.
1316     # PROBE qlfdid is as PROBE ALL qlfdid.
1317     # PROBE number qlfdid filter-list
1318     # imports to the probe indicated by number
1319     # from the instance qlfdid. if no filterlist is given,
1320     # only the name itself goes to the probe.
1321     # Items always go to currently selected probe context.
1322     #------------------------------------------------------------------------
1323     proc PROBE {arg1 {buf ""} args} {
1324     global ascScripVect
1325     global ascProbVect ascBrowVect
1326     Script_CheckInterrupt
1327     if {$buf ==""} {
1328     Probe_Import_Filtered $ascScripVect(windowname) $arg1 1
1329     } else {
1330     # grandfather the old scripts
1331     if {$arg1=="ONE"} {
1332     Probe_Import current $buf
1333     return
1334     }
1335     if {$arg1=="ALL"} {
1336     # Probe_Import_Filtered $ascScripVect(windowname) $buf 1
1337     Probe_Import current $buf 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
1338     return
1339     }
1340     # all new probe uses should go to this.
1341     Probe_Import $arg1 $buf $args
1342     }
1343     }
1344    
1345     #
1346     # proc EXIT [NOCONFIRM]
1347     #------------------------------------------------------------------------
1348     # EXIT
1349     # EXIT NOCONFIRM
1350     # Quits ASCEND. A confirmation is requested unless NOCONFIRM is given
1351     # If any argument other than NOCONFIRM is given, an error occurs.
1352     #------------------------------------------------------------------------
1353     proc EXIT {args} {
1354     Script_CheckInterrupt
1355     if {$args=="NOCONFIRM"} {Tool_exit_internal; return}
1356     if {$args==""} {Tool_exit; return}
1357     error "Illegal argument to EXIT"
1358     }
1359    
1360     #------------------------------------------------------------------------
1361     # end of script keyword functions
1362     #------------------------------------------------------------------------
1363    
1364     #
1365     # proc DISPVAL {qlfname}
1366     #------------------------------------------------------------------------
1367     # print the instance part of qlfname
1368     #------------------------------------------------------------------------
1369     proc DISPVAL {qlfname} {
1370     Script_CheckInterrupt
1371     if {$qlfname == ""} {
1372     Script_Raise_Error "Invalid Name"
1373     return 0;
1374     }
1375     set res [catch {qlfdid $qlfname} err]
1376     if {$res} {
1377     Script_Raise_Error $err
1378     return 1;
1379     } {
1380     puts "[__brow_iname search]"
1381     }
1382     }
1383     #
1384     # proc Script_Raise_Alert
1385     #------------------------------------------------------------------------
1386     # script alertbox call
1387     #------------------------------------------------------------------------
1388     proc Script_Raise_Alert {errmsg {label "Error"} {geom ""}} {
1389     global ascScripVect
1390     set errorbtn [asctk_dialog .scripterror $ascScripVect(font) \
1391     $label $errmsg "" 0 OK Cancel];
1392     return $errorbtn
1393     }
1394    
1395     #
1396     # proc Script_record_label {args}
1397     #------------------------------------------------------------------------
1398     # script recording variable trace function to configure the recording label
1399     #------------------------------------------------------------------------
1400     proc Script_record_label {args} {
1401     global ascScripVect
1402     if {$ascScripVect(Record)} {
1403     $ascScripVect(RecordBtn) configure -text "Recording"
1404     } else {
1405     $ascScripVect(RecordBtn) configure -text " "
1406     }
1407     }
1408    
1409     #
1410     # proc Script_File_Loaded {filename}
1411     #------------------------------------------------------------------------
1412     # checks to see if a buffer with the name given has been opened
1413     # and not yet closed.
1414     # returns -1 if not currently open or else the buffer number
1415     # (0..$ascScripVect(maxbufnum)) of the corresponding buffer.
1416     #------------------------------------------------------------------------
1417     proc Script_File_Loaded {filename} {
1418     global ascScripVect
1419     for {set c 0} {$c <= $ascScripVect(maxbufnum)} {incr c} {
1420     if {$ascScripVect(bufopen.$c) && \
1421     "$ascScripVect(buffile.$c)" == "$filename"} {
1422     return $c
1423     }
1424     }
1425     return -1
1426     }
1427    
1428     #
1429     # proc Script_Read_File {filename}
1430     #------------------------------------------------------------------------
1431     # read a file without parsing first.
1432     # appends it to the current text box
1433     #------------------------------------------------------------------------
1434     proc Script_Read_File {filename} {
1435     global ascScripVect
1436     FileInText $ascScripVect(scripBox) $filename
1437     }
1438    
1439     # proc Script_Selection{}
1440     #------------------------------------------------------------------------
1441     # Returns the selection in the currently visible Script Text window.
1442     # If no text is selected, returns an empty string.
1443     #------------------------------------------------------------------------
1444     proc Script_Selection {} {
1445     global ascScripVect
1446     if {[catch "$ascScripVect(scripBox) get sel.first sel.last" sel] == 0} {
1447     return $sel;
1448     }
1449     return "";
1450     }
1451    
1452    
1453    
1454     #
1455     # proc Script_File_Get {filename}
1456     #------------------------------------------------------------------------
1457     # Read in a script file, deal with the buffers and all that.
1458     #------------------------------------------------------------------------
1459     proc Script_File_Get {filename} {
1460     global ascScripVect
1461     set filename [file nativename $filename]
1462     if {[file isfile $filename]} {
1463     set ascScripVect(filename) $filename;
1464     } else {
1465     Script_Raise_Alert "File Not Found"
1466     return 1;
1467     }
1468     # update menus and switch text box widgets
1469     set num $ascScripVect(maxbufnum)
1470     incr num
1471     set ascScripVect(bufopen.$num) 0
1472     ScriptSwitchToNewBuf $num $filename
1473     # load the text
1474     Script_Read_File $filename
1475     }
1476    
1477     #
1478     #------------------------------------------------------------------------
1479     # proc check_time. null proc
1480     #------------------------------------------------------------------------
1481     proc check_time {} {
1482     }
1483    
1484     #
1485     # proc Script_do_Font {}
1486     #---------------------------------------------------------------------
1487     # font select button for script window
1488     #---------------------------------------------------------------------
1489     proc Script_do_Font {args} {
1490     global ascScripVect
1491     set font ""
1492     if {$args != ""} {
1493     set font $args
1494     } else {
1495     set font [ascFontGet]
1496     }
1497     if {"$font" == ""} {
1498     return;
1499     }
1500     $ascScripVect(scripBox) configure -font $font
1501     set ascScripVect(font) [lindex [$ascScripVect(scripBox) configure -font] 4]
1502     }
1503    
1504    
1505     proc Script_do_NewFile {} {
1506     global ascScripVect
1507     set num $ascScripVect(maxbufnum)
1508     incr num
1509     ScriptSwitchToNewBuf $num {}
1510     }
1511    
1512     proc ascwhoami {} {
1513     global env tcl_platform
1514     if {[info exists env(USERNAME)]} {
1515     return $env(USERNAME)
1516     }
1517     if {[info exists env(USER)]} {
1518     return $env(USER)
1519     }
1520     if {[info exists env(User)]} {
1521     return $env(User)
1522     }
1523     if {[info exists env(user)]} {
1524     return $env(user)
1525     }
1526     return "anonymous[pid]"
1527     }
1528     #
1529     # proc Script_do_Import_File {}
1530     #------------------------------------------------------------------------
1531     # displays a filefind box and adds the file specified to the end of
1532     # the current script. would be nice if inserted at current point.
1533     #------------------------------------------------------------------------
1534     proc Script_do_Import_File {} {
1535     global ascScripVect asc_tkfbox ascToolVect
1536     set defaultname "$ascToolVect(dirinput)"
1537     set filename [tk_getOpenFile \
1538     -defaultextension "" \
1539     -filetypes $ascScripVect(filetypes) \
1540     -initialdir $defaultname \
1541     -parent .script \
1542     -title {Import script lines}]
1543    
1544     set filename [file nativename $filename]
1545     if {$filename == "" || [file isdirectory $filename]} {
1546     if {!$asc_tkfbox(cancelled)} {
1547     set msg "\""
1548     append msg $filename "\" cannot be read."
1549     asctk_dialog .fileerr $ascScripVect(font) FYI $msg "" 0 OK
1550     }
1551     return 1;
1552     } else {
1553     if {[file isfile $filename] == 0} {
1554     Script_Raise_Alert "File Not Found"
1555     return 1;
1556     }
1557     set newext "[file extension $filename]"
1558     if {$newext != ""} {
1559     set ascScripVect(lastimportextension) $newext
1560     ascresort_filetypes ascScripVect lastimportextension
1561     }
1562     Script_Read_File $filename
1563     if {$ascScripVect(visibility)} {newraise .script}
1564     update idletasks
1565     }
1566     }
1567    
1568     #
1569     # proc Script_do_ReadFile
1570     #------------------------------------------------------------------------
1571     # get a file from user and read it in
1572     #------------------------------------------------------------------------
1573     proc Script_do_ReadFile {} {
1574     global ascScripVect asc_tkfbox ascGlobalVect ascToolVect
1575     set defaultname "$ascToolVect(dirinput)"
1576     set asc_tkfbox(otherdirs) $ascGlobalVect(librarypathdirs)
1577     set filename [tk_getOpenFile \
1578     -defaultextension "" \
1579     -filetypes $ascScripVect(filetypes) \
1580     -initialdir $defaultname \
1581     -parent .script \
1582     -title {Read Ascend IV interface script}]
1583    
1584     if {$filename == "" || [file isdirectory $filename]} {
1585     if {!$asc_tkfbox(cancelled)} {
1586     set msg "\""
1587     append msg $filename "\" cannot be read."
1588     asctk_dialog .fileerr $ascScripVect(font) FYI $msg "" 0 OK
1589     }
1590     return 1;
1591     } else {
1592     set newext ""
1593     set newext [file extension $filename]
1594     if {$newext != ""} {
1595     set ascScripVect(lastreadextension) $newext
1596     ascresort_filetypes ascScripVect lastreadextension
1597     lappend ascGlobalVect(librarypathdirs) [file dirname $filename]
1598     }
1599     Script_File_Get $filename
1600     if {$ascScripVect(visibility)} {newraise .script}
1601     update idletasks
1602     }
1603     }
1604    
1605     #
1606     # proc Script_File_OpenandWrite {filename}
1607     #------------------------------------------------------------------------
1608     # internal to Script_do_WriteFile
1609     #------------------------------------------------------------------------
1610     proc Script_File_OpenandWrite {filename} {
1611     global ascScripVect
1612     set w $ascScripVect(scripBox);
1613     set nok [catch {set fdesc [open $filename w]}];
1614     if {$nok} {
1615     Script_Raise_Alert $fdesc "File Writing Error"
1616     return 1;
1617     }
1618     set data [Script_Selection]
1619     if {"$data" == ""} {
1620     Script_Raise_Alert "Nothing to Write" "Error"
1621     return 1;
1622     }
1623     puts $fdesc $data;
1624     close $fdesc;
1625     return 0;
1626     }
1627     #
1628     # proc Script_do_WriteFile {}
1629     #------------------------------------------------------------------------
1630     # save selection in script to a file selected via file box
1631     #------------------------------------------------------------------------
1632     proc Script_do_WriteFile {} {
1633     global ascScripVect
1634     set defaultname $ascScripVect(filename)
1635     set filename [tk_getSaveFile \
1636     -defaultextension "" \
1637     -filetypes $ascScripVect(filetypes) \
1638     -initialfile $defaultname \
1639     -parent .script \
1640     -title {Save Ascend IV interface script}]
1641    
1642     if {$filename == ""} {
1643     return 1;
1644     } else {
1645     Script_File_OpenandWrite $filename;
1646     }
1647     }
1648    
1649     #
1650     # proc Script_do_WriteBuf {}
1651     #------------------------------------------------------------------------
1652     # save selection in script to a file selected
1653     #------------------------------------------------------------------------
1654     proc Script_do_WriteBuf {} {
1655     global ascScripVect
1656     set defaultname $ascScripVect(filename)
1657     set w $ascScripVect(scripBox)
1658     $ascScripVect(scripBox) tag add sel 1.0 [$ascScripVect(scripBox) index end]
1659     set data [Script_Selection]
1660     if {![catch {set fdesc [open $defaultname w]}]} {
1661     puts $fdesc $data
1662     close $fdesc
1663     } else {
1664     puts "ERROR: failed to save file $defaultname"
1665     }
1666     $ascScripVect(scripBox) tag remove \
1667     sel 1.0 [$ascScripVect(scripBox) index end]
1668     }
1669    
1670     #
1671     # proc Script_do_WriteBufAs {}
1672     #------------------------------------------------------------------------
1673     # save selection in script to a file selected
1674     #------------------------------------------------------------------------
1675     proc Script_do_WriteBufAs {} {
1676     global ascScripVect
1677     set defaultname $ascScripVect(filename)
1678     set filename [tk_getSaveFile \
1679     -defaultextension "" \
1680     -filetypes $ascScripVect(filetypes) \
1681     -initialfile $defaultname \
1682     -parent .script \
1683     -title {Save interface script AS}]
1684    
1685     if {$filename == ""} {
1686     return 1;
1687     } else {
1688     $ascScripVect(scripBox) tag add \
1689     sel 1.0 [$ascScripVect(scripBox) index end]
1690     Script_File_OpenandWrite $filename;
1691     $ascScripVect(scripBox) tag remove sel \
1692     1.0 [$ascScripVect(scripBox) index end]
1693     }
1694     Script_File_Get $filename
1695     }
1696    
1697     #
1698     # proc Script_do_SelectAll {}
1699     #------------------------------------------------------------------------
1700     # highlights all of the script.
1701     # assumes text, which is quite sensible
1702     #------------------------------------------------------------------------
1703     proc Script_do_SelectAll {} {
1704     global ascScripVect
1705     $ascScripVect(scripBox) tag add sel 1.0 [$ascScripVect(scripBox) index end]
1706     update idletasks
1707     update
1708     }
1709    
1710     #
1711     # proc Script_find_Semi {}
1712     #------------------------------------------------------------------------
1713     # Finds char before next semicolon, starting at the beginning of current
1714     # selection. Ignores the very first character, to avoid being
1715     # stuck if you start at a semicolon.
1716     # Returns end of text if semicolon never found.
1717     # Isn't clever about disjoint selections:
1718     # could be if we stopped at selend instead of textend.
1719     # This sucker is shockingly fast.
1720     #------------------------------------------------------------------------
1721     proc Script_find_Semi {ScriptBox} {
1722     set psel ""
1723     set psel [$ScriptBox tag ranges sel]
1724     if {$psel==""} {error "no selection"}
1725     set p0 [lindex [split $psel] 0]
1726     set pend [$ScriptBox index end]
1727     for {set offset 1} \
1728     {![catch {set pc [$ScriptBox index "$p0 + $offset chars"]}] &&
1729     [$ScriptBox compare $pc < $pend] && \
1730     "[$ScriptBox get $pc]" != "\;"} \
1731     {incr offset} {}
1732     return $pc
1733     }
1734    
1735     #
1736     # proc Script_unsel {}
1737     #------------------------------------------------------------------------
1738     # unselect up through next semicolon, starting at beginning of cur selection
1739     #------------------------------------------------------------------------
1740     proc Script_unsel {ScriptBox} {
1741     set slist [$ScriptBox tag ranges sel]
1742     if {$slist==""} {return}
1743     set oselbeg [lindex $slist 0]
1744     set oselend [$ScriptBox index "[Script_find_Semi $ScriptBox] + 1 chars"]
1745    
1746     # Adjust the position of the insertion cursor, so that it is
1747     # set up at the start of the line just completed.
1748    
1749     $ScriptBox mark set insert "$oselend linestart"
1750    
1751     # remove the selection
1752     #
1753     $ScriptBox tag remove sel $oselbeg $oselend
1754     }
1755    
1756     #
1757     # proc Script_do_RemoveStats -Version 2 - TextBox Version
1758     #------------------------------------------------------------------------
1759     # delete disjoint selection. baa
1760     #------------------------------------------------------------------------
1761     proc Script_do_RemoveStats {} {
1762     global ascScripVect
1763     set w $ascScripVect(scripBox)
1764     set tlist "[$ascScripVect(scripBox) tag ranges sel]"
1765     if {$tlist==""} {return}
1766     set nr [expr [llength $tlist] /2]
1767     for {set r [expr $nr -1]} {$r>=0} {incr r -1} {
1768     set start [lindex $tlist [expr 2*$r]]
1769     set stop [lindex $tlist [expr 2*$r+1]]
1770     $w delete $start $stop
1771     }
1772     }
1773    
1774     proc ScriptFile_do_Copy {} {
1775     global ascScripVect
1776     $ascScripVect(fileentry) configure -state normal
1777     asc_export_selection $ascScripVect(fileentry)
1778     event generate $ascScripVect(fileentry) <<Copy>>
1779     $ascScripVect(fileentry) configure -state disabled
1780     }
1781    
1782     proc Script_do_Copy {} {
1783     global ascScripVect
1784     asc_export_selection $ascScripVect(scripBox)
1785     event generate $ascScripVect(scripBox) <<Copy>>
1786     }
1787    
1788     proc Script_do_Cut {} {
1789     global ascScripVect
1790     event generate $ascScripVect(scripBox) <<Cut>>
1791     }
1792    
1793     proc Script_do_Paste {} {
1794     global ascScripVect
1795     event generate $ascScripVect(scripBox) <<Paste>>
1796     }
1797    
1798     #
1799     # proc Script_do_Record {n1 n2 mode}
1800     #------------------------------------------------------------------------
1801     # not needed.
1802     # toggle recorder system. call will be from trace if at all
1803     #------------------------------------------------------------------------
1804     proc Script_do_Record {n1 n2 mode} {
1805     global ascScripVect
1806     update
1807     Script_ClearEvents
1808     update idletasks
1809     if {$ascScripVect(Record)} {
1810     }
1811     }
1812    
1813     # returns normal if something is selected and disabled if not.
1814     proc ScriptSelectState {} {
1815     global ascScripVect
1816     if {"[$ascScripVect(scripBox) tag ranges sel]" !=""} {
1817     return normal
1818     }
1819     return disabled
1820     }
1821    
1822     # always returns normal. updates the menu entry.
1823     proc ScriptSaveState {} {
1824     global ascScripVect ascPopInfo
1825     set lbl "Save $ascScripVect(filename)"
1826     $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
1827     return normal
1828     }
1829     #
1830     # proc Script_Update_File_Buttons {}
1831     #------------------------------------------------------------------------
1832     # does what it says
1833     #------------------------------------------------------------------------
1834     proc Script_Update_File_Buttons {} {
1835     global ascScripVect
1836     set mb "$ascScripVect(fileBtn)"
1837     $mb entryconfigure 0 -state normal
1838     $mb entryconfigure 1 -state normal
1839     $mb entryconfigure 2 -state normal
1840 ben.allan 659 $mb entryconfigure 3 -state normal
1841     # note 4: separators don't have states
1842     $mb entryconfigure 5 -state normal
1843     # note 6: separators don't have states
1844 johnpye 571 $mb entryconfigure 7 -state normal
1845 ben.allan 659 $mb entryconfigure 8 -state normal
1846     # note 9: separators don't have states
1847 johnpye 571 }
1848    
1849     #
1850     # proc Script_Update_EditButtons {}
1851     #------------------------------------------------------------------------
1852     # does what it says
1853     #------------------------------------------------------------------------
1854     proc Script_Update_Edit_Buttons {} {
1855     global ascScripVect
1856     set mb "$ascScripVect(editBtn)"
1857     switch [ScriptSelectState] {
1858     normal {
1859     $mb entryconfigure 3 -state normal
1860     }
1861     default {
1862     $mb entryconfigure 3 -state disabled
1863     }
1864     }
1865     }
1866    
1867     #
1868     # proc Script_Update_View_Buttons {}
1869     #------------------------------------------------------------------------
1870     # enable/disable options in the view menu
1871     #------------------------------------------------------------------------
1872     proc Script_Update_View_Buttons {} {
1873     global ascScripVect ascGlobalVect
1874    
1875     set mb .script.menubar.view
1876    
1877     if {$ascGlobalVect(saveoptions) == 0} {
1878     $mb entryconfigure 1 -state disabled
1879     $mb entryconfigure 2 -state disabled
1880     } else {
1881     $mb entryconfigure 1 -state normal
1882     $mb entryconfigure 2 -state normal
1883     }
1884    
1885     }
1886    
1887     #
1888     # proc Script_Update_ExecButtons {}
1889     #------------------------------------------------------------------------
1890     # does what it says
1891     #------------------------------------------------------------------------
1892     proc Script_Update_Exec_Buttons {} {
1893     global ascScripVect
1894     set mb $ascScripVect(execBtn)
1895     switch [ScriptSelectState] {
1896     normal {
1897     $mb entryconfigure 0 -state normal
1898     $mb entryconfigure 1 -state normal
1899     }
1900     default {
1901     $mb entryconfigure 0 -state disabled
1902     $mb entryconfigure 1 -state disabled
1903     }
1904     }
1905     }
1906    
1907     proc Script_SetCursor_Normal {ScriptBox} {
1908     $ScriptBox config -cursor xterm
1909     }
1910    
1911     proc Script_SetCursor_Executing {ScriptBox} {
1912     $ScriptBox config -cursor watch
1913     }
1914    
1915     proc Script_ExitGeom {} {
1916     return [setpos .script 40 40]
1917     }
1918    
1919     #
1920     # Script_do_Exit
1921     #------------------------------------------------------------------------
1922     # exit ascend button
1923     #------------------------------------------------------------------------
1924     proc Script_do_Exit {} {
1925     global ascScripVect
1926     set ascScripVect(menubreak) 1
1927     set position [Script_ExitGeom]
1928     set res [VShowWindow.ascConfirm "190x50$position" "Exit"]
1929     if {$res == 1} {
1930     Script_ClearInterrupt
1931     EXIT NOCONFIRM
1932     }
1933     }
1934    
1935     #
1936     #proc do_ScriptExecuteBox {}
1937     #------------------------------------------------------------------------
1938     # Creates a widget to ask whether the execution of the statements
1939     # in the script is going to be continuous or step by step
1940     #------------------------------------------------------------------------
1941     #
1942     proc do_ScriptExecuteBox {} {
1943     entertrace
1944     global ascScripVect ascScriptExecute
1945    
1946     set tl .scriptsteptrough
1947     # build widget
1948     toplevel $tl
1949    
1950     # Window manager configurations
1951     #global tk_version
1952    
1953     wm positionfrom $tl user
1954     wm sizefrom $tl user
1955     wm minsize $tl 250 60
1956     wm geometry $tl 250x60[setpos .display 90 190]
1957     wm title $tl ""
1958    
1959    
1960     # build widget $tl.buttons_frm
1961     frame $tl.buttons_frm \
1962     -borderwidth 0
1963    
1964     # build widget $tl.buttons_frm.next_button
1965     button $tl.buttons_frm.next_button \
1966     -font $ascScripVect(font) \
1967     -text Next \
1968     -width 7 \
1969     -command "
1970     global ascScriptExecute
1971     set ascScriptExecute(button) 1
1972     destroy $tl"
1973    
1974     # build widget $tl.buttons_frm.btn2
1975     button $tl.buttons_frm.btn2 \
1976     -borderwidth 2 \
1977     -font $ascScripVect(font) \
1978     -text Go \
1979     -width 4 \
1980     -command "
1981     global ascScriptExecute
1982     set ascScriptExecute(button) 2
1983     destroy $tl"
1984    
1985     # build widget $tl.buttons_frm.btn3
1986     button $tl.buttons_frm.btn3 \
1987     -borderwidth 3 \
1988     -font $ascScripVect(font) \
1989     -text Stop \
1990     -width 7 \
1991     -command "
1992     global ascScriptExecute
1993     set ascScriptExecute(button) 3
1994     destroy $tl"
1995    
1996     # pack widget $tl.buttons_frm
1997     pack append $tl.buttons_frm \
1998     $tl.buttons_frm.next_button {left frame center expand fill} \
1999     $tl.buttons_frm.btn2 {left frame center expand fill} \
2000     $tl.buttons_frm.btn3 {left frame center expand fill}
2001    
2002     # build widget $tl.lbl_frm
2003     frame $tl.lbl_frm
2004    
2005     # build widget $tl.lbl_frm.main_label
2006     label $tl.lbl_frm.main_label \
2007     -text "Script Executing Statements"
2008    
2009     # pack widget $tl.lbl_frm
2010     pack append $tl.lbl_frm \
2011     $tl.lbl_frm.main_label {top frame center pady 5 fillx}
2012    
2013     # pack widget $tl
2014     pack append $tl \
2015     $tl.lbl_frm {top frame center pady 5 fillx} \
2016     $tl.buttons_frm {top frame center fill}
2017    
2018     bind $tl <Visibility> "ascKeepOnTop $tl"
2019     proc DestroyWindow$tl {} "
2020     destroy $tl
2021     update"
2022    
2023     # wait for the box to be destroyed
2024     tkwait window $tl
2025     return $ascScriptExecute(button)
2026     leavetrace
2027     }
2028    
2029    
2030    
2031     #
2032     # Script_do_ExecuteStats {contmode}
2033     #------------------------------------------------------------------------
2034     # if contmode not given, it is assumed 1.
2035     # menubutton bindings are not supposed to require arguments.
2036     # Steps through tcl code in delimited chunks
2037     # Loops with intermediate ;
2038     #
2039     # If contmode = 0:
2040     # A)It will put each of the statements and previous
2041     # comments in the Display window
2042     # B)It stops after the execution of each statement to
2043     # ask if you
2044     # a)want to execute the next statement
2045     # b)want to stop
2046     # c)want to execute the rest of the statements without interruption.
2047     #
2048     # it will bomb Eval
2049     # Modified to use script_eval a registered call rather than tcls' eval
2050     # so as to evaluate things in the global sphere.
2051     #------------------------------------------------------------------------
2052     proc Script_do_ExecuteStats {{contmode 1}} {
2053     global ascScripVect ascSolvStatVect ascDispVect
2054     # need to store scriptbox incase a command in the script
2055     # changes to a new script buffer
2056     set locScriptBox $ascScripVect(scripBox)
2057     set com_list [Script_Selection]
2058     set statlist [split $com_list ";"]
2059     set ascScripVect(executing) 1
2060     Script_ClearInterrupt
2061     set continuous_mode $contmode
2062     set len [llength $statlist]
2063     set counter 1
2064     DispClear;
2065     DispSetEntry "Script statement just executed"
2066     Script_SetCursor_Executing $locScriptBox
2067     foreach stat $statlist {
2068     set counter [expr $counter + 1]
2069     if {$ascScripVect(menubreak) != 0} {
2070     puts stderr "Script interrupted"
2071     set ascSolvStatVect(menubreak) 0
2072     break
2073     }
2074     if {$continuous_mode != 1} {
2075     DispInsert3 $stat
2076     if {$ascDispVect(visibility)} {newraise .display}
2077     }
2078     if {[catch {script_eval $stat} jnk]} {#script_eval is a registered call
2079     set jnk [string trim $jnk]
2080     puts stderr "$jnk\n"
2081     puts "in script code: >>$stat<<"
2082     if {$continuous_mode != 1} {
2083     DispInsert3 "\n"
2084     DispInsert3 "$jnk\n"
2085     DispInsert3 "in script code: >>$stat<<"
2086     if {$ascDispVect(visibility)} {newraise .display}
2087     }
2088     # this should be done by individual commandslike
2089     # SOLVE rather than here
2090     if {[string range $jnk 0 4]=="Float"} {
2091     set ascScripVect(executing) 0
2092     error $jnk}
2093     Script_SetCursor_Normal $locScriptBox
2094     break
2095     }
2096     Script_unsel $locScriptBox
2097     update idletasks
2098     update
2099     if {$continuous_mode != 1} {
2100     if {$counter < $len} {
2101     set execmode [do_ScriptExecuteBox]
2102     DispClear;
2103     if {$execmode == 2} {
2104     set continuous_mode 1
2105     wm iconify .display
2106     }
2107     if {$execmode == 3} {
2108     wm iconify .display
2109     set ascScripVect(executing) 0
2110     set ascSolvStatVect(menubreak) 0
2111     Script_SetCursor_Normal $locScriptBox
2112     break
2113     }
2114     }
2115     }
2116     }
2117     set ascScripVect(executing) 0
2118     Script_SetCursor_Normal $locScriptBox
2119     return
2120     }
2121    
2122     #
2123     # proc Script_do_Help {}
2124     # proc Script_do_BindHelp {}
2125     #------------------------------------------------------------------------
2126     # Help button calls
2127     #------------------------------------------------------------------------
2128     proc Script_do_Help {} {
2129     Help_button script
2130     }
2131     proc Script_do_BindHelp {} {
2132     Help_button {script.help onascend/tclscripts}
2133     }
2134     proc Script_getting_started {} {
2135     Help_button {howto-ascend} on modeling
2136     }
2137    
2138     #------------------------------------------------------------------------
2139     # RECORDing system calls.
2140     # all of these look at the global variable ascScripVect(executing) to
2141     # see if they should record or not. Any user events that happen while a
2142     # script is running will be ignored, in all likelihood.
2143     # The script event counter ascScripVect(count) will be incremented. This
2144     # counter is used to insure that statements get inserted in the proper
2145     # order. (maybe)
2146     #------------------------------------------------------------------------
2147     # events recorded:
2148     # ASSIGN
2149     # BROWSE
2150     # READ FILE
2151     # READ VALUES
2152     # COMPILE
2153     # MERGE
2154     # REFINE
2155     # DELETE
2156     # PLOT
2157     # DISPLAY
2158     # PROBE
2159     # PRINT
2160     # RUN
2161     # SOLVE
2162     # WRITE
2163     # events ignored, for whatever reason
2164     # RESTORE
2165     # SAVE
2166     # INTEGRATE
2167     # OBJECTIVE
2168    
2169     #
2170     # proc Script_AppendEvent {line counter}
2171     #------------------------------------------------------------------------
2172     # insert line into the script window at end
2173     #------------------------------------------------------------------------
2174     proc Script_AppendEvent {line counter} {
2175     global ascScripVect
2176     $ascScripVect(scripBox) insert end $line
2177     }
2178     #
2179     # proc Script_Record_Solve {inst snum args}
2180     #------------------------------------------------------------------------
2181     # record solving with solver snum if not t already.
2182     #------------------------------------------------------------------------
2183     proc Script_Record_Solve {args} {
2184     global ascScripVect
2185     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2186     set inst [lindex $args 0]
2187     set sname [lindex $args 1]
2188    
2189     set pname [slv_get_pathname]
2190     set objnum [slv_get_obj_num 2]
2191     if {$objnum >= 0} {
2192     set objname "$pname.[stripbraces [dbg_write_obj 2 $objnum 0]]"
2193     set line "\nOPTIMIZE \{$objname\} IN \{$inst\} WITH $sname;"
2194     } else {
2195     set line "\nSOLVE \{$inst\} WITH $sname;"
2196     }
2197     set c [incr ascScripVect(count)]
2198     Script_AppendEvent $line $c
2199     }
2200     }
2201     #
2202     # proc Script_Record_Flush {args}
2203     #------------------------------------------------------------------------
2204     # record flushing the solver. this needs to be smarter if we have
2205     # multiple problems in the solver simultaneously.
2206     #------------------------------------------------------------------------
2207     proc Script_Record_Flush {args} {
2208     global ascScripVect
2209     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2210     set inst [lindex $args 0]
2211     set sname [lindex $args 1]
2212     set line "\nDELETE SYSTEM;"
2213     set c [incr ascScripVect(count)]
2214     Script_AppendEvent $line $c
2215     }
2216     }
2217    
2218     #
2219     # proc Script_Record_Read {file args}
2220     #------------------------------------------------------------------------
2221     # record file read in.
2222     # change backslashes \ to forward slashes / and put the name in
2223     # double quotes to protect spaces in the file name.
2224     #------------------------------------------------------------------------
2225     proc Script_Record_Read {file args} {
2226     global ascScripVect
2227     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2228     regsub -all {\\} $file / properFile
2229     set line "\nREAD FILE \"$properFile\";"
2230     set c [incr ascScripVect(count)]
2231     Script_AppendEvent $line $c
2232     }
2233     }
2234    
2235     #
2236     # proc Script_Record_ValueRead {file args}
2237     #------------------------------------------------------------------------
2238     # record values file read in.
2239     #------------------------------------------------------------------------
2240     proc Script_Record_ValueRead {file args} {
2241     global ascScripVect
2242     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2243     regsub -all {\\} $file / properFile
2244     set line "\nREAD VALUES \"$properFile\";"
2245     set c [incr ascScripVect(count)]
2246     Script_AppendEvent $line $c
2247     }
2248     }
2249    
2250     #
2251     # proc Script_Record_ValueWrite {args}
2252     #------------------------------------------------------------------------
2253     # record values file written.
2254     #------------------------------------------------------------------------
2255     proc Script_Record_ValueWrite {args} {
2256     global ascScripVect
2257     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2258     set inst [lindex $args 0]
2259     set filename [lindex $args 1]
2260     set line "\nWRITE VALUES \{$inst\} $filename;"
2261     set c [incr ascScripVect(count)]
2262     Script_AppendEvent $line $c
2263     }
2264     }
2265    
2266    
2267     #
2268     # proc Script_Record_Compile {args}
2269     #------------------------------------------------------------------------
2270     # record instantiation
2271     #------------------------------------------------------------------------
2272     proc Script_Record_Compile {args} {
2273     global ascScripVect
2274     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2275     set sim [lindex $args 0]
2276     set type [lindex $args 1]
2277     set line "\nCOMPILE $sim OF $type;"
2278     set c [incr ascScripVect(count)]
2279     Script_AppendEvent $line $c
2280     }
2281     }
2282    
2283     #
2284     # proc Script_Record_Refine {args}
2285     #------------------------------------------------------------------------
2286     # record interactive refinement
2287     #------------------------------------------------------------------------
2288     proc Script_Record_Refine {args} {
2289     global ascScripVect
2290     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2291     set inst [lindex $args 0]
2292     set type [lindex $args 1]
2293     set line "\nREFINE \{$inst\} TO $type;"
2294     set c [incr ascScripVect(count)]
2295     Script_AppendEvent $line $c
2296     }
2297     }
2298    
2299     #
2300     # proc Script_Record_Resume {args}
2301     #------------------------------------------------------------------------
2302     # record interactive resume compile
2303     #------------------------------------------------------------------------
2304     proc Script_Record_Resume {args} {
2305     global ascScripVect
2306     set inst "a"
2307     set line "a"
2308     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2309     if {[llength $args] >0} {
2310     set inst [lindex $args 0]
2311     set line "\nRESUME \{$inst\};"
2312     } else { set line "RESUME;"}
2313     set c [incr ascScripVect(count)]
2314     Script_AppendEvent $line $c
2315     }
2316     }
2317     #
2318     # proc Script_Record_Merge {args}
2319     #------------------------------------------------------------------------
2320     # record interactive merge
2321     #------------------------------------------------------------------------
2322     proc Script_Record_Merge {args} {
2323     global ascScripVect
2324     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2325     set inst1 [lindex $args 0]
2326     set inst2 [lindex $args 1]
2327     set line "\nMERGE \{$inst1\} WITH \{$inst2\};"
2328     set c [incr ascScripVect(count)]
2329     Script_AppendEvent $line $c
2330     }
2331     }
2332    
2333     #
2334     # proc Script_Record_DeleteTypes {args}
2335     #------------------------------------------------------------------------
2336     # record type deletion
2337     #------------------------------------------------------------------------
2338     proc Script_Record_DeleteTypes {args} {
2339     global ascScripVect
2340     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2341     set line "\nDELETE TYPES;"
2342     set c [incr ascScripVect(count)]
2343     Script_AppendEvent $line $c
2344     }
2345     }
2346    
2347     #
2348     # proc Script_Record_Delete {sim args}
2349     #------------------------------------------------------------------------
2350     # record sim deletion
2351     #------------------------------------------------------------------------
2352     proc Script_Record_Delete {sim args} {
2353     global ascScripVect
2354     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2355     set line "\nDELETE $sim;"
2356     set c [incr ascScripVect(count)]
2357     Script_AppendEvent $line $c
2358     }
2359     }
2360    
2361     #
2362     # proc Script_Record_Browse {inst args}
2363     #------------------------------------------------------------------------
2364     # record export for browsing of an instance
2365     #------------------------------------------------------------------------
2366     proc Script_Record_Browse {inst args} {
2367     global ascScripVect
2368     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2369     set line "\nBROWSE \{$inst\};"
2370     set c [incr ascScripVect(count)]
2371     Script_AppendEvent $line $c
2372     }
2373     }
2374    
2375     #
2376     # proc Script_Record_Assign {args}
2377     #------------------------------------------------------------------------
2378     # record assignment
2379     #------------------------------------------------------------------------
2380     proc Script_Record_Assign {args} {
2381     global ascScripVect
2382     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2383     set inst [lindex $args 0]
2384     set value [lindex $args 1]
2385     if {[catch {set units [lindex $args 2]} ]} {set units ""}
2386     set line "\nASSIGN \{$inst\} $value \{$units\};"
2387     set c [incr ascScripVect(count)]
2388     Script_AppendEvent $line $c
2389     }
2390     }
2391    
2392     #
2393     # proc Script_Record_Plot {args}
2394     #------------------------------------------------------------------------
2395     # record plot
2396     #------------------------------------------------------------------------
2397     proc Script_Record_Plot {args} {
2398     global ascScripVect
2399     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2400     set inst [lindex $args 0]
2401     set filename [lindex $args 1]
2402     set leafname [file tail $filename]
2403     set scrpref "asc[ascwhoami]"
2404     if {[string range $leafname 0 [string length $scrpref]]=="$scrpref."} {
2405     set filename ""
2406     }
2407     set line "\nPLOT \{$inst\} $filename;"
2408     set c [incr ascScripVect(count)]
2409     Script_AppendEvent $line $c
2410     set line "\nSHOW LAST;"
2411     set c [incr ascScripVect(count)]
2412     Script_AppendEvent $line $c
2413     }
2414     }
2415    
2416     #
2417     # proc Script_Record_Run {instproc args}
2418     #------------------------------------------------------------------------
2419     # record initialization routine
2420     #------------------------------------------------------------------------
2421     proc Script_Record_Run {instproc args} {
2422     global ascScripVect
2423     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2424     set line "\nRUN \{$instproc\};"
2425     set c [incr ascScripVect(count)]
2426     Script_AppendEvent $line $c
2427     }
2428     }
2429    
2430     #
2431     # proc Script_Record_Probe {args}
2432     #------------------------------------------------------------------------
2433     # record export to probe
2434     #------------------------------------------------------------------------
2435     proc Script_Record_Probe {args} {
2436     global ascScripVect
2437     set a1 [lindex $args 0]
2438     set a2 [lindex $args 1]
2439     set a3 [lindex $args 2]
2440     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2441     set line "\nPROBE "
2442     append line $a1
2443     append line " " \{ $a2 \}
2444     append line " " "\{[stripbraces $a3]\}\;"
2445     set c [incr ascScripVect(count)]
2446     Script_AppendEvent $line $c
2447     }
2448     }
2449    
2450     #
2451     # proc Script_Record_Display {item args}
2452     #------------------------------------------------------------------------
2453     # record export to display
2454     #------------------------------------------------------------------------
2455     proc Script_Record_Display {item args} {
2456     global ascScripVect
2457     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2458     puts $item; puts $args
2459     }
2460     }
2461    
2462     #
2463     # proc Script_Record_Print {item args}
2464     #------------------------------------------------------------------------
2465     # record printing probe or display
2466     #------------------------------------------------------------------------
2467     proc Script_Record_Print {item args} {
2468     global ascScripVect
2469     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2470     set line "\nPRINT $item"
2471     set c [incr ascScripVect(count)]
2472     Script_AppendEvent $line $c
2473     }
2474     }
2475     #
2476     # proc Script_Record_ClearVars {inst args}
2477     #------------------------------------------------------------------------
2478     # record solving with solver snum if not t already.
2479     #------------------------------------------------------------------------
2480     proc Script_Record_ClearVars {args} {
2481     global ascScripVect
2482     if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2483     set inst [lindex $args 0]
2484     set line "\nCLEAR_VARS \{$inst\};"
2485     set c [incr ascScripVect(count)]
2486     Script_AppendEvent $line $c
2487     }
2488     }
2489    
2490     #####################################################################
2491     # XF theft
2492     #------------------------------------------------------------------------
2493     # Procedure: FileInText
2494     # Description: fill a text with the contents of the file
2495     # Arguments: textWidget - the widget
2496     # {fileName} - filename to read
2497     # Returns: none
2498     # Sideeffects: the text widget is filled
2499     #------------------------------------------------------------------------
2500     proc FileInText {textWidget {fileName ""}} {# xf ignore me 5
2501    
2502     # check file existance
2503     if {"$fileName" == ""} {
2504     puts stderr "no filename specified"
2505     return
2506     }
2507     set fileName [file nativename $fileName]
2508     if {[catch {set fileInFile [open $fileName r]}]} {
2509     asctk_dialog .fileerr $ascScripVect(font) \
2510     Load-Error $fileInFile "" 0 OK
2511     return
2512     }
2513    
2514     set textValue [read $fileInFile]
2515     $textWidget insert end "$textValue"
2516     close $fileInFile
2517     }
2518    
2519     # eof
2520    
2521     #####################################################################
2522     # some text widget utils
2523     #
2524     # proc taglines {w}
2525     #------------------------------------------------------------------------
2526     # appears to tag first 80 char of lines or some such....
2527     #------------------------------------------------------------------------
2528     proc taglines {w} {
2529     set end [$w index end]
2530     set endl [split $end "."]
2531     set endl [lindex $endl 0]
2532     for {set c 1} {$c <= $endl} {incr c} {
2533     set start "$c\.0"
2534     set stop "$c\.80"
2535     $w tag add "line$c" "$start" "$stop"
2536     }
2537     }
2538    
2539     #
2540     # proc tagdelete {w}
2541     #------------------------------------------------------------------------
2542     # scrap all tags but sel
2543     #------------------------------------------------------------------------
2544     proc tagdelete {w} {
2545     set nm [$w tag names]
2546     foreach tag $nm {
2547     if {$tag != "sel"} {
2548     $w tag del $tag
2549     }
2550     }
2551     }

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22