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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 582 - (show annotations) (download) (as text)
Tue May 9 19:07:39 2006 UTC (18 years, 1 month ago) by ben.allan
File MIME type: text/x-tcl
File size: 111923 byte(s)
found more tk<8.4 isms.
1 # BrowserProc.tcl: support Tcl code for the Browser
2 # by Benjamin A. Allan and Kirk A. Abbott
3 # Created: January 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.99 $
6 # Last modified on: $Date: 1998/07/06 10:28:10 $
7 # Last modified by: $Author: ballan $
8 # Revision control file: $RCSfile: BrowserProc.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 qassgn {qid val {units ""}}
31 #------------------------------------------------------------------------
32 # holdover patch for old scripts.
33 # do not use this function in new scripts, use qassgn3 instead.
34 #------------------------------------------------------------------------
35 proc qassgn {qid val {units ""}} {
36 return [qassqn3 $qid $val $units]
37 }
38
39 #
40 # proc set_Browser_Defaults {}
41 #------------------------------------------------------------------------
42 # set browser on startup
43 #------------------------------------------------------------------------
44 proc set_Browser_Defaults {} {
45 global ascBrowVect ascGlobalVect xfShowWindow.browser
46
47 if {${xfShowWindow.browser}} {
48 # puts "setting browser buttons"
49 set ascBrowVect(windowname) .browser
50 set ascBrowVect(filename) [pwd]
51 set ascBrowVect(basefiletypes) {
52 {{New values} {.a4v} }
53 {{Old values} {.values} }
54 {{Most} {.*} }
55 {{All} {*} }
56 }
57 set ascBrowVect(filetypes) $ascBrowVect(basefiletypes)
58 set ascBrowVect(currentsim) ""
59 set ascBrowVect(depth) ""
60 set ascBrowVect(qlfdid) $ascBrowVect(currentsim)
61 set ascBrowVect(procedurelist) ""
62
63 if {![info exists ascBrowVect(dimconsistency)]} {
64 set ascBrowVect(dimconsistency) 1
65 }
66 if {![info exists ascBrowVect(lastreadextension)]} {
67 set ascBrowVect(lastreadextension) ".a4v"
68 }
69 if {![info exists ascBrowVect(ShowAtoms)]} {
70 set ascBrowVect(ShowAtoms) "" ;# don't show by default
71 }
72 if {![info exists ascBrowVect(HidePassed)]} {
73 set ascBrowVect(HidePassed) "" ;# don't show by default
74 }
75 if {![info exists ascBrowVect(localkinds)]} {
76 set ascBrowVect(localkinds) REAL_ATOM_INST
77 }
78 set ascBrowVect(locallist) [list \
79 REAL_ATOM_INST \
80 INTEGER_ATOM_INST \
81 BOOLEAN_ATOM_INST \
82 SYMBOL_ATOM_INST \
83 SET_ATOM_INST \
84 REL_INST \
85 LREL_INST \
86 REAL_CONSTANT_INST \
87 INTEGER_CONSTANT_INST \
88 BOOLEAN_CONSTANT_INST \
89 SYMBOL_CONSTANT_INST \
90 ]
91 foreach i $ascBrowVect(locallist) {
92 if {![info exists ascBrowVect(localshow,$i)]} {
93 set ascBrowVect(localshow,$i) 0
94 }
95 }
96 # here we establish the traces which keep the vars in sync
97 # with the lead inst kind of their group, as grouped on the
98 # check buttons in the browser
99 trace variable ascBrowVect(localshow,SET_ATOM_INST) w Brow_LeadCheckBtn
100 trace variable ascBrowVect(localshow,INTEGER_ATOM_INST) w Brow_LeadCheckBtn
101
102 if {![info exists ascBrowVect(localshow,REAL_ATOM_INST)]} {
103 set ascBrowVect(localshow,REAL_ATOM_INST) 1
104 } else {
105 set ascBrowVect(localshow,REAL_ATOM_INST) \
106 $ascBrowVect(localshow,REAL_ATOM_INST) ;# tweak the trace
107 }
108 Brow_UpdateLocalKinds
109 set ascBrowVect(initialized) "FALSE"
110
111 set ascBrowVect(parents) .browser.main_frm.parents_box.listbox1
112 set ascBrowVect(children) .browser.main_frm.child_box.listbox1
113 set ascBrowVect(local) .browser.local_frm.child_box.listbox1
114 set ascBrowVect(locallabel) nothing
115
116 $ascBrowVect(parents) configure \
117 -exportselection {0}
118
119 bind $ascBrowVect(windowname) <F5> Browser_do_ResumeCompile
120
121 bind $ascBrowVect(parents) <1> {
122 set d [%W nearest %y]
123 if {$d != ""} {
124 if {$d == [%W size] - 1} {
125 # no change of focus, just do something else
126 Brow_do_SameParentsBox $d
127 } else {
128 Brow_do_ParentsBox $d
129 }
130 }
131 }
132
133 # bind $ascBrowVect(parents) <3> {# Parentsbox
134 # set d [%W nearest %y]
135 # if {$d != "" } {
136 # Brow_do_ParentsSetValue $d
137 # }
138 # }
139
140 ascRightMouseAddCommand $ascBrowVect(parents) BrowUpdateFindCascade \
141 cascade -label "Find" \
142 -underline -1 -menu $ascBrowVect(parents).childpop.mfind
143
144 ascRightMouseAddCommand $ascBrowVect(parents) BrowUpdateRunCascade \
145 cascade -label "Run" \
146 -underline -1 -menu $ascBrowVect(parents).childpop.mrun
147
148 ascRightMouseAddCommand $ascBrowVect(parents) BrowSetValueState \
149 command -label "Set value" \
150 -underline -1 -command Browser_do_SetValue
151
152 ascRightMouseAddCommand $ascBrowVect(parents) BrowSetAttributeState \
153 command -label "Set attribute values" \
154 -underline -1 -command Brow_do_ParentsSetValue
155
156 ascRightMouseAddCommand $ascBrowVect(parents) BrowShowCodeState \
157 command -label "Show code" \
158 -underline -1 -command {Disp_do_ShowCode [inst type]}
159
160 ascRightMouseAddCommand $ascBrowVect(parents) BrowSolveState \
161 command -label "Solve..." \
162 -underline -1 -command Brow_do_Export2Solver
163
164 ascRightMouseAddCommand $ascBrowVect(parents) normal \
165 command -label "Probe..." \
166 -underline -1 -command Brow_do_Export2Probe
167
168 ascRightMouseAddCommand $ascBrowVect(parents) normal \
169 separator
170
171 ascRightMouseAddCommand $ascBrowVect(parents) normal \
172 command -command {Toggle_Remote ascBrowVect} \
173 -label {Close window} -underline -1
174
175
176 # remove global ListBox bindings from the ChildBox so we
177 # cannot select objects in the ChildBox
178 # default bindtags is $ascBrowVect(children) Listbox .browser all
179 set bind_tags [bindtags $ascBrowVect(children)]
180 if {[set findit [lsearch $bind_tags Listbox]] != -1} {
181 bindtags $ascBrowVect(children) [lreplace $bind_tags $findit $findit]
182 }
183
184 bind $ascBrowVect(children) <1> {
185 # browse down
186 set ndx [%W nearest %y]
187 if {[%W size] != "0"} {
188 Brow_do_ChildBox $ndx
189 }
190 }
191
192 bind $ascBrowVect(children) <Double-2> {
193 set ndx [%W nearest %y]
194 if {[%W size] != "0"} {
195 Brow_do_BooleanToggle $ndx
196 }
197 }
198
199 bind $ascBrowVect(children) <3> {
200 # set value
201 set ndx [%W nearest %y]
202 if {[%W size] != "0"} {
203 Brow_do_ChildSetValue $ndx
204 }
205 }
206
207 bind $ascBrowVect(local) <1> { # export to child box
208 set ndx [%W nearest %y]
209 if {[%W size] != "0"} {
210 Brow_do_LocalBrowse $ndx
211 }
212 }
213
214 bind $ascBrowVect(local) <3> { # set value, if sane
215 set ndx [%W nearest %y]
216 if {[%W size] != 0} {
217 Brow_do_LocalSetValue $ndx
218 }
219 }
220
221 # set up the multiple setvalue box
222 Brow_InitSetvalue
223
224 # Update Enabled/Disabled entries when a menu is posted
225 #
226 .browser.menubar.file configure \
227 -postcommand Brow_Update_File_Buttons
228
229 .browser.menubar.display configure \
230 -postcommand Brow_Update_Display_Buttons
231
232 .browser.menubar.edit configure \
233 -postcommand Brow_Update_Edit_Buttons
234
235 .browser.menubar.export configure \
236 -postcommand Brow_Update_Export_Buttons
237
238 .browser.menubar.find configure \
239 -postcommand Brow_Update_Find_Buttons
240
241 .browser.menubar.view configure \
242 -postcommand Brow_Update_View_Buttons
243
244
245 # Set Initialized flag
246 #
247 set ascBrowVect(initialized) "FALSE"
248
249 # bind "^C"
250 bind .browser <Control-Key-C> "Tool_exit"
251
252 VPane-Bind .browser.main_frm parents_box child_box 10 0.333
253 HPane-Bind .browser main_frm local_frm 10 0.5
254
255 # set pointer
256 .browser config -cursor left_ptr
257
258 # setup trace on dim consistency checking.
259 if {[trace vinfo ascBrowVect(dimconsistency)]==""} {
260 trace variable ascBrowVect(dimconsistency) w Brow_SetDimNoise
261 }
262 } else {
263 puts "browser doesn't exist! buttons not set"
264 }
265 }
266 #update disabling on find popup
267 proc BrowUpdateFindCascade {} {
268 global ascBrowVect ascPopdata tk_version
269 set m $ascBrowVect(parents).childpop.mfind
270 if {![winfo exists $m]} {
271 menu $m \
272 -tearoffcommand [string toupper $m] \
273 -tearoff 0
274 $m add command \
275 -command {Brow_do_FindFixed TRUE} \
276 -label {Fixed variables} \
277 -underline -1
278 $m add command \
279 -command {Brow_do_FindOpers} \
280 -label {Operands} \
281 -underline -1
282 $m add command \
283 -command {Brow_do_FindFixed FALSE} \
284 -label {Free variables} \
285 -underline -1
286 $m add command \
287 -command {Brow_do_FindEligible} \
288 -label {Eligible variables} \
289 -underline -1
290 $m add command \
291 -command {Brow_do_FindActive} \
292 -label {Active variables} \
293 -underline -1
294 $m add command \
295 -command {Brow_do_FindUndefined} \
296 -label {Undefined values} \
297 -underline -1
298 # bindings don't stick if you leave out this update.
299 update
300 switch $tk_version {
301 8.4 -
302 8.5 {
303 bind $m <Any-Leave> "+
304 set ascPopdata($ascBrowVect(parents).childpop.in) 0
305 set ascPopdata($ascBrowVect(parents).childpop.id) \
306 \[after \$ascPopdata(delay) \{if \{!\$ascPopdata($ascBrowVect(parents).childpop.in)\} \
307 \{ tk::MenuUnpost $ascBrowVect(parents).childpop \} \}\]
308 "
309 }
310 default {
311 bind $m <Any-Leave> "+
312 set ascPopdata($ascBrowVect(parents).childpop.in) 0
313 set ascPopdata($ascBrowVect(parents).childpop.id) \
314 \[after \$ascPopdata(delay) \{if \{!\$ascPopdata($ascBrowVect(parents).childpop.in)\} \
315 \{ tkMenuUnpost $ascBrowVect(parents).childpop \} \}\]
316 "
317 }
318 bind $m <Any-Enter> "+
319 set ascPopdata($ascBrowVect(parents).childpop.in) 1
320 catch \{after cancel \$ascPopdata($ascBrowVect(parents).childpop.id)\}
321 "
322 }
323 menu_disable_all $m
324 if {[$ascBrowVect(parents) size] != 0} {
325 $m entryconfigure 0 -state normal
326 $m entryconfigure 5 -state normal
327 }
328 switch [inst kind] {
329 WHEN_INST -
330 REL_INST -
331 LREL_INST {
332 $m entryconfigure 1 -state normal
333 }
334 MODEL_INST -
335 ARRAY_INT_INST -
336 ARRAY_ENUM_INST {
337 $m entryconfigure 2 -state normal
338 $m entryconfigure 3 -state normal
339 }
340 default { }
341 }
342
343 return normal
344 }
345 #update methods menu
346 proc BrowUpdateRunCascade {} {
347 global ascBrowVect ascPopdata
348 set m $ascBrowVect(parents).childpop.mrun
349 if {[winfo exists $m]} {
350 catch {destroy $m}
351 }
352 set mlist ""
353 if {[string compare [inst kind] "MODEL_INST"] == 0} {
354 set itype [inst type]
355 if {![llength [libr_query -methods -type $itype]] && \
356 ![llength [libr_query -basemethods]]} {
357 return disabled
358 }
359 set mlist [libr_query -methods -type $itype]
360 set blist [libr_query -basemethods]
361 foreach i $blist {
362 if {[lsearch -exact $mlist $i] == -1} {
363 lappend mlist $i
364 }
365 }
366 set nlist [lsort $mlist]
367 set mlist $nlist
368 } else {
369 return disabled
370 }
371 set root [Brow_get_subname]
372 menu $m \
373 -tearoffcommand [string toupper $m] \
374 -tearoff 0
375 foreach i $mlist {
376 $m add command \
377 -command "RUN $root.$i" \
378 -label $i \
379 -underline -1
380 }
381 update
382 bind $m <Any-Leave> "+
383 set ascPopdata($ascBrowVect(parents).childpop.in) 0
384 set ascPopdata($ascBrowVect(parents).childpop.id) \
385 \[after \$ascPopdata(delay) \{if \{!\$ascPopdata($ascBrowVect(parents).childpop.in)\} \
386 \{ tkMenuUnpost $ascBrowVect(parents).childpop \} \}\]
387 "
388 bind $m <Any-Enter> "+
389 set ascPopdata($ascBrowVect(parents).childpop.in) 1
390 catch \{after cancel \$ascPopdata($ascBrowVect(parents).childpop.id)\}
391 "
392 return normal
393 }
394 #
395 # proc Brow_trans_option {opt}
396 #-----------------------------------------------------------------------
397 # Brow_trans_option: translate Xname into vector name for the options
398 # and return subscript, vector id in a list
399 # If option unrecognized, return same name and Brow
400 # Note: a useless function unless the browser resources are standardized
401 # like everyone elses
402 #-----------------------------------------------------------------------
403 proc Brow_trans_option {opt} {
404 switch $opt {
405 {displayAtomValue} {return {TypeorValue Brow}}
406 {queryFile} {return {queryfile Brow}}
407 default {return "$opt Brow"}
408 }
409 }
410
411 #
412 # proc Brow_do_Font {args}
413 #---------------------------------------------------------------------
414 # font select button for browser window
415 #---------------------------------------------------------------------
416 proc Brow_do_Font {args} {
417 global ascBrowVect
418 set font ""
419 if {$args !=""} {
420 set font $args
421 } else {
422 set font [ascFontGet]
423 }
424 if {"$font" == ""} {
425 return
426 }
427 $ascBrowVect(children) configure -font $font
428 $ascBrowVect(parents) configure -font $font
429 $ascBrowVect(local) configure -font $font
430 set ascBrowVect(font) [$ascBrowVect(children) cget -font]
431 }
432
433
434 #
435 # proc Brow_InitBrowser {}
436 #-------------------------------------------------------------------------
437 # empty browserboxes and set currentsim/child/parent null
438 #-------------------------------------------------------------------------
439 proc Brow_InitBrowser {} {
440 global ascBrowVect
441
442 rootinit;
443 ascclearlist $ascBrowVect(parents);
444 ascclearlist $ascBrowVect(children);
445 ascclearlist $ascBrowVect(local);
446 }
447
448 #
449 # proc BrowMakeName
450 #-------------------------------------------------------------------------
451 # return qlfdid of child
452 #-------------------------------------------------------------------------
453 proc BrowMakeName {} {
454 global ascBrowVect
455
456 set name [Brow_get_subname]
457 set ascBrowVect(qlfdid) $name
458 set ascBrowVect(instkind) [inst kind]
459 # puts "-->$ascBrowVect(qlfdid) -- [inst kind] -- [inst nchild]<--"
460 return $ascBrowVect(qlfdid)
461 }
462
463 #
464 # proc Brow_do_ChildBox {ndx}
465 #-------------------------------------------------------------------------
466 # Gets the child selected in the child box at index ndx. Strips the \{ and
467 # \} and sets the 0th element as the potential new parent.
468 # Calls the registerd command "root $newparent". The "root" command will
469 # for the instance name and adjust the depth if found. If all is ok the
470 # newparent is inserted in the parent listbox.
471 # Brow_do_UpdateChild is then used to update the child box. Set the new
472 # selection to the newparent.
473 #-------------------------------------------------------------------------
474 proc Brow_do_ChildBox {ndx} {
475 global ascBrowVect
476
477 set a [$ascBrowVect(children) get $ndx]
478 set newparent [stripbraces $a]
479 switch [inst kind] {
480 ERROR_INST -
481 REAL_ATOM_INST -
482 INTEGER_ATOM_INST -
483 BOOLEAN_ATOM_INST -
484 SYMBOL_ATOM_INST -
485 SET_ATOM_INST -
486 REL_INST -
487 LREL_INST {return; #disable descent into ATOM children}
488 }
489 set aftername [string last " IS_A " $newparent]
490 if {$aftername == -1} {
491 set aftername [string last " = " $newparent]
492 }
493 if {$aftername >= 0 } {
494 set prettyP [string range $newparent 0 $aftername]
495 set prettyP [string trim $prettyP]
496 set candidate [string trim $prettyP "\[\'\]"]
497 set nok [catch {root $candidate} errmsg]
498 if {$nok} {
499 if {$errmsg == "At leaves of the Instance Tree"} {
500 puts stderr "--> $errmsg"
501 }
502 $ascBrowVect(children) delete 0 end
503 return
504 } else {
505 $ascBrowVect(parents) insert end $prettyP
506 Brow_do_UpdateChild \
507 $ascBrowVect(TypeorValue) \
508 $ascBrowVect(ShowAtoms) \
509 $ascBrowVect(HidePassed)
510 }
511 Brow_Setup_Selection $ascBrowVect(parents)
512 return;
513 }
514 }
515
516 #
517 # Brow_get_partname {listindex}
518 #-------------------------------------------------------------------------
519 # returns the name up to element ndx (which counts from 0) from
520 # the browser parent box, less any trailing non-MODEL names.
521 # if listindex is end, returns complete less any trailing array/ATOM names.
522 #-------------------------------------------------------------------------
523 proc Brow_get_partname {{ndx -1}} {
524 global ascBrowVect
525 if {$ndx < 0 || "$ndx" == "end"} {
526 set ndx [$ascBrowVect(parents) size]
527 }
528 set name "[$ascBrowVect(parents) get 0 0]"
529 set lastpart $name
530 if {[$ascBrowVect(parents) size] > 1} {
531 foreach i [$ascBrowVect(parents) get 1 $ndx] {
532 if { [string index $i 0] != "\["} {
533 append name .$i
534 } else {
535 append name $i
536 }
537 qlfdid $name
538 if {![string compare [inst kind search] "MODEL_INST"]} {
539 set lastpart $name
540 }
541 }
542 }
543 return $lastpart
544 }
545
546 #
547 # Brow_get_subname {listindex}
548 #-------------------------------------------------------------------------
549 # returns the name up to element ndx (which counts from 0) from
550 # the browser parent box.
551 # if listindex is end, returns complete name.
552 #-------------------------------------------------------------------------
553 proc Brow_get_subname {{ndx -1}} {
554 global ascBrowVect
555 if {$ndx < 0 || "$ndx" == "end"} {
556 set ndx [$ascBrowVect(parents) size]
557 }
558 set name "[$ascBrowVect(parents) get 0 0]"
559 if {[$ascBrowVect(parents) size] > 1} {
560 foreach i [$ascBrowVect(parents) get 1 $ndx] {
561 if { [string index $i 0] != "\["} {
562 append name .$i
563 } else {
564 append name $i
565 }
566 }
567 }
568 return $name
569 }
570
571 #
572 # proc Brow_do_SameParentsBox {ndx}
573 #-------------------------------------------------------------------------
574 # Does things that we want when not changing the focus.
575 # Creates a popup menu for:
576 # running methods, what else?
577 #-------------------------------------------------------------------------
578 proc Brow_do_SameParentsBox {ndx} {
579 # puts we should put a menu here.
580 }
581 #
582 # proc Brow_do_ParentsBox {ndx}
583 #-------------------------------------------------------------------------
584 # The main binding for ascending the Browser Parents Box.
585 # Sets the current working
586 # instance based on the listbox index. Updates the child box. Sets the
587 # current selection. A valid listbox index must be sent to this function.
588 # i.e. A valid instance must exist and must have been selected.
589 #-------------------------------------------------------------------------
590 proc Brow_do_ParentsBox {ndx} {
591 global ascBrowVect ascScripVect
592 set depth $ndx
593 incr depth
594 set muffle $ascScripVect(executing)
595 if {!$muffle} {
596 set ascScripVect(executing) 1
597 }
598 if {[$ascBrowVect(parents) size] > 1} {
599 set name [Brow_get_subname $ndx]
600 Brow_Export_Any_2Browser $name
601 }
602 if {!$muffle} {
603 set ascScripVect(executing) 0
604 }
605 }
606
607 # left side browser
608 proc Brow_do_ParentsSetValue {{ndx 0}} {
609 global ascBrowVect
610 set name [Brow_get_subname]
611 puts $name
612 if {[catch {qlfdid $name} errmsg]} {return}
613 Browser_SetvalueBox $ascBrowVect(windowname) $name
614 }
615
616 # right side browser
617 proc Brow_do_ChildSetValue {ndx} {
618 global ascBrowVect
619 set i [lindex [$ascBrowVect(children) get $ndx] 0]
620 set name [Brow_childname [Brow_get_subname] $i]
621 if {[catch {qlfdid $name} errmsg]} {return}
622 Browser_do_SetValue $ascBrowVect(windowname) $name
623 }
624
625 # bottom browser
626 proc Brow_do_LocalSetValue {ndx} {
627 global ascBrowVect
628 set i [lindex [$ascBrowVect(local) get $ndx] 0]
629 set name [Brow_childname [Brow_get_subname] $i]
630 if {[catch {qlfdid $name} errmsg]} {return}
631 Browser_do_SetValue $ascBrowVect(local) $name
632 }
633
634 proc Brow_do_LocalBrowse {ndx} {
635 global ascBrowVect
636 set i [lindex [$ascBrowVect(local) get $ndx] 0]
637 Script_ClearInterrupt
638 BROWSE [Brow_childname [Brow_get_subname] $i]
639 }
640
641 proc Brow_UpdateLocalLabel {leadkind} {
642 global ascBrowVect
643 switch $leadkind {
644 REAL_ATOM_INST {set ascBrowVect(locallabel) {Real variables}}
645 INTEGER_ATOM_INST {set ascBrowVect(locallabel) {Discrete variables}}
646 REL_INST {set ascBrowVect(locallabel) {Real relations}}
647 LREL_INST {set ascBrowVect(locallabel) {Logical relations}}
648 REAL_CONSTANT_INST {set ascBrowVect(locallabel) {Real constants}}
649 SET_ATOM_INST {set ascBrowVect(locallabel) {Discrete constants}}
650 }
651 }
652
653 #
654 # proc Brow_do_UpdateCore {basename listbox instkindlist}
655 #-------------------------------------------------------------------------
656 # # Prototype implementation. Not to be optimized until we prove it needs
657 # # optimizing.
658 # This cannot be called until after Brow_do_ParentsBox.
659 # This should not be called until after Brow_do_UpdateChild
660 # Updates the local box based on the available information in the instance
661 # and ascBrowVect(localkinds).
662 # This implementation could be extremely speeded up by reconsidering
663 # whether we should have multiple local_frm.childbox of which only
664 # one is shown (a la probe) and whether we should revisit C code
665 # to return additional info to reduce the tcl work load.
666 # Additionally, the ui needs more buttons: this is a slight overload of
667 # the View button.
668 #
669 # dumb assumptions:
670 # all things in localbox are atoms (in the sense of having a value)
671 # user wants to see ATOM attributes/units
672 # [brow_child_list search all $ascBrowVect(TypeorValue)]
673 #-------------------------------------------------------------------------
674 proc Brow_do_UpdateCore {base box kindlist} {
675 ascclearlist $box
676 set connector .
677 set rootkind {}
678 if {[catch {set rootkind [inst kind current]} err]} {
679 return
680 }
681 set childlist [inst child]
682 if {$rootkind=="ARRAY_ENUM_INST" || $rootkind=="ARRAY_INT_INST"} {
683 set connector ""
684 }
685 foreach c $childlist {
686 set name $base$connector$c
687 if {[catch {qlfdid $name} errmsg]} {continue}
688 set instkind [inst kind search]
689 if {[lsearch -exact $kindlist $instkind] != -1 &&
690 [libr_type_is_shown [inst type search]] != 0} {
691 set line ""
692 set esym " = "
693 set val [inst atomvalue search]
694 switch $instkind {
695 REL_INST -
696 LREL_INST {
697 set esym " : "
698 }
699 }
700 catch {set val [lindex [u_browgetval search] 0]} errmsg
701 append line $c $esym $val
702 $box insert end $line
703 }
704 }
705 }
706
707 #
708 # proc Brow_do_UpdateLocalBox {}
709 #-------------------------------------------------------------------------
710 # # Prototype implementation. Not to be optimized until we prove it needs
711 # # optimizing.
712 # This cannot be called until after Brow_do_ParentsBox.
713 # This should not be called until after Brow_do_UpdateChild
714 # Updates the local box based on the available information in the instance
715 # and ascBrowVect(localkinds).
716 # This implementation could be extremely speeded up by reconsidering
717 # whether we should have multiple local_frm.childbox of which only
718 # one is shown (a la probe) and whether we should revisit C code
719 # to return additional info to reduce the tcl work load.
720 # Additionally, the ui needs more buttons: this is a slight overload of
721 # the View button.
722 #
723 # dumb assumptions:
724 # all things in localbox are atoms (in the sense of having a value)
725 # user wants to see ATOM attributes/units
726 # [brow_child_list search all $ascBrowVect(TypeorValue)]
727 #
728 # args should be empty or the lead type of a group of types corresponding
729 # to a checkbutton on the browser.
730 # It tells the user which button they toggled last, to help explain
731 # the 2 letter button labels.
732 #-------------------------------------------------------------------------
733 proc Brow_do_UpdateLocalBox {args} {
734 global ascBrowVect
735 Brow_UpdateLocalLabel $args
736 set base [Brow_get_subname]
737 # here we need to assemble localkinds from the current set of booleans
738 Brow_UpdateLocalKinds
739 Brow_do_UpdateCore [Brow_get_subname] \
740 $ascBrowVect(local) \
741 $ascBrowVect(localkinds)
742 }
743
744 #
745 # proc Brow_LeadCheckBtn {name1 name2 op}
746 #-------------------------------------------------------------------------
747 # updates the groups of variables based on the name of the lead
748 # instance type toggled by the check buttons.
749 #-------------------------------------------------------------------------
750 proc Brow_LeadCheckBtn {name1 name2 op} {
751 global ascBrowVect
752 if {$name1 != "ascBrowVect" || $op != "w"} {
753 return
754 }
755 switch $name2 {
756 localshow,REL_INST -
757 localshow,LREL_INST -
758 localshow,REAL_CONSTANT_INST -
759 localshow,REAL_ATOM_INST {
760 # do nothing for these, as they are singletons
761 return
762 }
763 localshow,INTEGER_ATOM_INST {
764 set ascBrowVect(localshow,BOOLEAN_ATOM_INST) \
765 $ascBrowVect(localshow,INTEGER_ATOM_INST)
766 set ascBrowVect(localshow,SYMBOL_ATOM_INST) \
767 $ascBrowVect(localshow,INTEGER_ATOM_INST)
768 }
769 localshow,BOOLEAN_ATOM_INST -
770 localshow,SYMBOL_ATOM_INST {
771 # do nothing for these, as they are followers of INTEGER_ATOM_INST
772 return
773 }
774 localshow,SET_ATOM_INST {
775 set ascBrowVect(localshow,INTEGER_CONSTANT_INST) \
776 $ascBrowVect(localshow,SET_ATOM_INST)
777 set ascBrowVect(localshow,BOOLEAN_CONSTANT_INST) \
778 $ascBrowVect(localshow,SET_ATOM_INST)
779 set ascBrowVect(localshow,SYMBOL_CONSTANT_INST) \
780 $ascBrowVect(localshow,SET_ATOM_INST)
781 }
782 localshow,INTEGER_CONSTANT_INST -
783 localshow,BOOLEAN_CONSTANT_INST -
784 localshow,SYMBOL_CONSTANT_INST {
785 # do nothing for these, as they are followers of SET_ATOM_INST
786 return
787 }
788 default {return}
789 }
790 }
791 #
792 # proc Brow_UpdateLocalKinds {}
793 #-------------------------------------------------------------------------
794 # fills in the value of ascBrowVect(localkinds)
795 # given the current values of the localshow booleans
796 #-------------------------------------------------------------------------
797 proc Brow_UpdateLocalKinds {} {
798 global ascBrowVect
799 set ascBrowVect(localkinds) ""
800 foreach i $ascBrowVect(locallist) {
801 if {$ascBrowVect(localshow,$i)} {
802 lappend ascBrowVect(localkinds) $i
803 }
804 }
805 }
806
807 #
808 # proc Brow_do_UpdateChild { {TypeorVal TYPE} {atoms ATOMS} {passed PASSED}}
809 #-------------------------------------------------------------------------
810 # Updates the child box based on the current instance. Will use as
811 # default arguments the ascBrowVect(TypeorVal) variable.
812 # Calls the brow_child_list routines with
813 # these arguments to display the child (aka subitem) info. Sets the
814 # current selection back to the Brow parents Box. The C-call WILL NOT
815 # return an error if the current instance is NULL. This simplifies the
816 # code a lot!!!
817 #-------------------------------------------------------------------------
818 proc Brow_do_UpdateChild { {TypeorVal TYPE} {atoms ATOMS} {passed PASSED}} {
819 global ascBrowVect
820
821 set nok [catch {
822 brow_child_list current all $TypeorVal $atoms $passed
823 } childlist_or_err]
824 if {$nok} {
825 if {$childlist_or_err == "At leaves of the Instance Tree"} {
826 $ascBrowVect(children) delete 0 end
827 return
828 }
829 if {$childlist_or_err == "Child not found - check your root"} {
830 $ascBrowVect(children) delete 1 end
831 return
832 }
833 }
834 set childlist $childlist_or_err
835 $ascBrowVect(children) delete 0 end
836 foreach child $childlist {
837 $ascBrowVect(children) insert end $child
838 }
839 Brow_do_UpdateLocalBox
840 }
841
842 #
843 # proc Brow_SetDimNoise {n1 n2 mode}
844 #-------------------------------------------------------------------------
845 # toggle the C setting of dim noise whenever the user does.
846 #-------------------------------------------------------------------------
847 proc Brow_SetDimNoise {n1 n2 mode} {
848 global ascBrowVect
849 u_dim_setverify $ascBrowVect(dimconsistency)
850 }
851 #
852 # Brow_do_TypeorValue
853 #-------------------------------------------------------------------------
854 # This is the command that is bound to the checkbutton for setting the
855 # view in the browser to variable types or values.
856 #-------------------------------------------------------------------------
857 proc Brow_do_TypeorValue {} {
858 global ascBrowVect
859 Brow_do_UpdateChild \
860 $ascBrowVect(TypeorValue) \
861 $ascBrowVect(ShowAtoms) \
862 $ascBrowVect(HidePassed)
863 }
864
865
866 #
867 # proc Brow_Update_Edit_Buttons {}
868 #-------------------------------------------------------------------------
869 # This procedure is bound to the Edit Menu Button.
870 # Used for enabling the Edit_Menu items depending on the type of the
871 # selected instance
872 #-------------------------------------------------------------------------
873 # by default everybody is disabled until proven useful
874 proc Brow_Update_Edit_Buttons {} {
875 global ascBrowVect
876 set mb .browser.menubar.edit
877
878 menu_disable_all $mb
879 if {[$ascBrowVect(parents) size] == 0 || [catch {inst kind} ]} {
880 return
881 }
882
883 # Run method -- menu_item 0
884 #
885 if {[string compare [inst kind] "MODEL_INST"] == 0} {
886 set itype [inst type]
887 if {[llength [libr_query -methods -type $itype]] || \
888 [llength [libr_query -basemethods]]} {
889 $mb entryconfigure 0 -state normal
890 }
891 }
892 # Clear Vars -- menu_item 1
893 #
894 if {![inst atomchild]} {
895 $mb entryconfigure 1 -state normal
896 }
897 # Set Value -- menu item 3
898 #
899 $mb entryconfigure 3 -state [BrowRealSetValueState]
900
901 # read/write values always work
902 # refine button 4
903 # disable if the instance has no potential refinements or if
904 # the instance is the child of an atom.
905 if {[is_type_refined] != 0 && ![inst atomchild]} {
906 $mb entryconfigure 4 -state normal
907 }
908 # merge button 5 and resume button 7
909 if {![inst atomchild]} {
910 $mb entryconfigure 5 -state normal
911 $mb entryconfigure 7 -state normal
912 }
913 }
914
915 proc BrowSolveState {} {
916 if {![string compare [inst kind] "MODEL_INST"]} {
917 return normal
918 }
919 return disabled
920 }
921 proc BrowShowCodeState {} {
922 global ascPopInfo
923 if {[inst type]==""} {
924 return disabled
925 }
926 set lbl "Show code of [inst type]..."
927 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
928 return normal
929 }
930
931 proc BrowRealSetValueState {} {
932 if {[inst isassignable]} {
933 return normal
934 }
935 return disabled
936 }
937
938 proc BrowSetValueState {} {
939 global ascPopInfo
940 set lbl "Set value of [Brow_get_subname]"
941 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
942 return [BrowRealSetValueState]
943 }
944
945 proc BrowSetAttributeState {} {
946 global ascPopInfo
947 set lbl "Set attributes of [Brow_get_subname]"
948 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
949 return normal
950 }
951 #
952 # proc Brow_Update_View_Buttons {}
953 #-------------------------------------------------------------------------
954 # Disable or enable the view menu items.
955 #-------------------------------------------------------------------------
956 proc Brow_Update_View_Buttons {} {
957 # save option and hide/unhide names items
958 global ascBrowVect ascGlobalVect
959 set mb .browser.menubar.view
960
961 if {$ascGlobalVect(saveoptions) == 0} {
962 $mb entryconfigure 9 -state disabled
963 } else {
964 $mb entryconfigure 9 -state normal
965 }
966
967 if {[$ascBrowVect(parents) size] == 0 || [catch {inst kind} ]} {
968 return
969 }
970 set kind [inst kind]
971 if {$kind != "ARRAY_ENUM_INST" && $kind != "ARRAY_INT_INST"} {
972 $mb entryconfigure 4 -state normal
973 $mb entryconfigure 5 -state normal
974 } else {
975 $mb entryconfigure 4 -state disabled
976 $mb entryconfigure 5 -state disabled
977 }
978 }
979
980 #
981 # proc Brow_Update_File_Buttons {}
982 #-------------------------------------------------------------------------
983 # Disable or enable the file menu items.
984 #-------------------------------------------------------------------------
985 proc Brow_Update_File_Buttons {} {
986 # all buttons always valid currently.
987 }
988 #
989 # proc Brow_Update_Display_Buttons {}
990 #-------------------------------------------------------------------------
991 # Disable or enable the display menu items.
992 #-------------------------------------------------------------------------
993 proc Brow_Update_Display_Buttons {} {
994 global ascBrowVect
995 set mb .browser.menubar.display
996
997 menu_disable_all $mb
998 if {[$ascBrowVect(parents) size] == 0 || [catch {inst kind} ]} {
999 return
1000 }
1001 set kind [inst kind]
1002 # Atrributes -- menu_item 0
1003 # implemented for real variables
1004 #$mb entryconfigure 1 -state normal
1005
1006
1007 # Attributes item 0
1008 if {$kind == "REAL_ATOM_INST"} {
1009 $mb entryconfigure 0 -state normal
1010 }
1011
1012 # Relations -- menu_item 1
1013 # Enable if is a model instance, is a relation, or is
1014 # an array of relation. The command __brow_isrelation handles the
1015 # 2nd and 3rd Case. Also enable if the instance is a
1016 # REAL_ATOM_INST -- a little overloading here. What we
1017 # do is display the relations that the atom is incident in.
1018 if {$kind == "MODEL_INST" || $kind == "REAL_ATOM_INST"} {
1019 $mb entryconfigure 1 -state normal
1020 } else {
1021 if {[__brow_isrelation current] == 1} {
1022 $mb entryconfigure 1 -state normal
1023 } {
1024 $mb entryconfigure 1 -state disabled
1025 }
1026 }
1027
1028 # Conditional Relations -- menu_item 2
1029 # Enable if is a model instance
1030
1031 if {$kind =="MODEL_INST" } {
1032 $mb entryconfigure 2 -state normal
1033 } else {
1034 $mb entryconfigure 2 -state disabled
1035 }
1036
1037 # Logical Relations -- menu_item 3
1038 # Enable if is a model instance, is a logical relation, or is
1039 # an array of logical relation. The command __brow_islogrel handles the
1040 # 2nd and 3rd Case. Also enable if the instance is a
1041 # BOOLEAN_ATOM_INST. What we do is display the logical relations
1042 # that the atom is incident in.
1043 #
1044
1045 if {$kind == "MODEL_INST" || $kind == "BOOLEAN_ATOM_INST"} {
1046 $mb entryconfigure 3 -state normal
1047 } else {
1048 if {[__brow_islogrel current] == 1} {
1049 $mb entryconfigure 3 -state normal
1050 } else {
1051 $mb entryconfigure 3 -state disabled
1052 }
1053 }
1054
1055 # Conditional Logical Relations -- menu_item 4
1056 # Enable if is a model instance
1057
1058 if {$kind =="MODEL_INST" } {
1059 $mb entryconfigure 4 -state normal
1060 } else {
1061 $mb entryconfigure 4 -state disabled
1062 }
1063
1064
1065 # When Statement -- menu_item 5
1066 # Enable if is a model instance, is a when, or is
1067 # an array of when. The command __brow_iswhen handles the
1068 # 2nd and 3rd Case.
1069 #
1070
1071 if {$kind == "MODEL_INST"} {
1072 $mb entryconfigure 5 -state normal
1073 } else {
1074 if {[__brow_iswhen current] == 1} {
1075 $mb entryconfigure 5 -state normal
1076 } else {
1077 if {[__brow_isinstanceinwhen current] == 1 } {
1078 $mb entryconfigure 5 -state normal
1079 } else {
1080 $mb entryconfigure 5 -state disabled
1081 }
1082 }
1083 }
1084
1085 # Plot -- menu item 7
1086 #
1087 if {[b_isplottable current]} {
1088 $mb entryconfigure 7 -state normal
1089 } else {
1090 $mb entryconfigure 7 -state disabled
1091 }
1092 # Statistics -- menu item 8
1093 #
1094 $mb entryconfigure 8 -state normal
1095 }
1096 #
1097 # proc Brow_Update_Find_Buttons {}
1098 #-------------------------------------------------------------------------
1099 # Disable or enable the find menu items.
1100 #-------------------------------------------------------------------------
1101 proc Brow_Update_Find_Buttons {} {
1102 global ascBrowVect
1103 set mb .browser.menubar.find
1104
1105 menu_disable_all $mb
1106 if {[$ascBrowVect(parents) size] == 0 || [catch {inst kind} ]} {
1107 return
1108 }
1109 # Enable all that are currently implemented, some for certain types only
1110 set disabled_list [list 7 8]
1111 set enabled_list [list 0 1 2 3 4 5 6 9]
1112
1113 foreach item $enabled_list {
1114 $mb entryconfigure $item -state normal
1115 }
1116 # type
1117 if {[$ascBrowVect(parents) size] != 0} {
1118 $mb entryconfigure 1 -state normal
1119 } else {
1120 $mb entryconfigure 1 -state disabled
1121 }
1122 # eligible
1123 if {[inst kind] == "MODEL_INST"} {
1124 $mb entryconfigure 5 -state normal
1125 } else {
1126 $mb entryconfigure 5 -state disabled
1127 }
1128 # active
1129 if {[inst kind] == "MODEL_INST"} {
1130 $mb entryconfigure 6 -state normal
1131 } else {
1132 $mb entryconfigure 6 -state disabled
1133 }
1134 # operands
1135 switch [inst kind] {
1136 WHEN_INST -
1137 LREL_INST -
1138 REL_INST {
1139 $mb entryconfigure 7 -state normal
1140 }
1141 default {
1142 $mb entryconfigure 7 -state disabled
1143 }
1144 }
1145 }
1146 #
1147 # proc Brow_Update_Export_Buttons {}
1148 #-------------------------------------------------------------------------
1149 # Disable or enable the export menu items.
1150 #-------------------------------------------------------------------------
1151 proc Brow_Update_Export_Buttons {} {
1152 global ascBrowVect
1153 set mb .browser.menubar.export
1154
1155 menu_disable_all $mb
1156 if {[$ascBrowVect(parents) size] == 0 || [catch {inst kind} ]} {
1157 return
1158 }
1159 # Enable export to solver
1160 # Will later be enabled for models and arrays of models.
1161 #
1162 if {[inst kind]=="MODEL_INST"} {
1163 $mb entryconfigure 0 -state normal
1164 }
1165 # probe legal always once not null
1166 if {![inst atomchild]} {
1167 $mb entryconfigure 1 -state normal
1168 }
1169 $mb entryconfigure 2 -state normal
1170 }
1171
1172
1173 #
1174 # proc Brow_do_BooleanToggle {ndx}
1175 #-------------------------------------------------------------------------
1176 # flip the truth of child ndx in the childbox
1177 #-------------------------------------------------------------------------
1178 proc Brow_do_BooleanToggle {ndx} {
1179 global ascBrowVect
1180 set int_ndx [expr $ndx + 1]
1181 set element [brow_child_list current $int_ndx VALUE]
1182 if {$element == ""} {
1183 return
1184 }
1185 set childname [lindex [lindex $element 0] 0]
1186 #
1187 # PUT SOME SAFETY CHECKS HERE !!!!
1188 # (put some safety checks in your c code, nincompoop)
1189 #
1190 if {[catch {root $childname} ]} {return}
1191 set kind [inst kind]
1192 if {$kind == "BOOLEAN_INST" || $kind == "BOOLEAN_ATOM_INST"} {
1193 set childvalue [lindex [stripbraces $element] 2]
1194 set childname [lindex [stripbraces $element] 0]
1195 if {$childvalue == "TRUE"} {
1196 set childvalue "FALSE"
1197 } else {
1198 set childvalue "TRUE"
1199 }
1200 brow_assign $childvalue
1201 set name [Brow_get_subname].$childname
1202 oldinst;
1203 Brow_do_UpdateChild \
1204 $ascBrowVect(TypeorValue) \
1205 $ascBrowVect(ShowAtoms) \
1206 $ascBrowVect(HidePassed)
1207 HUB_Message_to_HUB BOOLEANUPDATED [sims getc]
1208 HUB_Message_to_HUB VARIABLEUPDATED [sims getc]
1209 HUB_Message_to_HUB VALUESET $name $childvalue
1210 } else {
1211 oldinst;
1212 }
1213 }
1214
1215 #
1216 # proc Brow_do_UpdateParent {qlfdid}
1217 #-------------------------------------------------------------------------
1218 # fill browser parent box with qlfdid.
1219 # This function assumes that the name list is a preformatted
1220 # name list, such as that returned from a call to qlfdid.
1221 # example : a.b['q.z.w'][12].lower_bound would be in a list as:
1222 # a b ['q.z.w'] [12] lower_bound.
1223 # The Qlfdid_SplitPretty function served well for a long time,
1224 # but choked on q['a.b.c'] (being fooled by the dots in the
1225 # symbol.
1226 #-------------------------------------------------------------------------
1227 proc Brow_do_UpdateParent {name_list} {
1228 global ascBrowVect
1229
1230 set w $ascBrowVect(parents)
1231 set len [llength $name_list]
1232 if {$len == "0"} {
1233 return
1234 }
1235 $w delete 0 end
1236 for {set c 0} {$c < $len} {incr c} {
1237 $w insert end [lindex $name_list $c]
1238 }
1239 }
1240
1241 #
1242 # proc Brow_do_Export2Probe {}
1243 #------------------------------------------------------------------------
1244 # browser export 2 probe button
1245 #------------------------------------------------------------------------
1246 proc Brow_do_Export2Probe {} {# Attached to the Browser Export Menu
1247 global ascBrowVect
1248 Probe_Import_Filtered $ascBrowVect(windowname) [Brow_get_subname]
1249 }
1250
1251 #
1252 # proc Brow_do_ExportOne2Probe {}
1253 #-------------------------------------------------------------------------
1254 # Exports a single item to the current probe.
1255 # kind of a dull thing to do.
1256 #-------------------------------------------------------------------------
1257 proc Brow_do_ExportOne2Probe {} {
1258 Probe_Import current [Brow_get_subname]
1259 }
1260
1261 #
1262 # proc Brow_Export_Any_2Browser {qlfdid}
1263 #-------------------------------------------------------------------------
1264 # focus browser on qlfdid. The call to btransfer is to set
1265 # up the instance pointers. This call actually goes through
1266 # the qlfdid search *again*. This can be made more efficient.!!
1267 # One approach would be save the search list as a UserData Node
1268 # and retrieve on the next call.
1269 #-------------------------------------------------------------------------
1270 proc Brow_Export_Any_2Browser {{name ""}} {
1271 global ascBrowVect
1272 if {$name == ""} {
1273 return
1274 }
1275 set nok [catch "qlfdid \{$name\}" errmsg]
1276 if {$nok} {
1277 set msg "Unable to locate simulation $name. "
1278 append msg $errmsg
1279 Brow_Raise_Alert $msg "Export Error"
1280 return
1281 }
1282 set name_list "$errmsg"
1283 set nok [catch "btransfer \{$name\}" errmsg]
1284 if {$nok} {
1285 Brow_Raise_Alert $errmsg
1286 return
1287 }
1288 Brow_do_UpdateParent "$name_list"
1289 Brow_do_UpdateChild \
1290 $ascBrowVect(TypeorValue) \
1291 $ascBrowVect(ShowAtoms) \
1292 $ascBrowVect(HidePassed)
1293 set ascBrowVect(currentsim) [lindex $name_list 0]
1294 Brow_Setup_Selection $ascBrowVect(parents)
1295 HUB_Message_to_HUB INSTBROWSED $name
1296 if {$ascBrowVect(visibility)} {
1297 newraise .browser
1298 }
1299
1300 }
1301
1302 # proc Brow_HandleSimsDelete
1303 #------------------------------------------------------------------------
1304 # This procedure will be registered with the HUB.
1305 # If the current sim is the sim that is to be deleted then the g_instlist
1306 # for the browser will be initialized, the currentsim (all this in C-land)
1307 # will be set to NULL. The BrowserParents and ChildBox will be returned
1308 # to a clean state. This will prepare the system for the deletion of a
1309 # simulation
1310 #------------------------------------------------------------------------
1311 proc Brow_HandleSimsDelete {sims} {
1312 global ascBrowVect
1313 if {[sims getcurrent] != $sims} {
1314 return 0;
1315 }
1316 Brow_InitBrowser;
1317 return 0;
1318 }
1319
1320 #
1321 # proc Brow_HandleInstRefined
1322 #------------------------------------------------------------------------
1323 # This procedure will be called from the HUB.
1324 # If an instance HAS been refined, this procedure will check to see
1325 # if the instance was present in the browser by checking the name
1326 # of its simulation. If it was the instance will be re-exported to the
1327 # browser. Otherwise nothing will happen.
1328 #------------------------------------------------------------------------
1329 proc Brow_HandleInstRefined {args} {
1330 if {$args == ""} {return}
1331 set inst_name [lindex $args 0]
1332 set sim_name [lindex [split $inst_name .] 0]
1333 set cur_sim [sims getcurrent]
1334 if {$cur_sim == $sim_name} {
1335 Brow_Export_Any_2Browser $inst_name
1336 return 0;
1337 }
1338 }
1339
1340 #
1341 # proc Brow_HandleInstMerged
1342 #------------------------------------------------------------------------
1343 # This procedure will be called from the HUB.
1344 # If an instance HAS been merged, this should hanlde the re-exporting to
1345 # the browser. The same process as Brow_HandleInstRefined is used...
1346 # For the time being this seems sufficient.
1347 #------------------------------------------------------------------------
1348 proc Brow_HandleInstMerged {args} {
1349 Brow_HandleInstRefined {args}
1350 }
1351
1352 #
1353 # proc Brow_HandleVariableUpdated
1354 #-------------------------------------------------------------------------
1355 # This function will be called for the browser whenever a variables
1356 # values has changed. This call will be dispatched from the HUB.
1357 #-------------------------------------------------------------------------
1358 proc Brow_HandleVariableUpdated {{list ""}} {
1359 global ascBrowVect
1360 if {"[__brow_iname]" == "NULL_INSTANCE"} {
1361 return 0;
1362 }
1363 Brow_do_UpdateChild \
1364 $ascBrowVect(TypeorValue) \
1365 $ascBrowVect(ShowAtoms) \
1366 $ascBrowVect(HidePassed)
1367 return 0;
1368 }
1369
1370 #
1371 # proc Brow_HandleTypeHidden
1372 #-------------------------------------------------------------------------
1373 # This function will be called for the browser whenever a the TYPESHOW
1374 # bit of a type description has changed. This call will be dispatched
1375 # from the HUB.
1376 #-------------------------------------------------------------------------
1377 proc Brow_HandleTypeHidden {{list ""}} {
1378 global ascBrowVect
1379 if {"[__brow_iname]" == "NULL_INSTANCE"} {
1380 return 0;
1381 }
1382 Brow_do_UpdateChild \
1383 $ascBrowVect(TypeorValue) \
1384 $ascBrowVect(ShowAtoms) \
1385 $ascBrowVect(HidePassed)
1386 return 0;
1387 }
1388
1389 #
1390 # Do a series of finds to find undefined sets, integer const,
1391 # symbol const, boolean const, real const, integer const
1392 # vars,
1393 # var flags
1394 proc Brow_do_FindUndefined {{inst current}} {
1395 }
1396
1397 #
1398 # proc Brow_do_FindbyName {}
1399 #-------------------------------------------------------------------------
1400 # Find.byname buttton in the browser
1401 #-------------------------------------------------------------------------
1402 proc Brow_do_FindbyName {} {
1403 global ascMonoEntry1 ascBrowVect
1404 set pos [setpos .browser 150 70]
1405 set current_name [Brow_get_subname]
1406 set AscMonoEntry1(font) $ascBrowVect(font)
1407 set data [VShowWindow.ascMonoEntry1 "Enter Name" $pos \
1408 "$current_name" "Find by Name"]
1409 set btn [lindex $data 0]
1410 if {$btn != 1} {
1411 return
1412 }
1413 set name [lindex $data 1]
1414 if {$name == ""} {
1415 return
1416 }
1417 Brow_Export_Any_2Browser $name
1418 }
1419
1420 # proc Brow_Setup_FindBox
1421 #-------------------------------------------------------------------------
1422 # Sets up the box of found instances so that an export to the probe
1423 # may be done. There is a much more efficient way of doing these finds
1424 # which would maintain a list in C-land, rather than get instance names
1425 # and then reconvert them when exporting. For the time being this is how
1426 # it is being done. The same applies for cliques and aliases.
1427 #-------------------------------------------------------------------------
1428 proc Brow_Setup_FindBox {list {currentname ""}} {
1429 global ascListSelectB1Box ascBrowVect
1430
1431 if {![string length $currentname]} {
1432 set currentname [Brow_get_subname]
1433 }
1434 set ascListSelectB1Box(grab) 0
1435 set ascListSelectB1Box(btn2name) TagAll
1436 set ascListSelectB1Box(btn3name) Browse
1437 set ascListSelectB1Box(btn4name) Probe
1438 set ascListSelectB1Box(btn5name) ""
1439 set ascListSelectB1Box(btn2destroy) 0
1440 set ascListSelectB1Box(btn3destroy) 0
1441 set ascListSelectB1Box(btn4destroy) 0
1442 set ascListSelectB1Box(btn2command) Browser_FindSelectAll
1443 set ascListSelectB1Box(btn3command) Browser_BrowseListSelect
1444 set ascListSelectB1Box(btn4command) Browser_ProbeListSelect
1445 set ascListSelectB1Box(title) "Instances Found in [Brow_get_subname]"
1446 set ascListSelectB1Box(toplevelname) ".browfindbytype"
1447 set ascListSelectB1Box(font) $ascBrowVect(font)
1448 set ascListSelectB1Box(selectmode) extended
1449 set ascListSelectB1Box(headline) "Instances matched:"
1450
1451
1452 if {$list==""} {puts stderr "no matches found" ; return}
1453 set newlist {}
1454 set sep .
1455 switch [inst kind] {
1456 ARRAY_INT_INST -
1457 ARRAY_ENUM_INST {
1458 set sep {}
1459 }
1460 }
1461 foreach i $list {
1462 lappend newlist $currentname$sep$i
1463 }
1464 set button [AscListSelectB1Box $newlist \
1465 250x240[setpos .browser 150 20]]
1466 }
1467
1468 #proc Brow_Convert_TRUE_FALSE
1469 #-------------------------------------------------------------------------
1470 # Normalise TRUE or FALSE to their respective numeric representations.
1471 # It is cleaner to do it here rather than in C-land. The function
1472 # __brow_find_type expects 1 or 0 for boolean type values.
1473 #-------------------------------------------------------------------------
1474 proc Brow_Convert_TRUE_FALSE {value} {
1475 if {$value == "TRUE" || $value == "true"} {
1476 return 1
1477 } elseif {$value == "FALSE" || $value == "false"} {
1478 return 0
1479 } else {
1480 return $value
1481 }
1482 }
1483
1484 #
1485 # proc Brow_FindbyType {}
1486 #-------------------------------------------------------------------------
1487 # Sets up the data to make the C-call to do the
1488 # real find_by_type.
1489 #-------------------------------------------------------------------------
1490 proc Brow_FindbyType {query_list} {
1491
1492 set type [string trim [lindex $query_list 0]]
1493 set attr [string trim [lindex $query_list 1]]
1494 set lowvalue [Brow_Convert_TRUE_FALSE [string trim [lindex $query_list 2]]]
1495 set hivalue [Brow_Convert_TRUE_FALSE [string trim [lindex $query_list 3]]]
1496 if {$type == ""} {
1497 Brow_Raise_Alert "No type given,\nto find" "Find Error"
1498 return 1
1499 }
1500 if {$attr == ""} {
1501 set nok [catch {__brow_find_type cur $type} err_or_data]
1502 } elseif {$lowvalue == ""} {
1503 set nok [catch {__brow_find_type cur $type $attr} err_or_data]
1504 } elseif {$hivalue == ""} {
1505 set nok [catch {__brow_find_type cur $type $attr $lowvalue} err_or_data]
1506 } else {
1507 set nok [catch {__brow_find_type cur $type $attr $lowvalue $hivalue} \
1508 err_or_data]
1509 }
1510 if {$nok} {
1511 Brow_Raise_Alert $err_or_data
1512 return 1
1513 }
1514 if {"$err_or_data"==""} {
1515 Brow_Raise_Alert "No matches found."
1516 return 1
1517 }
1518 Brow_Setup_FindBox $err_or_data
1519 }
1520
1521 #
1522 # proc Brow_do_FindbyType {}
1523 #-------------------------------------------------------------------------
1524 # Find.bytype button in the browser
1525 #-------------------------------------------------------------------------
1526 proc Brow_do_FindbyType {} {
1527 global AscMonoEntry4 ascBrowVect
1528
1529 # The following code assumes that AscMonoEntry4.t was explicitly
1530 # sourced rather than auto-loaded. As such the AscMonoEntry4 array
1531 # exists, and can be written to. We want to stuff the box with the
1532 # last query made.
1533
1534 set pos [setpos .browser 150 70]
1535 if {$AscMonoEntry4(count) == 0} {
1536 set AscMonoEntry4(resultNW) solver_var
1537 set AscMonoEntry4(resultNE) fixed
1538 set AscMonoEntry4(resultSW) TRUE
1539 set AscMonoEntry4(resultSE) ""
1540 }
1541 incr AscMonoEntry4(count)
1542 set AscMonoEntry4(font) $ascBrowVect(font)
1543 set data [VShowWindow.ascMonoEntry4 "Find by Type" $pos \
1544 "Type" "Attribute" "Low Value" "High Value" \
1545 $AscMonoEntry4(resultNW) $AscMonoEntry4(resultNE) \
1546 $AscMonoEntry4(resultSW) $AscMonoEntry4(resultSE)]
1547 set btn [lindex $data 0]
1548 if {$btn == "1"} {
1549 set query_list [lrange $data 1 4]
1550 set res [Brow_FindbyType $query_list]
1551 }
1552 if {$btn =="3"} {Help_button browser find.bytype}
1553 }
1554
1555 #
1556 # proc Brow_RelationType{}
1557 #-------------------------------------------------------------------------
1558 # Find.bytype button in the browser
1559 #-------------------------------------------------------------------------
1560 proc Brow_RelationType {relinst} {
1561
1562 qlfdid $inst
1563 set nok [catch {qlfdid $name} err_msg]
1564 if {$nok} {
1565 puts "$err_msg"
1566 return -2
1567 }
1568 set nok [catch {__brow_reln_relopsearch} err_msg]
1569 return $err_msg
1570 }
1571
1572
1573 #
1574 # proc Brow_RelationSatisfied {}
1575 #-------------------------------------------------------------------------
1576 #-------------------------------------------------------------------------
1577 proc Brow_do_RelationSatisfied {} {
1578 error "Brow_do_RelationSatisfied not implemented"
1579 }
1580
1581
1582 #
1583 # proc Browser_FindSelectAll {{tl ""}}
1584 #-------------------------------------------------------------------------
1585 # select all in the asclistselectb1box associate with tl, or
1586 # select all in the last asclistselectb1box created if tl == ""
1587 #-------------------------------------------------------------------------
1588 proc Browser_FindSelectAll {{tl ""}} {
1589 AscListSelectB1SelectAll "$tl"
1590 }
1591
1592 #
1593 # proc Browser_BrowseListSelect {}
1594 #-------------------------------------------------------------------------
1595 # send first of any aliases selected/clique to the browser
1596 #-------------------------------------------------------------------------
1597 proc Browser_BrowseListSelect {} {
1598 global ascListSelectB1Box
1599 set list $ascListSelectB1Box(itemselected)
1600 if {$list != ""} {
1601 set item [lindex $list 0]
1602 Brow_Export_Any_2Browser $item
1603 }
1604 }
1605 #
1606 # proc Browser_ProbeListSelect {}
1607 #-------------------------------------------------------------------------
1608 # send any aliases/clique selected to the probe as single items
1609 #-------------------------------------------------------------------------
1610 proc Browser_ProbeListSelect {} {
1611 global ascListSelectB1Box
1612 set list $ascListSelectB1Box(itemselected)
1613 Probe_Import_List current $list
1614 }
1615
1616 #
1617 # proc Brow_do_FindAliases {}
1618 #-------------------------------------------------------------------------
1619 # Find.aliases button in the browser
1620 #-------------------------------------------------------------------------
1621 proc Brow_do_FindAliases {} {
1622 global ascListSelectB1Box ascBrowVect
1623 set list ""
1624 catch {set list [aliases current]}
1625
1626 set ascListSelectB1Box(grab) 0
1627 set ascListSelectB1Box(btn2name) Browse
1628 set ascListSelectB1Box(btn3name) Probe
1629 set ascListSelectB1Box(btn4name) ""
1630 set ascListSelectB1Box(btn5name) ""
1631 set ascListSelectB1Box(btn2destroy) 0
1632 set ascListSelectB1Box(btn3destroy) 0
1633 set ascListSelectB1Box(btn4destroy) 0
1634 set ascListSelectB1Box(btn5destroy) 0
1635 set ascListSelectB1Box(btn2command) Browser_BrowseListSelect
1636 set ascListSelectB1Box(btn3command) Browser_ProbeListSelect
1637 set ascListSelectB1Box(title) "Aliases for [Brow_get_subname]"
1638 set ascListSelectB1Box(toplevelname) ".browaliases"
1639 set ascListSelectB1Box(font) $ascBrowVect(font)
1640 set ascListSelectB1Box(selectmode) extended
1641 set ascListSelectB1Box(headline) "ARE_THE_SAME instances:"
1642
1643
1644 if {$list==""} {puts stderr "no aliases" ; return}
1645 set button [AscListSelectB1Box $list \
1646 250x240[setpos .browser 150 20]]
1647 }
1648
1649 #
1650 # proc Brow_do_FindISAs {}
1651 #-------------------------------------------------------------------------
1652 # Where.created button in the browser
1653 #-------------------------------------------------------------------------
1654 proc Brow_do_FindISAs {} {
1655 global ascListSelectB1Box ascBrowVect
1656 set list ""
1657 catch {set list [isas current]}
1658
1659 set ascListSelectB1Box(grab) 0
1660 set ascListSelectB1Box(btn2name) Browse
1661 set ascListSelectB1Box(btn3name) Probe
1662 set ascListSelectB1Box(btn4name) ""
1663 set ascListSelectB1Box(btn5name) ""
1664 set ascListSelectB1Box(btn2destroy) 0
1665 set ascListSelectB1Box(btn3destroy) 0
1666 set ascListSelectB1Box(btn4destroy) 0
1667 set ascListSelectB1Box(btn5destroy) 0
1668 set ascListSelectB1Box(btn2command) Browser_BrowseListSelect
1669 set ascListSelectB1Box(btn3command) Browser_ProbeListSelect
1670 set ascListSelectB1Box(title) "[Brow_get_subname] created as"
1671 set ascListSelectB1Box(toplevelname) ".browisas"
1672 set ascListSelectB1Box(font) $ascBrowVect(font)
1673 set ascListSelectB1Box(selectmode) extended
1674 set ascListSelectB1Box(headline) "Constructed instances:"
1675
1676
1677 if {$list==""} {puts stderr "no isas, which is very odd!" ; return}
1678 set button [AscListSelectB1Box $list \
1679 250x240[setpos .browser 150 20]]
1680 }
1681 #
1682 # proc Brow_do_FindClique {}
1683 #-------------------------------------------------------------------------
1684 # Find.clique button in the browser
1685 #-------------------------------------------------------------------------
1686 proc Brow_do_FindClique {} {
1687 global ascListSelectB1Box ascBrowVect
1688 set list ""
1689 catch {set list [cliques]}
1690
1691 set ascListSelectB1Box(grab) 0
1692 set ascListSelectB1Box(btn2name) TagAll
1693 set ascListSelectB1Box(btn3name) Browse
1694 set ascListSelectB1Box(btn4name) Probe
1695 set ascListSelectB1Box(btn5name) ""
1696 set ascListSelectB1Box(btn2destroy) 0
1697 set ascListSelectB1Box(btn3destroy) 0
1698 set ascListSelectB1Box(btn4destroy) 0
1699 set ascListSelectB1Box(btn2command) Browser_FindSelectAll
1700 set ascListSelectB1Box(btn3command) Browser_BrowseListSelect
1701 set ascListSelectB1Box(btn4command) Browser_ProbeListSelect
1702 set ascListSelectB1Box(title) "Clique of [Brow_get_subname]"
1703 set ascListSelectB1Box(toplevelname) ".browclique"
1704 set ascListSelectB1Box(font) $ascBrowVect(font)
1705 set ascListSelectB1Box(selectmode) extended
1706 set ascListSelectB1Box(headline) "ARE_ALIKE instances:"
1707
1708
1709 if {$list==""} {puts stderr "no clique!" ; return}
1710 set button [AscListSelectB1Box $list \
1711 250x240[setpos .browser 150 20]]
1712 }
1713 #
1714 # proc Brow_do_FindFixed {fixed}
1715 #-------------------------------------------------------------------------
1716 # Find free/fixed variables button in the browser popup
1717 #-------------------------------------------------------------------------
1718 proc Brow_do_FindFixed {fixed} {
1719 global ascListSelectBox ascSolvVect ascBrowVect
1720
1721 switch $fixed {
1722 TRUE {
1723 Brow_FindbyType {real fixed 1}
1724 }
1725 FALSE -
1726 default {
1727 Brow_FindbyType {real fixed 0}
1728 }
1729 }
1730 }
1731 #
1732 # proc Brow_do_FindEligible {}
1733 #-------------------------------------------------------------------------
1734 # Find.eligible variables button in the browser
1735 #-------------------------------------------------------------------------
1736 proc Brow_do_FindEligible {} {
1737 global ascListSelectBox ascSolvVect ascBrowVect
1738
1739 set list {}
1740 set prefix "[Brow_get_subname]"
1741 if {[slv_checksys] && 0 == \
1742 [string compare [sims getc] [lindex [split [slv_get_pathname] .] 0]]} {
1743 set list [__brow_find_type cur solver_var message eligible]
1744 set ascListSelectBox(title) "Eligible in Solver"
1745 } else {
1746 set list ""
1747 set refresh 0
1748 catch {set list [lindex [brow_find_eligible 2] 0]}
1749 set ascListSelectBox(title) "Eligible in [Brow_get_subname]"
1750 }
1751
1752 set ascListSelectBox(grab) 1
1753 set ascListSelectBox(btn3name) ""
1754 set ascListSelectBox(btn4name) ""
1755 set ascListSelectBox(btn5name) ""
1756 set ascListSelectBox(toplevelname) ".broweligible"
1757 set ascListSelectBox(font) $ascBrowVect(font)
1758 set ascListSelectBox(selectmode) browse
1759 set ascListSelectBox(headline) "Select to fix one of:"
1760 set newlist ""
1761
1762 foreach i $list {
1763 lappend newlist $prefix.$i
1764 }
1765 if {$newlist==""} {
1766 puts stderr "No variables eligible to be fixed."
1767 Brow_Raise_Alert "No variables eligible\n to be fixed." "DOF analysis"
1768 return
1769 }
1770 set alist [lsort $newlist]
1771 set button [AscListSelectBox $newlist \
1772 250x240[setpos .browser 50 20]]
1773 if {$button==2} {return}
1774 Solve_EligListSelect 0 ;# what is this doing here?
1775 }
1776
1777 #
1778 # proc Brow_do_FindActiveRels {}
1779 #-------------------------------------------------------------------------
1780 # Find.active rels button in the browser
1781 #-------------------------------------------------------------------------
1782 proc Brow_do_FindActiveRels {} {
1783 entertrace
1784 global ascListSelectB1Box ascSolvVect ascBrowVect
1785
1786 set list {}
1787 set prefix "[Brow_get_subname]"
1788 if {[slv_checksys] && 0 == \
1789 [string compare [sims getc] [lindex [split [slv_get_pathname] .] 0]]} {
1790 set list [__brow_find_type cur relation message active]
1791 set ascListSelectB1Box(title) "Active Relations in Solver"
1792 } else {
1793 set list ""
1794 set refresh 0
1795 catch {set list [lindex [brow_find_activerels 2] 0]}
1796 set ascListSelectB!Box(title) "Active Relations in [Brow_get_subname]"
1797 }
1798
1799 set ascListSelectB1Box(grab) 0
1800 set ascListSelectB1Box(btn2name) TagAll
1801 set ascListSelectB1Box(btn3name) Browse
1802 set ascListSelectB1Box(btn4name) Probe
1803 set ascListSelectB1Box(btn5name) ""
1804 set ascListSelectB1Box(btn2destroy) 0
1805 set ascListSelectB1Box(btn3destroy) 0
1806 set ascListSelectB1Box(btn4destroy) 0
1807 set ascListSelectB1Box(btn2command) Browser_FindSelectAll
1808 set ascListSelectB1Box(btn3command) Browser_BrowseListSelect
1809 set ascListSelectB1Box(btn4command) Browser_ProbeListSelect
1810 set ascListSelectB1Box(title) "Active Relations of [Brow_get_subname]"
1811 set ascListSelectB1Box(toplevelname) ".browactive"
1812 set ascListSelectB1Box(font) $ascBrowVect(font)
1813 set ascListSelectB1Box(selectmode) extended
1814 set ascListSelectB1Box(headline) "Active Relations:"
1815
1816 foreach i $list {
1817 lappend newlist $prefix.$i
1818 }
1819 if {$newlist==""} {
1820 puts stderr "No active relations."
1821 Brow_Raise_Alert "No Active Relation\n" "Solver Configuration"
1822 return
1823 }
1824 set alist [lsort $newlist]
1825 set button [AscListSelectB1Box $newlist \
1826 250x240[setpos .browser 150 20]]
1827 return
1828 leavetrace
1829 }
1830
1831 #
1832 # proc Brow_do_FindRels {}
1833 #-------------------------------------------------------------------------
1834 # Find.relations button in the browser
1835 #-------------------------------------------------------------------------
1836 proc Brow_do_FindRels {} {
1837 puts stdout "Finding relations not implemented"
1838 }
1839 #
1840 # proc Brow_do_FindOpers {}
1841 #-------------------------------------------------------------------------
1842 # Find.operands button in the browser
1843 #-------------------------------------------------------------------------
1844 proc Brow_do_FindOpers {} {
1845 set list [inst operands -current]
1846 set root "[Brow_get_partname]"
1847 if {[llength $list]} {
1848 Brow_Setup_FindBox $list $root
1849 } else {
1850 Brow_Raise_Alert "No operands found in [Brow_get_subname]" \
1851 "Operands message"
1852 }
1853 }
1854 #
1855 # proc Brow_do_FindParents {}
1856 #-------------------------------------------------------------------------
1857 # Find.parents button in the browser
1858 #-------------------------------------------------------------------------
1859 proc Brow_do_FindParents {} {
1860 puts stdout "Finding parents not implemented"
1861 }
1862 #
1863 # proc Brow_do_FindPendings {}
1864 #-------------------------------------------------------------------------
1865 # Find.pendings button in the browser
1866 #-------------------------------------------------------------------------
1867 proc Brow_do_FindPendings {} {
1868 if {[bnumpendings instance current] > 0} {
1869 puts "\n--------------------------------------------------------------\n\
1870 Pendings statements for the instance\n"
1871 bwritependings [sims getcurrentsim]
1872 puts "\n--------------------------------------------------------------"
1873 return;
1874 } else {
1875 puts "\n--------------------------------------------------------------\n"
1876 puts "No pendings statements for the browser instance\n"
1877 }
1878 }
1879
1880 #
1881 # proc Qlfdid_SplitPretty {qlfdid}
1882 #-------------------------------------------------------------------------
1883 # parse qlfdid: .->spc [ -> spc[
1884 #-------------------------------------------------------------------------
1885 proc Qlfdid_SplitPretty {name} {
1886 set b $name
1887 regsub -all {\.} $b " " b;
1888 regsub -all {\[} $b " \[" b;
1889 regsub -all {\]} $b "\]" b;
1890 return $b;
1891 }
1892
1893 #
1894 # Brow_Setup_Selection {listbox {startpos "end"} {endpos "end"}}
1895 #-------------------------------------------------------------------------
1896 # clear present list selection and select from startpos to endpos
1897 #-------------------------------------------------------------------------
1898 proc Brow_Setup_Selection {listbox {startpos "end"} {endpos "end"}} {
1899
1900 $listbox selection clear 0 end
1901 $listbox selection set $startpos $endpos
1902 }
1903
1904 #
1905 # proc Browser_ProcShowCode
1906 #-------------------------------------------------------------------------
1907 # show procedure code for each procedure in $ascListSelectBox(itemselected)
1908 # assuming each item is an proc of the current instance.
1909 #-------------------------------------------------------------------------
1910 proc Browser_ProcShowCode {currentname} {
1911 global ascListSelectBox ascUtilVect ascDispVect
1912 if {$ascListSelectBox(itemselected)==""} {return}
1913
1914 DispClear;
1915 qlfdid $currentname
1916 foreach i $ascListSelectBox(itemselected) {
1917 set outputfile [FileUniqueName "$ascUtilVect(asctmp)/ascdisproc"]
1918 bgetproc $i $outputfile search
1919 set f [open $outputfile]
1920 # read chunks of 10k
1921 while {![eof $f]} {
1922 $ascDispVect(textBox) insert end [read $f 10000]
1923 }
1924 close $f
1925 file delete $outputfile
1926 }
1927 DispSetEntry "Method code from $currentname"
1928 newraise .display
1929 }
1930
1931 #
1932 # proc Browser_do_Methods {}
1933 #-------------------------------------------------------------------------
1934 # browser Edit.RunMethods button
1935 #-------------------------------------------------------------------------
1936 proc Browser_do_Methods {} {
1937 global ascBrowVect
1938 global ascListSelectBox
1939 global ascLibrVect
1940
1941 set currentname [Brow_get_subname]
1942 set ascListSelectBox(grab) 0
1943 set ascListSelectBox(btn3name) Show
1944 set ascListSelectBox(btn4name) ""
1945 set ascListSelectBox(btn5name) ""
1946 set ascListSelectBox(btn3destroy) 0
1947 set ascListSelectBox(btn3command) "Browser_ProcShowCode $currentname"
1948 set ascListSelectBox(headline) "Methods ($currentname):"
1949 set ascListSelectBox(toplevelname) ".browprocedures"
1950 set ascListSelectBox(font) $ascBrowVect(font)
1951 set ascListSelectBox(selectmode) extended
1952 set ascListSelectBox(title) "Select Method"
1953
1954 set typename [inst type]
1955 set proc_list {}
1956 if {[catch {set proc_list [libr_query -methods -type $typename]} err]} {
1957 return;
1958 }
1959 if {$proc_list=="1" && [llength [libr_query -basemethods]] == 0} {
1960 return
1961 }
1962 foreach i [libr_query -basemethods] {
1963 if {[lsearch -exact $proc_list $i] == -1} {
1964 lappend proc_list $i
1965 }
1966 }
1967 set button [AscListSelectBox [lsort -dictionary $proc_list] \
1968 250x240[setpos .browser 50 50]]
1969 if {$button==2} {return}
1970 set Proc_list $ascListSelectBox(itemselected)
1971 if {$Proc_list != "" } {
1972 foreach Proc $Proc_list {
1973 if {[string length $Proc]==0} {
1974 continue
1975 }
1976 set nok [catch {
1977 brow_runmethod -method $Proc \
1978 -qlfdid $currentname \
1979 -backtrace $ascLibrVect(btuifstop) \
1980 -stopOnErr $ascLibrVect(ignorestop)
1981 } err]
1982 puts -nonewline "Running method $Proc in "
1983 puts $currentname
1984 if {$nok} {
1985 Brow_Raise_Alert $err" "Method Error"
1986 return 1
1987 }
1988 HUB_Message_to_HUB PROCRUN $currentname.$Proc
1989 }
1990 Brow_do_UpdateChild \
1991 $ascBrowVect(TypeorValue) \
1992 $ascBrowVect(ShowAtoms) \
1993 $ascBrowVect(HidePassed)
1994 HUB_Message_to_HUB VARIABLEUPDATED [sims getc]
1995 HUB_Message_to_HUB WHENVARUPDATED [sims getc]
1996 #
1997 # This is not required anymore. Its consequences are now a part
1998 # of the consequences of WHENVARUPDATED.
1999 # (wish this were TRUE: baa 6/11/97
2000 HUB_Message_to_HUB BOOLEANUPDATED [sims getc]
2001 #
2002 return 0;
2003 }
2004 Brow_Raise_Alert "No method was selected" "Intialization Error"
2005 return 1;
2006 }
2007
2008 #
2009 # proc Browser_do_ClearVars {}
2010 #-------------------------------------------------------------------------
2011 # browser Edit.ClearVars button
2012 #-------------------------------------------------------------------------
2013 proc Browser_do_ClearVars {} {
2014 Solve_do_Flush do_not_record
2015 free_all_vars
2016 HUB_Message_to_HUB CLEARVARS [Brow_get_subname]
2017 }
2018
2019 #
2020 # proc Browser_do_SetValue {{toplevel self} {instname ""}}
2021 #-------------------------------------------------------------------------
2022 # browser Edit.setvalue button
2023 # if a name is supplied, sets that value instead of current instance
2024 #-------------------------------------------------------------------------
2025 proc Browser_do_SetValue {{toplevel self} {instname ""}} {
2026 global ascBrowVect
2027 global AscEntryBox2
2028
2029 if {[string compare $toplevel "self"]==0} {
2030 set toplevel $ascBrowVect(windowname)
2031 }
2032 if {$instname == ""} {
2033 set instname [Brow_get_subname]
2034 }
2035 if {[catch {qlfdid $instname} errmsg]} {
2036 append msg "Browser_do_SetValue unable to find" $instname
2037 error $msg "This isn't a bug-- it's a user mistake"
2038 }
2039 if {![inst isassignable search]} {
2040 return
2041 }
2042
2043 if {[catch {set cur_value [u_browgetval search]} err]} {
2044 set cur_value [inst atomvalue search]
2045 set cur_units "\*"
2046 } else {
2047 set cur_value [stripbraces $cur_value]
2048 set cur_units [lindex [split $cur_value] 1]
2049 set cur_value [lindex $cur_value 0]
2050 }
2051 set pos [setpos $toplevel 65 65]
2052 set title {}
2053 append title $instname
2054 switch [inst kind search] {
2055 SYMBOL_INST -
2056 SYMBOL_ATOM_INST -
2057 SYMBOL_CONSTANT_INST {
2058 append title "\nValue / Units\n (do not include ' around value)"
2059 }
2060 default {
2061 append title "\nValue / Units"
2062 }
2063 }
2064 set data [VShowWindow.ascMonoEntry2 $title $pos $cur_value $cur_units]
2065 set btn [lindex $data 0]
2066 if {$btn == 1 && ( \
2067 [string compare $cur_value [lindex $data 1]] !=0 || \
2068 [string compare $cur_units [lindex $data 2]] !=0) } {
2069 set value [lindex $data 1]
2070 set units [lindex $data 2]
2071 brow_assign -search $value $units
2072 HUB_Message_to_HUB VALUESET $instname $value $units
2073 Brow_do_UpdateChild \
2074 $ascBrowVect(TypeorValue) \
2075 $ascBrowVect(ShowAtoms) \
2076 $ascBrowVect(HidePassed)
2077 # Brow_do_UpdateChild (in local Core update) moves qlfdid.
2078 qlfdid $instname
2079 if {[inst iswhenvar search]} {
2080 HUB_Message_to_HUB WHENVARUPDATED $instname
2081 #
2082 # solver needs to know about potential changes of configuration
2083 #
2084 } else {
2085 if {[inst kind search]=="BOOLEAN_INST" || \
2086 [inst kind search]=="BOOLEAN_ATOM_INST"} {
2087 HUB_Message_to_HUB BOOLEANUPDATED $instname
2088 #
2089 # solver needs to know about potential dof changes
2090 #
2091 } else {
2092 HUB_Message_to_HUB VARIABLEUPDATED $instname
2093 }
2094 }
2095 }
2096 }
2097 #
2098 proc Brow_InitSetvalue {} {
2099 global ascSetvalueVect ascBrowVect
2100 set ascSetvalueVect(basenamelist) [list rootname]
2101 set ascSetvalueVect(namelist) [list rootname]
2102 set ascSetvalueVect(rootname) ""
2103 set ascSetvalueVect(rootname.label) "Assigning in:"
2104 set ascSetvalueVect(rootname.type) string
2105
2106 set ascSetvalueVect(grab) 1
2107 set ascSetvalueVect(cancellable) 1
2108 set ascSetvalueVect(npages) 1
2109 set ascSetvalueVect(toplevel) .setvalue
2110 set ascSetvalueVect(titlebase) "Set instance values: "
2111 set ascSetvalueVect(helpcommand) {Help_button browser.set.values}
2112 set ascSetvalueVect(whenokcommand) Brow_CheckSetvaluesInput
2113
2114 set ascParPageVect(btn_font) $ascBrowVect(font)
2115 set ascParPageVect(lbl_font) $ascBrowVect(font)
2116 }
2117
2118 #
2119 # proc Brow_CheckSetvaluesInput {}
2120 #------------------------------------------------------------------------
2121 # Checks the string entries in a for not containing ' characters.
2122 # checks ${c}__uni_ string entries in a for being legal units.
2123 #------------------------------------------------------------------------
2124 proc Brow_CheckSetvaluesInput {} {
2125 # this shouldn't be necessary, ASSIGN should be robust to bad input
2126 # and we should catch around ASSIGN.
2127 }
2128
2129 #
2130 # proc Brow_SetvalueConfigure {name}
2131 #------------------------------------------------------------------------
2132 # Sets up the namelist in ascSetvalueVect based on name.
2133 # Do not call this with a bad instance name.
2134 # On return, ascSetvalueVect(vallist) is the list of leaf names of
2135 # parts in instance $name which were offered to the user for assignment.
2136 # Does not unroll arrays.
2137 # If a part named foo in vallist is of type 'real' then there will also be
2138 # an element foo__uni_ of type 'string'
2139 # there may be other elements in ascSetvalueVect, but they are irrelevant
2140 # if not in vallist.
2141 #------------------------------------------------------------------------
2142 proc Brow_SetvalueConfigure {name} {
2143 global ascSetvalueVect
2144
2145 set ascSetvalueVect(namelist) $ascSetvalueVect(basenamelist)
2146 set ascSetvalueVect(entrywidth) 20
2147 set ascSetvalueVect(rootname) $name
2148 set ascSetvalueVect(rootname.choices) $ascSetvalueVect(rootname)
2149 set ascSetvalueVect(title) $ascSetvalueVect(titlebase)
2150 append ascSetvalueVect(title) $ascSetvalueVect(rootname)
2151 # if name is assignable (atomic & !relation), create rootvalue
2152 # entry based on type.
2153 # get childlist of name, find assignables and their types,
2154 # build name list, including a units entry for reals
2155 qlfdid $name ;# set g_search_inst in C land
2156 set clist [inst child search] ;# want the full list, not just viewables
2157 set ascSetvalueVect(vallist) ""
2158 set counter 0
2159 set page 1
2160 foreach c $clist {
2161 incr counter
2162 if {$page * 10 < $counter} { incr page }
2163 set cname [Brow_childname $name $c]
2164 if {[catch {qlfdid $cname} errmsg] || ![inst isassignable search]} {
2165 continue ;# skip NULL children and unassignables
2166 }
2167 lappend ascSetvalueVect(namelist) $c
2168 lappend ascSetvalueVect(vallist) $c
2169 set ascSetvalueVect($c.label) $c
2170 set ascSetvalueVect($c.page) $page
2171 set tmplen 0
2172 catch {set tmplen [string length [inst atomvalue search]]}
2173 if {$tmplen && $tmplen < 40 && $tmplen > $ascSetvalueVect(entrywidth)} {
2174 set ascSetvalueVect(entrywidth) $tmplen
2175 }
2176 switch [inst kind search] {
2177 REAL_INST -
2178 REAL_ATOM_INST -
2179 REAL_CONSTANT_INST {
2180 set cur_value ""
2181 set cur_units ""
2182 if {[catch {set cur_value [u_browgetval search]} \
2183 err]} {
2184 set cur_value [inst atomvalue search]
2185 set cur_units "\*"
2186 } else {
2187 set cur_value [lindex $cur_value 0]
2188 set cur_units [lindex [split $cur_value] 1]
2189 set cur_value [lindex $cur_value 0]
2190 }
2191 set ascSetvalueVect($c) $cur_value
2192 set ascSetvalueVect($c.type) real
2193 set ascSetvalueVect($c.old) $cur_value
2194 lappend ascSetvalueVect(namelist) ${c}__uni_
2195 set tmplen 0
2196 catch {set tmplen [string length $cur_units]}
2197 if {$tmplen < 40 && \
2198 $tmplen > $ascSetvalueVect(entrywidth)} {
2199 set ascSetvalueVect(entrywidth) $tmplen
2200 }
2201 set ascSetvalueVect(${c}__uni_) $cur_units
2202 set ascSetvalueVect(${c}__uni_.type) string
2203 set ascSetvalueVect(${c}__uni_.page) $page
2204 set ascSetvalueVect(${c}__uni_.old) $cur_units
2205 set ascSetvalueVect(${c}__uni_.label) "Units for "
2206 append ascSetvalueVect(${c}__uni_.label) $c
2207 }
2208 INTEGER_INST -
2209 INTEGER_ATOM_INST -
2210 INTEGER_CONSTANT_INST {
2211 set ascSetvalueVect($c) [inst atomvalue search]
2212 set ascSetvalueVect($c.old) $ascSetvalueVect($c)
2213 set ascSetvalueVect($c.type) int
2214 }
2215 BOOLEAN_INST -
2216 BOOLEAN_ATOM_INST -
2217 BOOLEAN_CONSTANT_INST {
2218 set ascSetvalueVect($c) [inst atomvalue search]
2219 switch $ascSetvalueVect($c) {
2220 FALSE {
2221 set ascSetvalueVect($c) 0
2222 set ascSetvalueVect($c.old) 0
2223 set ascSetvalueVect($c.type) bool
2224 }
2225 TRUE {
2226 set ascSetvalueVect($c) 1
2227 set ascSetvalueVect($c.old) 1
2228 set ascSetvalueVect($c.type) bool
2229 }
2230 UNDEFINED {
2231 set ascSetvalueVect($c) UNDEFINED
2232 set ascSetvalueVect($c.old) UNDEFINED
2233 set ascSetvalueVect($c.type) bool
2234 }
2235 default {
2236 error \
2237 "Brow_SetvalueConfigure bool confused"
2238 }
2239 }; # END inner switch
2240 }
2241 SYMBOL_INST -
2242 SYMBOL_ATOM_INST -
2243 SYMBOL_CONSTANT_INST {
2244 set ascSetvalueVect($c) [inst atomvalue search]
2245 set ascSetvalueVect($c.old) $ascSetvalueVect($c)
2246 set ascSetvalueVect($c.type) string
2247 }
2248 SET_ATOM_INST -
2249 SET_INST {
2250 # do nothing with sets yet; # too complicated
2251 }
2252 default {
2253 # above should be a complete listing of our assignable kinds.
2254 error \
2255 "Brow_SetvalueConfigure can't cope with [inst kind search]"
2256 }
2257 }
2258 }
2259 set ascSetvalueVect(npages) $page
2260 }
2261
2262 #
2263 # proc Brow_childname {root leaf}
2264 #------------------------------------------------------------------------
2265 # Figures out how to add leaf to root and returns the combination.
2266 # Basically, this centralizes the checks for gluing array elements
2267 # to root names in qualified id production.
2268 #------------------------------------------------------------------------
2269 proc Brow_childname {root leaf} {
2270 if {$leaf == ""} {return $root}
2271 if { [string index $leaf 0] != "\["} {
2272 append root .$leaf
2273 } else {
2274 append root $leaf
2275 }
2276 return $root
2277 }
2278
2279 #
2280 # proc Browser_SetvalueBox {caller name}
2281 #------------------------------------------------------------------------
2282 # Caller is the name of the toplevel window calling this function.
2283 # Set values dialog for assignable children of name.
2284 # $name may point to any sort of instance that has assignable children.
2285 # If nothing to do, returns silently.
2286 # name is a full qualified identifier.
2287 # Uses the ASSIGN operator because we can't cope with the
2288 # hub event generation here without creating an impenetrable mess.
2289 #------------------------------------------------------------------------
2290 proc Browser_SetvalueBox {caller name} {
2291 global ascProbVect
2292 global ascSetvalueVect
2293
2294 Brow_SetvalueConfigure $name
2295 if {$ascSetvalueVect(vallist) == ""} {
2296 return; # don't call parpage as it may barf on empty.
2297 }
2298 ascParPage ascSetvalueVect [setpos $caller 0 0] 1 0
2299 if {$ascSetvalueVect(__,cancelled)} {return}
2300 foreach i $ascSetvalueVect(vallist) {
2301 switch $ascSetvalueVect($i.type) {
2302 real {
2303 if {$ascSetvalueVect($i) == "UNDEFINED"} {continue}
2304 if {$ascSetvalueVect($i.old) != $ascSetvalueVect($i) || \
2305 $ascSetvalueVect(${i}__uni_.old) != \
2306 $ascSetvalueVect(${i}__uni_)} {
2307 puts $i
2308 if {$i != "__atom_value__"} {
2309 if {[catch {ASSIGN [Brow_childname $name $i] \
2310 $ascSetvalueVect($i) $ascSetvalueVect(${i}__uni_)
2311 } errmsg]} {
2312 append errmsg ": " $i " " $ascSetvalueVect($i) " "
2313 append errmsg $ascSetvalueVect(${i}__uni_)
2314 puts $errmsg
2315 }
2316 } else {
2317 if {[catch {ASSIGN $name $ascSetvalueVect($i) \
2318 $ascSetvalueVect(${i}__uni_)
2319 } errmsg]} {
2320 append errmsg ": " $name " " $ascSetvalueVect($i) " "
2321 append errmsg $ascSetvalueVect(${i}__uni_)
2322 puts $errmsg
2323 }
2324 }
2325 }
2326 }
2327 int -
2328 bool -
2329 string {
2330 if {$ascSetvalueVect($i) == "UNDEFINED"} {continue}
2331 if {$ascSetvalueVect($i.old) != $ascSetvalueVect($i)} {
2332 if {$i != "__atom_value__"} {
2333 if {[catch {ASSIGN [Brow_childname $name $i] \
2334 $ascSetvalueVect($i)} errmsg]} {
2335 append errmsg ": " $i " " $ascSetvalueVect($i) " "
2336 append errmsg $ascSetvalueVect(${i}__uni_)
2337 puts $errmsg
2338 }
2339 } else {
2340 if {[catch {ASSIGN $name $ascSetvalueVect($i)} errmsg]} {
2341 append errmsg ": " $name " " $ascSetvalueVect($i) " "
2342 append errmsg $ascSetvalueVect(${i}__uni_)
2343 puts $errmsg
2344 }
2345 }
2346 }
2347 }
2348 default {
2349 error "binary data type in Brow_SetvalueBox???"
2350 }
2351 }
2352 }
2353 }
2354
2355 #===========================================
2356 #
2357 # proc Brow_do_Read {}
2358 #-------------------------------------------------------------------------
2359 # Read values back into an instance.
2360 # instance should have at least the namespace of the instance which was used
2361 # when writing the read file.
2362 # Instance doesn't have to be in the browser.
2363 #-------------------------------------------------------------------------
2364 proc Brow_do_Read {} {
2365 global ascBrowVect
2366 set defaultname [file dirname $ascBrowVect(filename)]
2367 set filename [tk_getOpenFile \
2368 -defaultextension "" \
2369 -filetypes $ascBrowVect(filetypes) \
2370 -initialdir $defaultname \
2371 -parent .browser \
2372 -title {Read saved values file}]
2373
2374 if {$filename == "" || [file isdirectory $filename]} {
2375 return 1;
2376 } else {
2377 puts "Reading values from $filename"
2378 if {[catch {Brow_parse_values $filename 0} err]} {
2379 puts "Problem reading values file:"
2380 puts "error>>>$err<<<"
2381 }
2382 set ascBrowVect(filename) $filename
2383 set newext "[file extension $filename]"
2384 if {$newext != ""} {
2385 set ascBrowVect(lastreadextension) $newext
2386 ascresort_filetypes ascBrowVect lastreadextension
2387 }
2388
2389 update idletasks
2390 }
2391 # here we should be grabbing the first line of filename, taking its
2392 #second to last item, and issuing the updated calls with that sim name.
2393 HUB_Message_to_HUB VARIABLEUPDATED
2394 HUB_Message_to_HUB BOOLEANUPDATED
2395 HUB_Message_to_HUB DATAREAD $filename
2396 }
2397
2398 proc Brow_do_SaveOptions {} {
2399 View_Save_Window_Options browser
2400 }
2401 #
2402 # proc Brow_do_Write {}
2403 #-------------------------------------------------------------------------
2404 # write real and boolean values from current instance downward to file.
2405 # not particularly picky about what ARE_THE_SAMEd parts get called.
2406 # The prefix that is used at the moment is : "qassgn3 \{".
2407 # "qassgn3" is the fastest version of the reading code.
2408 # The dummy_name is a requirement of teh bwritevalues command.
2409 #-------------------------------------------------------------------------
2410 proc Brow_do_Write {} {
2411 global ascBrowVect
2412
2413 set defaultname $ascBrowVect(filename)
2414 set filename [tk_getSaveFile \
2415 -defaultextension "" \
2416 -filetypes $ascBrowVect(filetypes) \
2417 -initialfile $defaultname \
2418 -parent .browser \
2419 -title {Save variable values}]
2420
2421 if {$filename == ""} {
2422 return 1;
2423 } {
2424 set ascBrowVect(filename) $filename
2425 bwritevalues $filename "qassgn3 \{" current "dummy_name" #fast
2426 puts "Wrote values file $filename."
2427 }
2428 HUB_Message_to_HUB DATAWRITE [Brow_get_subname] $filename
2429 }
2430
2431 #
2432 # proc Browser_RefineShowCode {}
2433 #-------------------------------------------------------------------------
2434 # display code of type (found in ascListSelectBox) in the display window
2435 #-------------------------------------------------------------------------
2436 proc Browser_RefineShowCode {} {
2437 global ascListSelectBox ascUtilVect ascDispVect
2438
2439 if {$ascListSelectBox(itemselected)==""} {return}
2440 set type [lindex $ascListSelectBox(itemselected) 0]
2441 set inputfile [file_by_type $type]
2442 set outputfile [FileUniqueName "$ascUtilVect(asctmp)/ascdiscode"]
2443 set result [Disp_ShowCode $type $inputfile $outputfile]
2444 if {$result == "0"} {
2445 FastFileInText $ascDispVect(textBox) $outputfile
2446 }
2447 file delete $outputfile
2448 DispSetEntry "Refinement code of $type"
2449 newraise .display
2450 }
2451
2452 #
2453 # proc Browser_Refine {}
2454 #-------------------------------------------------------------------------
2455 # browser Edit.refine button
2456 # target_type is the target_type to refine to. This procedure does the
2457 # actual work of refining the types by calling the C-code. inst_context
2458 # specifies whether the current or search instance.
2459 # NOTE: The current sim will be re-exported to the browser. This is a fast
2460 # operation and ensures that none of the browser instances are all update
2461 # after the refine has been done, and that they are not looking at *moved*
2462 # instances.
2463 #-------------------------------------------------------------------------
2464 proc Browser_Refine {target_type {inst_context "current"}} {
2465 if {$target_type == ""} {return 1}
2466 set nok [catch "brefine $target_type $inst_context" err_msg]
2467 if {$nok} {
2468 Brow_Raise_Alert "$err_msg" "Refine Error";
2469 return 1;
2470 } {
2471 return 0;
2472 }
2473 }
2474 #
2475 # proc Browser_do_Refine {}
2476 #-------------------------------------------------------------------------
2477 # browser Edit.refine button
2478 # target_type is the target_type to refine to.
2479 #-------------------------------------------------------------------------
2480 proc Browser_do_Refine {} {
2481 global ascBrowVect
2482
2483 global ascListSelectBox
2484 set ascListSelectBox(grab) 1
2485 set ascListSelectBox(btn4name) ""
2486 set ascListSelectBox(btn3name) Show
2487 set ascListSelectBox(btn5name) ""
2488 set ascListSelectBox(btn3destroy) 0
2489 set ascListSelectBox(btn3command) Browser_RefineShowCode
2490 set ascListSelectBox(headline) "Eligible types for refinement:"
2491 set ascListSelectBox(toplevelname) ".browrefine"
2492 set ascListSelectBox(selectmode) browse
2493 set ascListSelectBox(font) $ascBrowVect(font)
2494 set ascListSelectBox(title) "Refining [inst type] [Brow_get_subname]:"
2495
2496 set type [inst type]
2497 set button [AscListSelectBox [drefines_meall $type] \
2498 250x240[setpos .browser 50 50]]
2499 if {$button==2} {return 1}
2500 if {$button==1} {
2501 set target_type $ascListSelectBox(itemselected)
2502 }
2503 if {$target_type ==""} {
2504 Brow_Raise_Alert "You must specify\na type." "Refine Error";
2505 return 1;
2506 }
2507 #
2508 # Save the old names so that we can set back up
2509 # the browser when finished. Inform all interested parties
2510 # that the move is about to take place. THEN do the refine.
2511 #
2512 set old_name [Brow_get_subname]
2513 set old_sim [sims getcurrent]
2514 HUB_Message_to_HUB INSTANCEMOVED $old_sim
2515 set nok [Browser_Refine $target_type current]
2516 if {$nok} { return 1 }
2517
2518 # The following should handle the re-exporting of the given
2519 # instance to the Browser. We don't do it here directly as a
2520 # we need to send the message to the HUB that something WAS refined
2521 # in any Case but don't want to set up a potential infinite loop, or
2522 # end up calling the re-export code twice.
2523
2524 HUB_Message_to_HUB INSTREFINED $old_name $target_type
2525 }
2526
2527 # proc Browser_Merge {}
2528 #-------------------------------------------------------------------------
2529 # This command ASSUMES that g_search_inst is looking at the instance to
2530 # be merged with. Will attempt to merge the current and the search inst.
2531 # Hence it takes no args. This routine could be made more general, by
2532 # setting up more instance pointers. The code for BrowMergeCmd in
2533 # interface/BrowserProc.c should then be modified accordingly.
2534 #-------------------------------------------------------------------------
2535 proc Browser_Merge {} {
2536 set nok [catch "bmerge" err_msg]
2537 if {$nok} {
2538 Brow_Raise_Alert "$err_msg" "Merge Error"
2539 return 1
2540 }
2541 return 0
2542 }
2543
2544 #
2545 # proc Browser_do_Merge {}
2546 #-------------------------------------------------------------------------
2547 # This command is bound to the merge menu item on the browser. It will
2548 # prompt for a dialog box for the name of the instance to be merged
2549 # with. Will call 'qlfdid' to search for the instance and if found
2550 # leave g_search_isnt looking at the instance. Brow_Merge will be then
2551 # called to do the true merge.
2552 # target_inst is the fully qualified name of the instance that is going
2553 # to be merged with the current instance. Will work only on the current
2554 # instance.
2555 #-------------------------------------------------------------------------
2556 proc Browser_do_Merge {} {
2557 global AscMonoEntry1 ascBrowVect
2558
2559 set sim [sims getc]
2560 set name [Brow_get_subname]
2561 set AscMonoEntry1(font) $ascBrowVect(font)
2562 set target_inst [lindex [VShowWindow.ascMonoEntry1 \
2563 "Instance Name :" "420x100[setpos .browser 50 50]" \
2564 "" "Enter fully qualified instance name to merge with."] 1]
2565 if {$AscMonoEntry1(button)==2} {return 1}
2566 if {$AscMonoEntry1(button)==3} {puts "No help yet"; return 1}
2567 if {$target_inst ==""} {
2568 Brow_Raise_Alert "You must specify\nan instance name." "Merge Error";
2569 return 1;
2570 }
2571 set nok [catch "qlfdid {$target_inst}" err_msg]
2572 if {$nok} {
2573 Brow_Raise_Alert "Error in finding instance\n$err_msg" "Merge Error"
2574 return 1;
2575 }
2576
2577 # Inform all interested parties that an instance is about
2578 # to be moved in memory. This includes the Browser itself.
2579 # THEN do the merge.
2580
2581 HUB_Message_to_HUB INSTANCEMOVED $sim
2582 set nok [Browser_Merge]
2583 if {$nok} { return 1 }
2584
2585 # The re-exporting of the instance to the browser is handled by
2586 # the below code. See the note in Browser_do_Refine for more details.
2587 #
2588 HUB_Message_to_HUB INSTMERGED $name $target_inst
2589 }
2590
2591 #
2592 # proc Browser_do_ResumeCompile {}
2593 #-------------------------------------------------------------------------
2594 # browser Edit.compile.resumecompilation button
2595 #-------------------------------------------------------------------------
2596 proc Browser_do_ResumeCompile {} {
2597 global ascBrowVect
2598 set old_name [Brow_get_subname]
2599 set old_sim [sims getcurrent]
2600 HUB_Message_to_HUB INSTANCEMOVED $old_sim
2601 sim_reinstantiate $old_name
2602 global ascScripVect
2603 set muffle $ascScripVect(executing)
2604 if {!$muffle} {set ascScripVect(executing) 1}
2605 Brow_Export_Any_2Browser $old_name
2606 if {!$muffle} {set ascScripVect(executing) 0}
2607 #if {$nok} { return 1 }
2608 HUB_Message_to_HUB INSTANCERESUMED $old_sim
2609 }
2610
2611 #
2612 # proc Brow_Raise_Alert {errmsg {label "Error"} {geom "200x70+480+200"}}
2613 #-------------------------------------------------------------------------
2614 # browser alertbox
2615 #-------------------------------------------------------------------------
2616 proc Brow_Raise_Alert {errmsg {label "Error"} {geom "200x70+480+200"}} {
2617 Script_Raise_Alert $errmsg $label
2618 }
2619 #
2620 # proc Brow_CreatePart_ErrorCheck {partname parttype}
2621 #-------------------------------------------------------------------------
2622 # inverse boolean sanity check on create part button
2623 # Needed for Create Part only.
2624 #-------------------------------------------------------------------------
2625 proc Brow_CreatePart_ErrorCheck {partname parttype} {
2626 if {$partname == ""} {
2627 set errmsg "No name was given\n for the part"
2628 Brow_Raise_Alert $errmsg "Create Part Error"
2629 return 1;
2630 }
2631 if {$parttype == ""} {
2632 set errmsg "No type was given"
2633 Brow_Raise_Alert $errmsg "Create Part Error"
2634 return 1;
2635 }
2636 puts "Check childexist"
2637 set list [inst child]
2638 if {[lsearch $list $partname] == -1} {
2639 set errmsg "The name given\nalready exists"
2640 Brow_Raise_Alert $errmsg "Create Part Error"
2641 return 1;
2642 }
2643 puts "Check typeexist"
2644 if {![libr_query -exists -type $parttype]} {
2645 set errmsg "The specified type\ndoes not exist"
2646 Brow_Raise_Alert $errmsg "Create Part Error"
2647 return 1;
2648 }
2649 return 0;
2650 }
2651 #
2652 # proc Browser_do_CreatePart {}
2653 #-------------------------------------------------------------------------
2654 # browser Edit.compile.createpart button
2655 #-------------------------------------------------------------------------
2656 proc Browser_do_CreatePart {} {
2657 global ascBrowVect AscMonoEntry2
2658
2659 # disabled until problem with typeexist (library.h:FindType) fixed.
2660 Brow_Raise_Alert "Create Part not\nyet implemented"
2661 return 1;
2662
2663 set pos [setpos .browser 65 65]
2664 set AscMonoEntry2(font) $ascBrowVect(font)
2665 set data \
2666 [VShowWindow.ascMonoEntry2 "Part name Type name" \
2667 "$pos" "newpart" "\*"]
2668 if {$data == "" || [lindex $data 0] == 2} {
2669 return;
2670 }
2671 set partname [lindex $data 1]
2672 set parttype [lindex $data 2]
2673 set nok [Brow_CreatePart_ErrorCheck $partname $parttype]
2674 if {$nok} {
2675 return 1;
2676 }
2677 set nok [catch "createpart $partname $parttype" err]
2678 if {$nok} {
2679 return 1;
2680 } {
2681 puts "Part $partname OF $parttype Created"
2682 return 0;
2683 }
2684 }
2685 #-------------------------------------------------------------------------
2686 #-------------------------------------------------------------------------
2687 #DISPLAY CODE
2688
2689 #
2690 # proc Brow_InvokePlotProgram
2691 #-------------------------------------------------------------------------
2692 # Accepts the name of a plot file and will invoke a plotting program on it.
2693 #-------------------------------------------------------------------------
2694 proc Brow_InvokePlotProgram {filename {plotcommand ""}} {
2695 global ascUtilVect
2696 if {$plotcommand != ""} {
2697 set plot_cmd $plotcommand
2698 } {
2699 set plot_cmd $ascUtilVect(plot_command)
2700 if {$plot_cmd == ""} {return}
2701 }
2702 #exec $plot_cmd $filename
2703 if {[catch {eval "exec" $plot_cmd $filename &} msg]} {
2704 puts "Error invoking $plot_cmd $filename"
2705 }
2706 }
2707
2708 #
2709 # proc Brow_PrepPlotFile
2710 #-------------------------------------------------------------------------
2711 # Prepares and writes the plotfile based on the type of plot, which is
2712 # currently one of plain, xgraph, gnu_plot. Valid instances are
2713 # 'current' or 'search'.
2714 #-------------------------------------------------------------------------
2715 proc Brow_PrepPlotFile {plot_type {whichinst "current"}} {
2716 global ascUtilVect
2717 set username [ascwhoami]
2718 set file_prefix $ascUtilVect(asctmp)/asc$username
2719 set filename [FileUniqueName "$file_prefix.$plot_type"]
2720
2721 # call the C-code to write the plotfile for the current inst.
2722 set res [b_prepplotfile $whichinst $filename $plot_type]
2723 puts "Generating plot file \"$filename\""
2724 return $filename;
2725 }
2726
2727 #
2728 # proc Brow_do_Plot
2729 #-------------------------------------------------------------------------
2730 # This is the function bound the menu item plot under mb display in the
2731 # browser. A unique filename is created from the code FileUniqueName
2732 # function in DisplayProc.tcl.
2733 #-------------------------------------------------------------------------
2734 proc Brow_do_Plot {} {
2735 global ascUtilVect
2736
2737 # Next C-call returns 1 if we can plot.
2738 set can_plot [b_isplottable current];
2739 if {$can_plot == 0} {return}
2740 set plot_type $ascUtilVect(plot_type)
2741
2742 # This will create a filename of the form /tmp/ascka0p.xgraph6459.113525
2743 set filename [Brow_PrepPlotFile $plot_type]
2744 if {$filename == ""} {return}
2745 if {$ascUtilVect(plot_command) != ""} {
2746 Brow_InvokePlotProgram $filename $ascUtilVect(plot_command)
2747 HUB_Message_to_HUB PLOTMADE [Brow_get_subname] $filename
2748 } {error "Plot command not set in utilities window!"}
2749 }
2750 #
2751 # proc Brow_do_Statistics {}
2752 #-------------------------------------------------------------------------
2753 # Display.Statistics button in the browser
2754 #-------------------------------------------------------------------------
2755 proc Brow_do_Statistics {} {
2756 puts stdout "Instance Statistics for [Brow_get_subname]:"
2757 bstatistics
2758 puts stdout "====================================================="
2759 }
2760
2761
2762 #
2763 # proc Brow_do_DispAttr {}
2764 #-------------------------------------------------------------------------
2765 # This is command will display the attributes associated with
2766 # the currently focused instance if it is a variable. needs to be
2767 # expanded.
2768 #-------------------------------------------------------------------------
2769 proc Brow_do_DispAttr {} {
2770 global ascDispVect
2771 set list "none"
2772 catch {set list [dbg_write_qlfattr [Brow_get_subname]]}
2773 DispClear;
2774 DispSetEntry "Attributes of [Brow_get_subname]"
2775 DispInsert $list
2776 if {$ascDispVect(visibility)} {newraise .display}
2777 }
2778
2779 #
2780 # proc Brow_do_HideNames
2781 #-------------------------------------------------------------------------
2782 # pops up a list of visible children of type (see ChildVisible, child.h,
2783 # or maybe just "inst child") and strip off the leading goo of each)
2784 # and makes invisible those selected.
2785 # Children hidden are hidden in all contexts similar to the current one,
2786 # because the hide bit is part of the typedescriptions child list.
2787 # maybe we should have hide child and hide child in all refinements.
2788 #-------------------------------------------------------------------------
2789 proc Brow_do_HideNames {} {
2790 global ascListSelectB1Box ascBrowVect
2791 set list ""
2792 set type "[inst type]"
2793 set plist ""
2794 catch {set list [brow_child_list current all TYPE ATOMS PASSED]}
2795 foreach i $list {
2796 lappend plist "[lindex $i 0]"
2797 }
2798
2799 if {$plist == ""} {
2800 Brow_Raise_Alert "Hide names called without children to hide" \
2801 "Unhide error"
2802 return
2803 }
2804 set ascListSelectB1Box(grab) 0
2805 set ascListSelectB1Box(btn2name) TagAll
2806 set ascListSelectB1Box(btn3name) Hide
2807 set ascListSelectB1Box(btn4name) ""
2808 set ascListSelectB1Box(btn5name) ""
2809 set ascListSelectB1Box(btn2destroy) 0
2810 set ascListSelectB1Box(btn3destroy) 0
2811 set ascListSelectB1Box(btn4destroy) 0
2812 set ascListSelectB1Box(btn2command) Browser_FindSelectAll
2813 set ascListSelectB1Box(btn3command) Brow_HideListSelect
2814 set ascListSelectB1Box(title) "Hide names in $type"
2815 set ascListSelectB1Box(toplevelname) ".browhidename"
2816 set ascListSelectB1Box(selectmode) extended
2817 set ascListSelectB1Box(headline) "Hideable $type Parts"
2818 set ascBrowVect(hideparts_type) $type
2819
2820 set button [AscListSelectB1Box $plist \
2821 250x240[setpos .browser 150 20]]
2822 }
2823
2824 proc Brow_HideListSelect {} {
2825 global ascListSelectB1Box ascBrowVect
2826 set list $ascListSelectB1Box(itemselected)
2827 set type $ascBrowVect(hideparts_type)
2828 foreach i $list {
2829 libr_hide_type $type $i
2830 Libr_recordhide add $type $i
2831 }
2832 HUB_Message_to_HUB TYPEHIDDEN
2833 }
2834 #
2835 # proc Brow_do_UnHideNames {}
2836 #-------------------------------------------------------------------------
2837 # pops up a list of invisible children of type (see ChildVisible, child.h)
2838 # and makes visible those selected.
2839 #-------------------------------------------------------------------------
2840 proc Brow_do_UnHideNames {} {
2841 global ascListSelectB1Box ascBrowVect
2842 set list ""
2843 set alllist ""
2844 set hiddenlist ""
2845 set type "[inst type]"
2846 set plist ""
2847 catch {set list [brow_child_list current all TYPE ATOMS PASSED]}
2848 foreach i $list {
2849 lappend plist "[lindex $i 0]"
2850 }
2851 catch {set alllist [inst child]}
2852 if {$alllist == "0"} {
2853 Brow_Raise_Alert "UnHide names called\non childless instance" \
2854 "Unhide error"
2855 return
2856 }
2857 foreach i $alllist {
2858 if {[lsearch -exact $plist $i] == -1} {
2859 lappend hiddenlist $i
2860 }
2861 }
2862 if {$hiddenlist == ""} {
2863 Brow_Raise_Alert "UnHide names found no hidden children" \
2864 "Unhide message"
2865 return
2866 }
2867
2868 set ascListSelectB1Box(grab) 0
2869 set ascListSelectB1Box(btn2name) TagAll
2870 set ascListSelectB1Box(btn3name) UnHide
2871 set ascListSelectB1Box(btn4name) ""
2872 set ascListSelectB1Box(btn5name) ""
2873 set ascListSelectB1Box(btn2destroy) 0
2874 set ascListSelectB1Box(btn3destroy) 0
2875 set ascListSelectB1Box(btn4destroy) 0
2876 set ascListSelectB1Box(btn2command) Browser_FindSelectAll
2877 set ascListSelectB1Box(btn3command) Brow_UnHideListSelect
2878 set ascListSelectB1Box(title) "UnHide names in $type"
2879 set ascListSelectB1Box(toplevelname) ".browshowname"
2880 set ascListSelectB1Box(selectmode) extended
2881 set ascListSelectB1Box(headline) "$type hidden Parts"
2882 set ascBrowVect(hideparts_type) $type
2883
2884 set button [AscListSelectB1Box $hiddenlist \
2885 250x240[setpos .browser 150 20]]
2886 }
2887
2888 proc Brow_UnHideListSelect {} {
2889 global ascListSelectB1Box ascBrowVect
2890 set list $ascListSelectB1Box(itemselected)
2891 set type $ascBrowVect(hideparts_type)
2892 foreach i $list {
2893 libr_unhide_type $type $i
2894 Libr_recordhide delete $type $i
2895 }
2896 HUB_Message_to_HUB TYPEHIDDEN
2897 }
2898
2899 # proc Brow_DispRelsForAtom
2900 #-------------------------------------------------------------------------
2901 # This actually does the work of fetching the relations associated
2902 # with a REAL_ATOM_INST and soon to come BOOLEAN_ATOM_INSTs and stuffing
2903 # them in the Display window.
2904 #-------------------------------------------------------------------------
2905 proc Brow_DispRelsForAtom {{context "current"}} {
2906 global ascDispVect
2907
2908 set rel_list [__brow_relsforatom $context];
2909 if {$rel_list == ""} {
2910 newraise .display;
2911 DispClear;
2912 return
2913 }
2914 # clear the display box.
2915 DispClear;
2916 DispSetEntry "Relations for atom [Brow_get_subname]"
2917 DispInsert2 $rel_list;
2918 newraise .display
2919 }
2920
2921
2922 # proc Brow_DispRelations
2923 #-------------------------------------------------------------------------
2924 # This actually does the work of fetching the relations and stuffing them
2925 # in the display box. Valid options are INFIX or POSFIX.
2926 #-------------------------------------------------------------------------
2927 proc Brow_DispRelations {{infix_or_postfix "INFIX"}} {
2928 global ascDispVect
2929 if {$infix_or_postfix == "INFIX"} {
2930 set rel_list [bgetrels current];
2931 } {
2932 set rel_list [bgetrelspf current];
2933 }
2934 if {$rel_list == ""} {
2935 newraise .display;
2936 DispClear;
2937 return
2938 }
2939 # clear the display box.
2940 DispClear;
2941 DispSetEntry "Relations in [Brow_get_subname]"
2942 DispInsert2 $rel_list;
2943 newraise .display
2944 }
2945
2946
2947 #
2948 # proc Brow_do_DispRelations {}
2949 #-------------------------------------------------------------------------
2950 # This command will display the relations associated with
2951 # the currently focused instance. The relations will be displayed in the
2952 # Display window. A postfix representation of the display is coded but
2953 # not bound to the button.
2954 #-------------------------------------------------------------------------
2955 proc Brow_do_DispRelations {} {
2956 global ascBrowVect
2957
2958 set inst_kind [inst kind]
2959 # if not model type then check for arrays of relations
2960
2961 switch $inst_kind {
2962 {MODEL_INST} {
2963 Brow_DispRelations INFIX;
2964 }
2965 {REAL_ATOM_INST} {
2966 Brow_DispRelsForAtom current;
2967 }
2968 default {
2969 set is_rel_type [__brow_isrelation current]
2970 if {$is_rel_type} {
2971 Brow_DispRelations INFIX;
2972 }
2973 }
2974 }
2975 }
2976
2977
2978 # proc Brow_DispCondRels
2979 #-------------------------------------------------------------------------
2980 # This actually does the work of fetching the conditional relations and
2981 # stuffing them in the display box. Only INFIX representation.
2982 #-------------------------------------------------------------------------
2983 proc Brow_DispCondRels {} {
2984 global ascDispVect
2985
2986 set rel_list [bgetcondrels current];
2987
2988 if {$rel_list == ""} {
2989 newraise .display;
2990 DispClear;
2991 return
2992 }
2993 # clear the display box.
2994 DispClear;
2995 DispSetEntry "Conditional Relations in [Brow_get_subname]"
2996 DispInsert2 $rel_list;
2997 newraise .display
2998 }
2999
3000
3001 #
3002 # proc Brow_do_DispCondRels {}
3003 #-------------------------------------------------------------------------
3004 # This command will display the relations associated with
3005 # the currently focused instance. The relations will be displayed in the
3006 # Display window.
3007 #-------------------------------------------------------------------------
3008 proc Brow_do_DispCondRels {} {
3009 global ascBrowVect
3010
3011 set inst_kind [inst kind]
3012 # if not model type then check for arrays of relations
3013
3014 switch $inst_kind {
3015 {MODEL_INST} {
3016 Brow_DispCondRels;
3017 }
3018 default {
3019 set is_rel_type [__brow_isrelation current]
3020 if {$is_rel_type} {
3021 Brow_DispCondRels;
3022 }
3023 }
3024 }
3025 }
3026
3027
3028
3029 # proc Brow_DispLogRelsForAtom
3030 #-------------------------------------------------------------------------
3031 # This actually does the work of fetching the logical relations associated
3032 # with a BOOLEAN_ATOM_INST and stuffing
3033 # them in the Display window.
3034 #-------------------------------------------------------------------------
3035 proc Brow_DispLogRelsForAtom {{context "current"}} {
3036 global ascDispVect
3037
3038 set lrel_list [__brow_logrelsforatom $context];
3039 if {$lrel_list == ""} {
3040 newraise .display;
3041 DispClear;
3042 return
3043 }
3044 # clear the display box.
3045 DispClear;
3046 DispSetEntry "Logical Relations for atom [Brow_get_subname]"
3047 DispInsert2 $lrel_list;
3048 newraise .display
3049 }
3050
3051
3052 # proc Brow_DispLogRels
3053 #-------------------------------------------------------------------------
3054 # This actually does the work of fetching the logical relations
3055 # and stuffing them in the display box.
3056 # Valid options are INFIX or POSFIX.
3057 #-------------------------------------------------------------------------
3058 proc Brow_DispLogRels {{infix_or_postfix "INFIX"}} {
3059 global ascDispVect
3060 if {$infix_or_postfix == "INFIX"} {
3061 set lrel_list [bgetlogrels current];
3062 } {
3063 set lrel_list [bgetlogrelspf current];
3064 }
3065 if {$lrel_list == ""} {
3066 newraise .display;
3067 DispClear;
3068 return
3069 }
3070 # clear the display box.
3071 DispClear;
3072 DispSetEntry "Logical Relations in [Brow_get_subname]"
3073 DispInsert2 $lrel_list;
3074 newraise .display
3075 }
3076
3077
3078 #
3079 # proc Brow_do_DispLogRels {}
3080 #-------------------------------------------------------------------------
3081 # This command will display the logical relations associated with
3082 # the currently focused instance. The logical relations will be displayed
3083 # in the Display window. A postfix representation of the display is coded
3084 # but not bound to the button.
3085 #-------------------------------------------------------------------------
3086 proc Brow_do_DispLogRels {} {
3087 global ascBrowVect
3088
3089 set inst_kind [inst kind]
3090 # if not model type then check for arrays of logical relations
3091
3092 switch $inst_kind {
3093 {MODEL_INST} {
3094 Brow_DispLogRels INFIX;
3095 }
3096 {BOOLEAN_ATOM_INST} {
3097 Brow_DispLogRelsForAtom current;
3098 }
3099 default {
3100 set is_logrel_type [__brow_islogrel current]
3101 if {$is_logrel_type} {
3102 Brow_DispLogRels INFIX;
3103 }
3104 }
3105 }
3106 }
3107
3108
3109
3110 # proc Brow_DispCondLogRels
3111 #-------------------------------------------------------------------------
3112 # This actually does the work of fetching the conditional logical
3113 # relations and stuffing them in the display box.
3114 # Only INFIX representation.
3115 #-------------------------------------------------------------------------
3116 proc Brow_DispCondLogRels {} {
3117 global ascDispVect
3118
3119 set logrel_list [bgetcondlogrels current];
3120
3121 if {$logrel_list == ""} {
3122 newraise .display;
3123 DispClear;
3124 return
3125 }
3126 # clear the display box.
3127 DispClear;
3128 DispSetEntry "Conditional Logical Relations in [Brow_get_subname]"
3129 DispInsert2 $logrel_list;
3130 newraise .display
3131 }
3132
3133
3134 #
3135 # proc Brow_do_DispCondLogRels {}
3136 #-------------------------------------------------------------------------
3137 # This command will display the logical relations associated with
3138 # the currently focused instance. The log relations will be displayed
3139 # in the Display window.
3140 #-------------------------------------------------------------------------
3141 proc Brow_do_DispCondLogRels {} {
3142 global ascBrowVect
3143
3144 set inst_kind [inst kind]
3145 # if not model type then check for arrays of relations
3146
3147 switch $inst_kind {
3148 {MODEL_INST} {
3149 Brow_DispCondLogRels;
3150 }
3151 default {
3152 set is_logrel_type [__brow_islogrel current]
3153 if {$is_logrel_type} {
3154 Brow_DispCondLogRels;
3155 }
3156 }
3157 }
3158 }
3159
3160
3161
3162
3163
3164
3165
3166
3167 # proc Brow_DispWhensForInstance
3168 #-------------------------------------------------------------------------
3169 # This actually do the work of fetching the whens associated
3170 # with an instance and stuffing them in the Display window.
3171 # Instance can be boolean, integer, symbol, relation. It will
3172 # collect the WHENs which include such an instance in either
3173 # the list of variables or in some of the CASEs.
3174 #-------------------------------------------------------------------------
3175 proc Brow_DispWhensForInstance {{context "current"}} {
3176 global ascDispVect
3177
3178 set when_list [__brow_whensforinstance $context];
3179 if {$when_list == ""} {
3180 newraise .display;
3181 DispClear;
3182 return
3183 }
3184 # clear the display box.
3185 DispClear;
3186 DispSetEntry "Whens for instance [Brow_get_subname]"
3187 DispInsert2 $when_list;
3188 newraise .display
3189 }
3190
3191
3192 # proc Brow_DispWhens
3193 #-------------------------------------------------------------------------
3194 # This actually does the work of fetching the whens
3195 # and stuffing them in the display box. It works for models, a WHEN or
3196 # array of WHENs
3197 #-------------------------------------------------------------------------
3198 proc Brow_DispWhens {} {
3199 global ascDispVect
3200 #
3201 set when_list [bgetwhens current];
3202 if {$when_list == ""} {
3203 newraise .display;
3204 DispClear;
3205 return
3206 }
3207 # clear the display box.
3208 DispClear;
3209 DispSetEntry "Whens in [Brow_get_subname]"
3210 DispInsert2 $when_list;
3211 newraise .display
3212 }
3213
3214
3215 #
3216 # proc Brow_do_DispWhens {}
3217 #-------------------------------------------------------------------------
3218 # This command will display the WHENs associated with
3219 # the currently focused instance. The whens will be displayed
3220 # in the Display window.
3221 #-------------------------------------------------------------------------
3222 proc Brow_do_DispWhens {} {
3223 global ascBrowVect
3224
3225 # To check for model
3226 set inst_kind [inst kind]
3227
3228 if { $inst_kind =="MODEL_INST" } {
3229 Brow_DispWhens;
3230 return
3231 }
3232
3233 # To check for when or array of when
3234 set is_when_type [__brow_iswhen current]
3235
3236 if {$is_when_type} {
3237 Brow_DispWhens;
3238 return
3239 }
3240
3241 # if not model type or when then check for instance in when
3242 set is_instance_in_when [__brow_isinstanceinwhen current]
3243
3244 if {$is_instance_in_when} {
3245 Brow_DispWhensForInstance;
3246 return
3247 }
3248 }
3249
3250 #-------------------------------------------------------------------------
3251 #-------------------------------------------------------------------------
3252
3253
3254 # proc Brow_do_Help {}
3255 # proc Brow_do_BindHelp {}
3256 #-------------------------------------------------------------------------
3257 # browser help onbrowsing, onbrowser, respectively
3258 #-------------------------------------------------------------------------
3259 proc Brow_do_Help {} {
3260 Help_button browser
3261 }
3262 proc Brow_do_BindHelp {} {
3263 Help_button browser.help onbrowser
3264 }
3265
3266 #
3267 # misc random header, unmatched by any function
3268 #-------------------------------------------------------------------------
3269 # proc Brow_export_to_probe
3270 #
3271 # defined in ProbeProc.tcl
3272 #
3273 # This code will be for return values from the brow_child_list or inst type
3274 # routines of the form 'name IS_A type' or 'name = value'. It is perhaps
3275 # easiest to retunr this compound information as a long list and to use
3276 # the following function to strip apart. For example the ascBrowVect(children)
3277 # needs the compound information but the ascParentsBox needs only the name.
3278 #-------------------------------------------------------------------------
3279
3280 #
3281 # proc strip {tvlist} {
3282 #-------------------------------------------------------------------------
3283 # remove ' [ ] from a string tvlist
3284 #-------------------------------------------------------------------------
3285 proc strip {tvlist} {
3286
3287 regsub -all {\'} $tvlist "" b;
3288 regsub -all {\[} $b "" b; regsub -all {\]} $b "" b;
3289 return $b;
3290 }
3291
3292 #
3293 # proc stripbraces {listelement}
3294 #-------------------------------------------------------------------------
3295 # remove any outer { } from a string
3296 #-------------------------------------------------------------------------
3297 proc stripbraces {listelement} {
3298 set listelement [string trimleft $listelement " \{"];
3299 set list [string trimright $listelement " \}"];
3300 return $list
3301 }
3302
3303 #
3304 # proc Brow_parse_values {filename force}
3305 #-------------------------------------------------------------------------
3306 # function to parse a values file. unexecutable tcl lines will be reported
3307 # as will the total line count parsed.
3308 #-------------------------------------------------------------------------
3309 proc Brow_parse_values {filename force} {
3310 global ascBrowVect
3311 set ok 1
3312 set lc 0
3313 set line ""
3314 set errors ""
3315 set ec 0
3316 # open file
3317 set fileid [open $filename r]
3318 set cc [gets $fileid line]
3319 # get first line for preprocessing
3320 if {$cc<0} {
3321 close $fileid
3322 puts stdout "Read $lc lines from $filename."
3323 return
3324 }
3325 # check header for new style relative addressing
3326 if {[string first qlfdid $line] == 0} {
3327 set root [lindex $line 1]
3328 set label ""
3329 set title ""
3330 if {[catch {eval $line} err]} {
3331 set title "Read values into what object? ($root not found)"
3332 set label "Name:"
3333 set force 0
3334 } else {
3335 set title "Values to be read into:"
3336 set label "Object:"
3337 }
3338 global AscMonoEntry1
3339 set AscMonoEntry2(font) $ascBrowVect(font)
3340 if {$force == 0} { # confirm read-to location
3341 set tinst [lindex [VShowWindow.ascMonoEntry1 \
3342 $label "500x100[setpos .library 50 50]" \
3343 $root $title ""] 1]
3344 if {$AscMonoEntry1(button)==2} {
3345 close $fileid
3346 return
3347 }
3348 if {$AscMonoEntry1(button)==3} {
3349 set expl {Enter a simulation or qualified name.}
3350 Script_Raise_Alert $expl "$label help:"
3351 close $fileid
3352 return
3353 }
3354 if {[catch {qlfdid $tinst} msg]} {
3355 Script_Raise_Alert "$tinst not found!" "Undefined instance"
3356 close $fileid
3357 return
3358 }
3359 }
3360 # else the qlfdid passed above in catch eval line
3361 } else {
3362 incr lc
3363 if {[catch $line ] && $line != ""} {
3364 incr ec
3365 lappend errors "$lc:"
3366 lappend errors $line
3367 }
3368 }
3369 while {$ok} {
3370 set cc [gets $fileid line]
3371 if {$cc<0} {break}
3372 incr lc
3373 if {[catch $line ] && $line != ""} {
3374 # puts stderr "Unable to parse value file line: $lc\n $line"
3375 if {[string first qlfdid $line] == 0} {
3376 puts stderr "exiting read values due to qlfdid failure\n"
3377 close $fileid
3378 }
3379 incr ec
3380 lappend errors "$lc:"
3381 lappend errors $line
3382 }
3383 }
3384 close $fileid
3385 puts stdout "Read $lc lines from $filename."
3386 if {$ec} {
3387 puts stderr "Errors on $ec lines."
3388 puts stderr " Type \"Brow_parse_errors\" to see the lines."
3389 }
3390 set ascBrowVect(parseerrors) $errors
3391 }
3392
3393 proc Brow_parse_errors {} {
3394 global ascBrowVect
3395 puts stderr "Parse errors: -------------------------------------"
3396 foreach i $ascBrowVect(parseerrors) {
3397 puts stderr $i
3398 }
3399 puts stderr "End of parse errors -------------------------------------"
3400 }
3401
3402 #
3403 # eof
3404 #

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