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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1576 - (show annotations) (download) (as text)
Sun Aug 5 09:44:07 2007 UTC (12 years, 6 months ago) by jpye
File MIME type: text/x-tcl
File size: 80364 byte(s)
Fixed Tcl/Tk interface for new non-contiguous solver numbering.
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 $numz
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 $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 $mb entryconfigure 7 -state normal
1845 $mb entryconfigure 8 -state normal
1846 # note 9: separators don't have states
1847 }
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