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

Contents of /trunk/ascend4/TK/ScriptProc.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (17 years, 1 month ago) by aw0a
File MIME type: text/x-tcl
File size: 80314 byte(s)
Setting up web subdirectory in repository
1 # 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
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 # note 3: separators don't have states
1841 $mb entryconfigure 4 -state normal
1842 # note 5: separators don't have states
1843 $mb entryconfigure 6 -state normal
1844 $mb entryconfigure 7 -state normal
1845 # note 8: separators don't have states
1846 }
1847
1848 #
1849 # proc Script_Update_EditButtons {}
1850 #------------------------------------------------------------------------
1851 # does what it says
1852 #------------------------------------------------------------------------
1853 proc Script_Update_Edit_Buttons {} {
1854 global ascScripVect
1855 set mb "$ascScripVect(editBtn)"
1856 switch [ScriptSelectState] {
1857 normal {
1858 $mb entryconfigure 3 -state normal
1859 }
1860 default {
1861 $mb entryconfigure 3 -state disabled
1862 }
1863 }
1864 }
1865
1866 #
1867 # proc Script_Update_View_Buttons {}
1868 #------------------------------------------------------------------------
1869 # enable/disable options in the view menu
1870 #------------------------------------------------------------------------
1871 proc Script_Update_View_Buttons {} {
1872 global ascScripVect ascGlobalVect
1873
1874 set mb .script.menubar.view
1875
1876 if {$ascGlobalVect(saveoptions) == 0} {
1877 $mb entryconfigure 1 -state disabled
1878 $mb entryconfigure 2 -state disabled
1879 } else {
1880 $mb entryconfigure 1 -state normal
1881 $mb entryconfigure 2 -state normal
1882 }
1883
1884 }
1885
1886 #
1887 # proc Script_Update_ExecButtons {}
1888 #------------------------------------------------------------------------
1889 # does what it says
1890 #------------------------------------------------------------------------
1891 proc Script_Update_Exec_Buttons {} {
1892 global ascScripVect
1893 set mb $ascScripVect(execBtn)
1894 switch [ScriptSelectState] {
1895 normal {
1896 $mb entryconfigure 0 -state normal
1897 $mb entryconfigure 1 -state normal
1898 }
1899 default {
1900 $mb entryconfigure 0 -state disabled
1901 $mb entryconfigure 1 -state disabled
1902 }
1903 }
1904 }
1905
1906 proc Script_SetCursor_Normal {ScriptBox} {
1907 $ScriptBox config -cursor xterm
1908 }
1909
1910 proc Script_SetCursor_Executing {ScriptBox} {
1911 $ScriptBox config -cursor watch
1912 }
1913
1914 proc Script_ExitGeom {} {
1915 return [setpos .script 40 40]
1916 }
1917
1918 #
1919 # Script_do_Exit
1920 #------------------------------------------------------------------------
1921 # exit ascend button
1922 #------------------------------------------------------------------------
1923 proc Script_do_Exit {} {
1924 global ascScripVect
1925 set ascScripVect(menubreak) 1
1926 set position [Script_ExitGeom]
1927 set res [VShowWindow.ascConfirm "190x50$position" "Exit"]
1928 if {$res == 1} {
1929 Script_ClearInterrupt
1930 EXIT NOCONFIRM
1931 }
1932 }
1933
1934 #
1935 #proc do_ScriptExecuteBox {}
1936 #------------------------------------------------------------------------
1937 # Creates a widget to ask whether the execution of the statements
1938 # in the script is going to be continuous or step by step
1939 #------------------------------------------------------------------------
1940 #
1941 proc do_ScriptExecuteBox {} {
1942 entertrace
1943 global ascScripVect ascScriptExecute
1944
1945 set tl .scriptsteptrough
1946 # build widget
1947 toplevel $tl
1948
1949 # Window manager configurations
1950 #global tk_version
1951
1952 wm positionfrom $tl user
1953 wm sizefrom $tl user
1954 wm minsize $tl 250 60
1955 wm geometry $tl 250x60[setpos .display 90 190]
1956 wm title $tl ""
1957
1958
1959 # build widget $tl.buttons_frm
1960 frame $tl.buttons_frm \
1961 -borderwidth 0
1962
1963 # build widget $tl.buttons_frm.next_button
1964 button $tl.buttons_frm.next_button \
1965 -font $ascScripVect(font) \
1966 -text Next \
1967 -width 7 \
1968 -command "
1969 global ascScriptExecute
1970 set ascScriptExecute(button) 1
1971 destroy $tl"
1972
1973 # build widget $tl.buttons_frm.btn2
1974 button $tl.buttons_frm.btn2 \
1975 -borderwidth 2 \
1976 -font $ascScripVect(font) \
1977 -text Go \
1978 -width 4 \
1979 -command "
1980 global ascScriptExecute
1981 set ascScriptExecute(button) 2
1982 destroy $tl"
1983
1984 # build widget $tl.buttons_frm.btn3
1985 button $tl.buttons_frm.btn3 \
1986 -borderwidth 3 \
1987 -font $ascScripVect(font) \
1988 -text Stop \
1989 -width 7 \
1990 -command "
1991 global ascScriptExecute
1992 set ascScriptExecute(button) 3
1993 destroy $tl"
1994
1995 # pack widget $tl.buttons_frm
1996 pack append $tl.buttons_frm \
1997 $tl.buttons_frm.next_button {left frame center expand fill} \
1998 $tl.buttons_frm.btn2 {left frame center expand fill} \
1999 $tl.buttons_frm.btn3 {left frame center expand fill}
2000
2001 # build widget $tl.lbl_frm
2002 frame $tl.lbl_frm
2003
2004 # build widget $tl.lbl_frm.main_label
2005 label $tl.lbl_frm.main_label \
2006 -text "Script Executing Statements"
2007
2008 # pack widget $tl.lbl_frm
2009 pack append $tl.lbl_frm \
2010 $tl.lbl_frm.main_label {top frame center pady 5 fillx}
2011
2012 # pack widget $tl
2013 pack append $tl \
2014 $tl.lbl_frm {top frame center pady 5 fillx} \
2015 $tl.buttons_frm {top frame center fill}
2016
2017 bind $tl <Visibility> "ascKeepOnTop $tl"
2018 proc DestroyWindow$tl {} "
2019 destroy $tl
2020 update"
2021
2022 # wait for the box to be destroyed
2023 tkwait window $tl
2024 return $ascScriptExecute(button)
2025 leavetrace
2026 }
2027
2028
2029
2030 #
2031 # Script_do_ExecuteStats {contmode}
2032 #------------------------------------------------------------------------
2033 # if contmode not given, it is assumed 1.
2034 # menubutton bindings are not supposed to require arguments.
2035 # Steps through tcl code in delimited chunks
2036 # Loops with intermediate ;
2037 #
2038 # If contmode = 0:
2039 # A)It will put each of the statements and previous
2040 # comments in the Display window
2041 # B)It stops after the execution of each statement to
2042 # ask if you
2043 # a)want to execute the next statement
2044 # b)want to stop
2045 # c)want to execute the rest of the statements without interruption.
2046 #
2047 # it will bomb Eval
2048 # Modified to use script_eval a registered call rather than tcls' eval
2049 # so as to evaluate things in the global sphere.
2050 #------------------------------------------------------------------------
2051 proc Script_do_ExecuteStats {{contmode 1}} {
2052 global ascScripVect ascSolvStatVect ascDispVect
2053 # need to store scriptbox incase a command in the script
2054 # changes to a new script buffer
2055 set locScriptBox $ascScripVect(scripBox)
2056 set com_list [Script_Selection]
2057 set statlist [split $com_list ";"]
2058 set ascScripVect(executing) 1
2059 Script_ClearInterrupt
2060 set continuous_mode $contmode
2061 set len [llength $statlist]
2062 set counter 1
2063 DispClear;
2064 DispSetEntry "Script statement just executed"
2065 Script_SetCursor_Executing $locScriptBox
2066 foreach stat $statlist {
2067 set counter [expr $counter + 1]
2068 if {$ascScripVect(menubreak) != 0} {
2069 puts stderr "Script interrupted"
2070 set ascSolvStatVect(menubreak) 0
2071 break
2072 }
2073 if {$continuous_mode != 1} {
2074 DispInsert3 $stat
2075 if {$ascDispVect(visibility)} {newraise .display}
2076 }
2077 if {[catch {script_eval $stat} jnk]} {#script_eval is a registered call
2078 set jnk [string trim $jnk]
2079 puts stderr "$jnk\n"
2080 puts "in script code: >>$stat<<"
2081 if {$continuous_mode != 1} {
2082 DispInsert3 "\n"
2083 DispInsert3 "$jnk\n"
2084 DispInsert3 "in script code: >>$stat<<"
2085 if {$ascDispVect(visibility)} {newraise .display}
2086 }
2087 # this should be done by individual commandslike
2088 # SOLVE rather than here
2089 if {[string range $jnk 0 4]=="Float"} {
2090 set ascScripVect(executing) 0
2091 error $jnk}
2092 Script_SetCursor_Normal $locScriptBox
2093 break
2094 }
2095 Script_unsel $locScriptBox
2096 update idletasks
2097 update
2098 if {$continuous_mode != 1} {
2099 if {$counter < $len} {
2100 set execmode [do_ScriptExecuteBox]
2101 DispClear;
2102 if {$execmode == 2} {
2103 set continuous_mode 1
2104 wm iconify .display
2105 }
2106 if {$execmode == 3} {
2107 wm iconify .display
2108 set ascScripVect(executing) 0
2109 set ascSolvStatVect(menubreak) 0
2110 Script_SetCursor_Normal $locScriptBox
2111 break
2112 }
2113 }
2114 }
2115 }
2116 set ascScripVect(executing) 0
2117 Script_SetCursor_Normal $locScriptBox
2118 return
2119 }
2120
2121 #
2122 # proc Script_do_Help {}
2123 # proc Script_do_BindHelp {}
2124 #------------------------------------------------------------------------
2125 # Help button calls
2126 #------------------------------------------------------------------------
2127 proc Script_do_Help {} {
2128 Help_button script
2129 }
2130 proc Script_do_BindHelp {} {
2131 Help_button {script.help onascend/tclscripts}
2132 }
2133 proc Script_getting_started {} {
2134 Help_button {howto-ascend} on modeling
2135 }
2136
2137 #------------------------------------------------------------------------
2138 # RECORDing system calls.
2139 # all of these look at the global variable ascScripVect(executing) to
2140 # see if they should record or not. Any user events that happen while a
2141 # script is running will be ignored, in all likelihood.
2142 # The script event counter ascScripVect(count) will be incremented. This
2143 # counter is used to insure that statements get inserted in the proper
2144 # order. (maybe)
2145 #------------------------------------------------------------------------
2146 # events recorded:
2147 # ASSIGN
2148 # BROWSE
2149 # READ FILE
2150 # READ VALUES
2151 # COMPILE
2152 # MERGE
2153 # REFINE
2154 # DELETE
2155 # PLOT
2156 # DISPLAY
2157 # PROBE
2158 # PRINT
2159 # RUN
2160 # SOLVE
2161 # WRITE
2162 # events ignored, for whatever reason
2163 # RESTORE
2164 # SAVE
2165 # INTEGRATE
2166 # OBJECTIVE
2167
2168 #
2169 # proc Script_AppendEvent {line counter}
2170 #------------------------------------------------------------------------
2171 # insert line into the script window at end
2172 #------------------------------------------------------------------------
2173 proc Script_AppendEvent {line counter} {
2174 global ascScripVect
2175 $ascScripVect(scripBox) insert end $line
2176 }
2177 #
2178 # proc Script_Record_Solve {inst snum args}
2179 #------------------------------------------------------------------------
2180 # record solving with solver snum if not t already.
2181 #------------------------------------------------------------------------
2182 proc Script_Record_Solve {args} {
2183 global ascScripVect
2184 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2185 set inst [lindex $args 0]
2186 set sname [lindex $args 1]
2187
2188 set pname [slv_get_pathname]
2189 set objnum [slv_get_obj_num 2]
2190 if {$objnum >= 0} {
2191 set objname "$pname.[stripbraces [dbg_write_obj 2 $objnum 0]]"
2192 set line "\nOPTIMIZE \{$objname\} IN \{$inst\} WITH $sname;"
2193 } else {
2194 set line "\nSOLVE \{$inst\} WITH $sname;"
2195 }
2196 set c [incr ascScripVect(count)]
2197 Script_AppendEvent $line $c
2198 }
2199 }
2200 #
2201 # proc Script_Record_Flush {args}
2202 #------------------------------------------------------------------------
2203 # record flushing the solver. this needs to be smarter if we have
2204 # multiple problems in the solver simultaneously.
2205 #------------------------------------------------------------------------
2206 proc Script_Record_Flush {args} {
2207 global ascScripVect
2208 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2209 set inst [lindex $args 0]
2210 set sname [lindex $args 1]
2211 set line "\nDELETE SYSTEM;"
2212 set c [incr ascScripVect(count)]
2213 Script_AppendEvent $line $c
2214 }
2215 }
2216
2217 #
2218 # proc Script_Record_Read {file args}
2219 #------------------------------------------------------------------------
2220 # record file read in.
2221 # change backslashes \ to forward slashes / and put the name in
2222 # double quotes to protect spaces in the file name.
2223 #------------------------------------------------------------------------
2224 proc Script_Record_Read {file args} {
2225 global ascScripVect
2226 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2227 regsub -all {\\} $file / properFile
2228 set line "\nREAD FILE \"$properFile\";"
2229 set c [incr ascScripVect(count)]
2230 Script_AppendEvent $line $c
2231 }
2232 }
2233
2234 #
2235 # proc Script_Record_ValueRead {file args}
2236 #------------------------------------------------------------------------
2237 # record values file read in.
2238 #------------------------------------------------------------------------
2239 proc Script_Record_ValueRead {file args} {
2240 global ascScripVect
2241 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2242 regsub -all {\\} $file / properFile
2243 set line "\nREAD VALUES \"$properFile\";"
2244 set c [incr ascScripVect(count)]
2245 Script_AppendEvent $line $c
2246 }
2247 }
2248
2249 #
2250 # proc Script_Record_ValueWrite {args}
2251 #------------------------------------------------------------------------
2252 # record values file written.
2253 #------------------------------------------------------------------------
2254 proc Script_Record_ValueWrite {args} {
2255 global ascScripVect
2256 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2257 set inst [lindex $args 0]
2258 set filename [lindex $args 1]
2259 set line "\nWRITE VALUES \{$inst\} $filename;"
2260 set c [incr ascScripVect(count)]
2261 Script_AppendEvent $line $c
2262 }
2263 }
2264
2265
2266 #
2267 # proc Script_Record_Compile {args}
2268 #------------------------------------------------------------------------
2269 # record instantiation
2270 #------------------------------------------------------------------------
2271 proc Script_Record_Compile {args} {
2272 global ascScripVect
2273 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2274 set sim [lindex $args 0]
2275 set type [lindex $args 1]
2276 set line "\nCOMPILE $sim OF $type;"
2277 set c [incr ascScripVect(count)]
2278 Script_AppendEvent $line $c
2279 }
2280 }
2281
2282 #
2283 # proc Script_Record_Refine {args}
2284 #------------------------------------------------------------------------
2285 # record interactive refinement
2286 #------------------------------------------------------------------------
2287 proc Script_Record_Refine {args} {
2288 global ascScripVect
2289 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2290 set inst [lindex $args 0]
2291 set type [lindex $args 1]
2292 set line "\nREFINE \{$inst\} TO $type;"
2293 set c [incr ascScripVect(count)]
2294 Script_AppendEvent $line $c
2295 }
2296 }
2297
2298 #
2299 # proc Script_Record_Resume {args}
2300 #------------------------------------------------------------------------
2301 # record interactive resume compile
2302 #------------------------------------------------------------------------
2303 proc Script_Record_Resume {args} {
2304 global ascScripVect
2305 set inst "a"
2306 set line "a"
2307 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2308 if {[llength $args] >0} {
2309 set inst [lindex $args 0]
2310 set line "\nRESUME \{$inst\};"
2311 } else { set line "RESUME;"}
2312 set c [incr ascScripVect(count)]
2313 Script_AppendEvent $line $c
2314 }
2315 }
2316 #
2317 # proc Script_Record_Merge {args}
2318 #------------------------------------------------------------------------
2319 # record interactive merge
2320 #------------------------------------------------------------------------
2321 proc Script_Record_Merge {args} {
2322 global ascScripVect
2323 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2324 set inst1 [lindex $args 0]
2325 set inst2 [lindex $args 1]
2326 set line "\nMERGE \{$inst1\} WITH \{$inst2\};"
2327 set c [incr ascScripVect(count)]
2328 Script_AppendEvent $line $c
2329 }
2330 }
2331
2332 #
2333 # proc Script_Record_DeleteTypes {args}
2334 #------------------------------------------------------------------------
2335 # record type deletion
2336 #------------------------------------------------------------------------
2337 proc Script_Record_DeleteTypes {args} {
2338 global ascScripVect
2339 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2340 set line "\nDELETE TYPES;"
2341 set c [incr ascScripVect(count)]
2342 Script_AppendEvent $line $c
2343 }
2344 }
2345
2346 #
2347 # proc Script_Record_Delete {sim args}
2348 #------------------------------------------------------------------------
2349 # record sim deletion
2350 #------------------------------------------------------------------------
2351 proc Script_Record_Delete {sim args} {
2352 global ascScripVect
2353 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2354 set line "\nDELETE $sim;"
2355 set c [incr ascScripVect(count)]
2356 Script_AppendEvent $line $c
2357 }
2358 }
2359
2360 #
2361 # proc Script_Record_Browse {inst args}
2362 #------------------------------------------------------------------------
2363 # record export for browsing of an instance
2364 #------------------------------------------------------------------------
2365 proc Script_Record_Browse {inst args} {
2366 global ascScripVect
2367 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2368 set line "\nBROWSE \{$inst\};"
2369 set c [incr ascScripVect(count)]
2370 Script_AppendEvent $line $c
2371 }
2372 }
2373
2374 #
2375 # proc Script_Record_Assign {args}
2376 #------------------------------------------------------------------------
2377 # record assignment
2378 #------------------------------------------------------------------------
2379 proc Script_Record_Assign {args} {
2380 global ascScripVect
2381 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2382 set inst [lindex $args 0]
2383 set value [lindex $args 1]
2384 if {[catch {set units [lindex $args 2]} ]} {set units ""}
2385 set line "\nASSIGN \{$inst\} $value \{$units\};"
2386 set c [incr ascScripVect(count)]
2387 Script_AppendEvent $line $c
2388 }
2389 }
2390
2391 #
2392 # proc Script_Record_Plot {args}
2393 #------------------------------------------------------------------------
2394 # record plot
2395 #------------------------------------------------------------------------
2396 proc Script_Record_Plot {args} {
2397 global ascScripVect
2398 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2399 set inst [lindex $args 0]
2400 set filename [lindex $args 1]
2401 set leafname [file tail $filename]
2402 set scrpref "asc[ascwhoami]"
2403 if {[string range $leafname 0 [string length $scrpref]]=="$scrpref."} {
2404 set filename ""
2405 }
2406 set line "\nPLOT \{$inst\} $filename;"
2407 set c [incr ascScripVect(count)]
2408 Script_AppendEvent $line $c
2409 set line "\nSHOW LAST;"
2410 set c [incr ascScripVect(count)]
2411 Script_AppendEvent $line $c
2412 }
2413 }
2414
2415 #
2416 # proc Script_Record_Run {instproc args}
2417 #------------------------------------------------------------------------
2418 # record initialization routine
2419 #------------------------------------------------------------------------
2420 proc Script_Record_Run {instproc args} {
2421 global ascScripVect
2422 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2423 set line "\nRUN \{$instproc\};"
2424 set c [incr ascScripVect(count)]
2425 Script_AppendEvent $line $c
2426 }
2427 }
2428
2429 #
2430 # proc Script_Record_Probe {args}
2431 #------------------------------------------------------------------------
2432 # record export to probe
2433 #------------------------------------------------------------------------
2434 proc Script_Record_Probe {args} {
2435 global ascScripVect
2436 set a1 [lindex $args 0]
2437 set a2 [lindex $args 1]
2438 set a3 [lindex $args 2]
2439 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2440 set line "\nPROBE "
2441 append line $a1
2442 append line " " \{ $a2 \}
2443 append line " " "\{[stripbraces $a3]\}\;"
2444 set c [incr ascScripVect(count)]
2445 Script_AppendEvent $line $c
2446 }
2447 }
2448
2449 #
2450 # proc Script_Record_Display {item args}
2451 #------------------------------------------------------------------------
2452 # record export to display
2453 #------------------------------------------------------------------------
2454 proc Script_Record_Display {item args} {
2455 global ascScripVect
2456 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2457 puts $item; puts $args
2458 }
2459 }
2460
2461 #
2462 # proc Script_Record_Print {item args}
2463 #------------------------------------------------------------------------
2464 # record printing probe or display
2465 #------------------------------------------------------------------------
2466 proc Script_Record_Print {item args} {
2467 global ascScripVect
2468 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2469 set line "\nPRINT $item"
2470 set c [incr ascScripVect(count)]
2471 Script_AppendEvent $line $c
2472 }
2473 }
2474 #
2475 # proc Script_Record_ClearVars {inst args}
2476 #------------------------------------------------------------------------
2477 # record solving with solver snum if not t already.
2478 #------------------------------------------------------------------------
2479 proc Script_Record_ClearVars {args} {
2480 global ascScripVect
2481 if {!$ascScripVect(executing) && $ascScripVect(Record)} {
2482 set inst [lindex $args 0]
2483 set line "\nCLEAR_VARS \{$inst\};"
2484 set c [incr ascScripVect(count)]
2485 Script_AppendEvent $line $c
2486 }
2487 }
2488
2489 #####################################################################
2490 # XF theft
2491 #------------------------------------------------------------------------
2492 # Procedure: FileInText
2493 # Description: fill a text with the contents of the file
2494 # Arguments: textWidget - the widget
2495 # {fileName} - filename to read
2496 # Returns: none
2497 # Sideeffects: the text widget is filled
2498 #------------------------------------------------------------------------
2499 proc FileInText {textWidget {fileName ""}} {# xf ignore me 5
2500
2501 # check file existance
2502 if {"$fileName" == ""} {
2503 puts stderr "no filename specified"
2504 return
2505 }
2506 set fileName [file nativename $fileName]
2507 if {[catch {set fileInFile [open $fileName r]}]} {
2508 asctk_dialog .fileerr $ascScripVect(font) \
2509 Load-Error $fileInFile "" 0 OK
2510 return
2511 }
2512
2513 set textValue [read $fileInFile]
2514 $textWidget insert end "$textValue"
2515 close $fileInFile
2516 }
2517
2518 # eof
2519
2520 #####################################################################
2521 # some text widget utils
2522 #
2523 # proc taglines {w}
2524 #------------------------------------------------------------------------
2525 # appears to tag first 80 char of lines or some such....
2526 #------------------------------------------------------------------------
2527 proc taglines {w} {
2528 set end [$w index end]
2529 set endl [split $end "."]
2530 set endl [lindex $endl 0]
2531 for {set c 1} {$c <= $endl} {incr c} {
2532 set start "$c\.0"
2533 set stop "$c\.80"
2534 $w tag add "line$c" "$start" "$stop"
2535 }
2536 }
2537
2538 #
2539 # proc tagdelete {w}
2540 #------------------------------------------------------------------------
2541 # scrap all tags but sel
2542 #------------------------------------------------------------------------
2543 proc tagdelete {w} {
2544 set nm [$w tag names]
2545 foreach tag $nm {
2546 if {$tag != "sel"} {
2547 $w tag del $tag
2548 }
2549 }
2550 }

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