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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 571 - (show annotations) (download) (as text)
Tue May 9 00:14:59 2006 UTC (14 years ago) by johnpye
File MIME type: text/x-tcl
File size: 57599 byte(s)
Renaming 'tcltk98' to 'tcltk', continued...
1 # LibraryProc.tcl: Library Tcl Code
2 # by Benjamin A. Allan and Kirk A. Abbott
3 # Created: January 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.73 $
6 # Last modified on: $Date: 2003/01/19 01:27:44 $
7 # Last modified by: $Author: ballan $
8 # Revision control file: $RCSfile: LibraryProc.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 set_Library_Defaults {}
31 #-------------------------------------------------------------------
32 # the usual setup of window defaults
33 #-------------------------------------------------------------------
34 proc set_Library_Defaults {} {
35
36 global xfShowWindow.library
37 global ascLibrVect
38 global ascLibrVect
39 global ascSimsVect
40
41 # The ascLibrVect(fullfilename) array member is being used
42 # solely for the purpose of having something to stuff in
43 # in the file selection box on repeated calls.
44
45 set ascLibrVect(compileC) 0
46 set ascLibrVect(btuifstop) 1
47 set ascLibrVect(ignorestop) 0
48 set ascLibrVect(parserWarnings) 1
49 set ascLibrVect(compilerWarnings) 1
50 set ascLibrVect(simplifyRelations) 1
51 set ascLibrVect(useCopyAnon) 1
52 set ascLibrVect(lastreadextension) ".a4c"
53 set ascLibrVect(fullfilename) ""
54 set ascLibrVect(selectedtype) ""
55 set ascLibrVect(target_type) ""
56 set ascLibrVect(target_units) ""
57 set ascLibrVect(basefiletypes) {
58 {{Models} {.a4c .asc} }
59 {{Libraries} {.a4l .lib} }
60 {{All ASCEND} {.a4c .a4l .asc .lib .a4p .a4v .a4u} }
61 {{Most} {.*} }
62 {{All} {*} }
63 }
64 set ascLibrVect(filetypes) $ascLibrVect(basefiletypes)
65 set ascLibrVect(windowname) .library
66 # The status line is being controlled by a -textvariable bound
67 # to the entry box. To write to the box, then just set the below variable.
68 set ascLibrVect(entryline) ""
69
70 # As types or type.child are suppressed or unsuppressed,
71 # they should be added to the Libraries tcl list using
72 # the Libr_recordhide function
73 # Libr_recordhide add typename
74 # Libr_recordhide add typename.partname
75 # and removed
76 # Libr_recordhide delete typename
77 # Libr_recordhide delete typename.partname
78 # from the tcl list hiddentypes.
79 Libr_recordhide add unSELECTed_part
80
81 if {[catch {set ascLibrVect(initialized)}]} {
82 set ascLibrVect(initialized) "FALSE"
83 }
84
85 set ascSimsVect(windowname) ".sims";
86 set ascSimsVect(target_instance) "";
87 set ascSimsVect(instancetype) "";
88 set ascSimsVect(selectedsim) "";
89 set ascSimsVect(deletelist) "";
90 set ascSimsVect(filename) "";
91 set ascSimsVect(filetypes) {
92 {{Pending statements} {.pendings} }
93 {{Simulation structure} {.a4i} }
94 {{Most} {.*} }
95 {{All} {*} }
96 }
97
98 set ascLibrVect(moduleBox) .library.main_frm.file_box.listbox1
99 set ascLibrVect(typeBox) .library.main_frm.model_box.listbox1
100 set ascLibrVect(entryBox) .library.entry_frm.lib_entry
101 set ascLibrVect(simsBox) .library.sims_frm.sims_box.listbox1
102 set ascLibrVect(autorun) default_self
103
104 set ascLibrVect(btfirst) 1
105
106 # init method generation stuff
107 set ascLibrVect(standardmethods) {}
108 set ascLibrVect(generate_ADDMETHOD) 0
109 set_MethodsDefaults
110
111 Configure_Library
112 }
113
114 proc Sims_SetupBinTokenCC {} {
115 global ascLibrVect ascUtilVect tcl_platform
116 if {$ascLibrVect(btfirst)} {
117 set ascLibrVect(btfirst) 0
118
119 # set up code generation options
120 set ascLibrVect(btmaxrel) 1000 ;# arbitrary limit. 0 if bt to be ignored.
121 set ascLibrVect(g_uid) 1 ;# a unique id counter
122 set ascLibrVect(btdir) \
123 [file dirname [file dirname [info nameofexecutable]]]/lib
124 set ascLibrVect(btdir) [file nativename $ascLibrVect(btdir)]
125 set ascLibrVect(btverbose) 1 ;# don't comment the code
126 set ascLibrVect(bthousekeep) 0 ;# do housekeep
127 set ascLibrVect(bttarg) $ascUtilVect(asctmp)/asc[ascwhoami]bt[pid]_
128 set ascLibrVect(bttarg) [file nativename $ascLibrVect(bttarg)]
129 if {![file isdirectory $ascLibrVect(btdir)] || \
130 ![file exists $ascLibrVect(btdir)/btprolog.h] || \
131 ($tcl_platform(platform) == "unix" && \
132 ![file exists $ascLibrVect(btdir)/Makefile.bt]) ||
133 ($tcl_platform(platform) == "windows" && \
134 ![file exists $ascLibrVect(btdir)/Makefile.bt.vc]) } {
135 set ascLibrVect(compileC) 0 ;# no build files. suppress bintokens.
136 }
137 set ascLibrVect(btbuildfmt) "%s -f \""
138 append ascLibrVect(btbuildfmt) $ascLibrVect(btdir)
139 append ascLibrVect(btbuildfmt) "%s\" RM=\"%s\" "
140 append ascLibrVect(btbuildfmt) "BTINCLUDES=-I\""
141 append ascLibrVect(btbuildfmt) $ascLibrVect(btdir)
142 append ascLibrVect(btbuildfmt) "\" BTTARGET=\""
143 append ascLibrVect(btbuildfmt) $ascLibrVect(bttarg)
144 append ascLibrVect(btbuildfmt) %d
145 append ascLibrVect(btbuildfmt) "\" \""
146 append ascLibrVect(btbuildfmt) $ascLibrVect(bttarg)
147 append ascLibrVect(btbuildfmt) %d
148 append ascLibrVect(btbuildfmt) "\" TMPDIR=\""
149 append ascLibrVect(btbuildfmt) [file nativename $ascUtilVect(asctmp)]
150 append ascLibrVect(btbuildfmt) "\""
151 switch $tcl_platform(platform) {
152 unix {
153 set ascLibrVect(btunlink) {/bin/rm -f}
154 set ascLibrVect(btmakeutil) make
155 set ascLibrVect(btmakefile) /Makefile.bt
156 }
157 windows {
158 set ascLibrVect(btunlink) del
159 set ascLibrVect(btmakeutil) nmake
160 set ascLibrVect(btmakefile) \\Makefile.bt.vc
161 }
162 default {
163 set ascLibrVect(compileC) 0 ;# 0 --> bt to be ignored.
164 }
165 }
166 ;# done first time only
167 }
168 incr ascLibrVect(g_uid)
169 set srcname $ascLibrVect(bttarg)$ascLibrVect(g_uid).c
170 set objname $ascLibrVect(bttarg)$ascLibrVect(g_uid).o
171 set libname \
172 $ascLibrVect(bttarg)$ascLibrVect(g_uid)[info sharedlibextension]
173 # need 'if windows' here to handle TOOLS32 and ASCENDLIB
174 set buildcommand \
175 [format $ascLibrVect(btbuildfmt) $ascLibrVect(btmakeutil) \
176 $ascLibrVect(btmakefile) $ascLibrVect(btunlink) \
177 $ascLibrVect(g_uid) $ascLibrVect(g_uid)]
178 set rellimit 0
179 if {$ascLibrVect(compileC)} {
180 set rellimit $ascLibrVect(btmaxrel)
181 puts "C compiling by:"
182 puts $buildcommand
183 }
184 sim_BinTokenSetOptions \
185 $srcname \
186 $objname \
187 $libname \
188 $buildcommand \
189 $ascLibrVect(btunlink) \
190 $rellimit \
191 $ascLibrVect(btverbose) \
192 $ascLibrVect(bthousekeep)
193
194 }
195
196 #
197 # proc Configure_Library {}
198 #-------------------------------------------------------------------
199 # bindings for library
200 #-------------------------------------------------------------------
201 proc Configure_Library {} {
202 global ascLibrVect
203
204 ascclearlist $ascLibrVect(moduleBox)
205 ascclearlist $ascLibrVect(typeBox)
206 ascclearlist $ascLibrVect(simsBox)
207
208 # Update Enabled/Disabled entries when a menu is posted
209 #
210 .library.menubar.display configure \
211 -postcommand Libr_Update_Display_Buttons
212 .library.menubar.edit configure \
213 -postcommand Libr_Update_Edit_Buttons
214 .library.menubar.export configure \
215 -postcommand Libr_Update_Export_Buttons
216 .library.menubar.file configure \
217 -postcommand Libr_Update_File_Buttons
218 .library.menubar.find configure \
219 -postcommand Libr_Update_Find_Buttons
220 .library.menubar.view configure \
221 -postcommand Libr_Update_View_Buttons
222
223
224 bind $ascLibrVect(moduleBox) <Button-1> {
225 set ndx [%W nearest %y]
226 set ascLibrVect(entryline) ""
227 if {$ndx != ""} {
228 Libr_do_ModuleBox $ndx
229 }
230 }
231 bind $ascLibrVect(entryBox) <F3> Libr_File_do_Copy
232
233 ascRightMouseAddCommand $ascLibrVect(moduleBox) LibrDeleteAllState \
234 command -label "Delete all types..." \
235 -underline 11 -command Libr_do_DeleteAll
236
237 ascRightMouseAddCommand $ascLibrVect(moduleBox) normal \
238 command -label "Close window" \
239 -underline 0 -command {Toggle_Remote ascLibrVect}
240
241
242 bind $ascLibrVect(typeBox) <ButtonRelease-1> {
243 set ndx [%W curselection]
244 if {$ndx != ""} {
245 set type [%W get $ndx]
246 Libr_do_StatusLine $type
247 }
248 }
249
250 bind $ascLibrVect(typeBox) <Double-1> {
251 set ndx [%W curselection]
252 if {$ndx != ""} {
253 set type [%W get $ndx]
254 Libr_do_StatusLine $type
255 Libr_do_compile
256 }
257 }
258
259 bind $ascLibrVect(typeBox) <Button-3> {
260 set ndx [%W nearest %y]
261 if {$ndx != ""} {
262 set type [%W get $ndx]
263 Libr_do_StatusLine $type
264 }
265 }
266
267 ascRightMouseAddCommand $ascLibrVect(typeBox) LibrCreateSimState \
268 command -label "Create simulation..." \
269 -underline 0 -command Libr_do_compile
270
271 ascRightMouseAddCommand $ascLibrVect(typeBox) LibrDeleteAllState \
272 command -label "Find ATOM by units..." \
273 -underline 0 -command Libr_do_FindAtom
274
275 ascRightMouseAddCommand $ascLibrVect(typeBox) LibrSourceState \
276 command -label "Display source code" \
277 -underline 0 -command Disp_do_ShowCode
278
279 ascRightMouseAddCommand $ascLibrVect(typeBox) LibrAncestryState \
280 command -label "Display type ancestry" \
281 -underline 0 -command Disp_do_ShowAncestry
282
283 #
284 # Bindings for the Simulations listbox
285 #
286 bind $ascLibrVect(simsBox) <1> {
287 global ascSimsVect;
288 set ndx [%W curselection];
289 if {$ndx != ""} {
290 set select [%W get $ndx];
291 if {$select != ""} {
292 set sim [lindex $select 0];
293 set ascSimsVect(selectedsim) $sim;
294 }
295 }
296 }
297
298 bind $ascLibrVect(simsBox) <Double-1> {
299 global ascSimsVect;
300 set ndx [%W curselection];
301 if {$ndx != ""} {
302 set select [%W get $ndx];
303 if {$select != ""} {
304 set sim [lindex $select 0];
305 set ascSimsVect(selectedsim) $sim;
306 }
307 Sims_Export2Browser $sim;
308 }
309 }
310
311 bind $ascLibrVect(simsBox) <3> {
312 global ascSimsVect;
313 set ndx [%W nearest %y];
314 if {$ndx != ""} {
315 set select [%W get $ndx];
316 if {$select != ""} {
317 set sim [lindex $select 0];
318 set ascSimsVect(selectedsim) $sim;
319 }
320 }
321 }
322
323 ascRightMouseAddCommand $ascLibrVect(simsBox) LibrSimPendingState \
324 command -label "Display pending statements" \
325 -underline -1 -command Disp_do_ShowPendings
326
327 ascRightMouseAddCommand $ascLibrVect(simsBox) LibrSimSolverState \
328 command -label "Export simulation to Solver" \
329 -underline -1 -command Sims_do_Export2Solver
330
331 ascRightMouseAddCommand $ascLibrVect(simsBox) LibrSimBrowserState \
332 command -label "Export simulation to Browser" \
333 -underline -1 \
334 -command {Script_ClearInterrupt; BROWSE $ascSimsVect(selectedsim)}
335
336 ascRightMouseAddCommand $ascLibrVect(simsBox) normal \
337 separator
338
339 ascRightMouseAddCommand $ascLibrVect(simsBox) LibrSimDeleteState \
340 command -label "Delete simulation" \
341 -underline -1 -command {DELETE $ascSimsVect(selectedsim)}
342
343 VPane-Bind [winfo parent [winfo parent $ascLibrVect(moduleBox)]] \
344 [winfo name [winfo parent $ascLibrVect(moduleBox)]] \
345 [winfo name [winfo parent $ascLibrVect(typeBox)]] 10 0.333
346
347 set ascLibrVect(initialized) "TRUE"
348 }
349
350
351 #
352 # proc Libr_do_Font {args}
353 #---------------------------------------------------------------------
354 # font select button for window
355 #---------------------------------------------------------------------
356 proc Libr_do_Font {args} {
357 global ascLibrVect;
358 set font ""
359 if {$args != ""} {
360 set font $args
361 } else {
362 set font [ascFontGet]
363 }
364 if {$font == ""} {
365 return;
366 }
367 $ascLibrVect(moduleBox) configure -font $font
368 $ascLibrVect(typeBox) configure -font $font
369 $ascLibrVect(entryBox) configure -font $font
370 $ascLibrVect(simsBox) configure -font $font
371 set ascLibrVect(font) [$ascLibrVect(typeBox) cget -font]
372 }
373
374 #
375 # proc Libr_recordhide {option} {typename} {partname ""}
376 #-------------------------------------------------------------------
377 # Keeps a tcl list of what is suppressed and what isn't,
378 # so that delete types doesn't force us to mark it all over
379 # again.
380 # Each time a file is read, just hide everything in this list
381 # with a catch{} around the hide command so that no errors are
382 # reported.
383 # Examples-
384 # to hide relations:
385 # Libr_recordhide add relation
386 # to hide the just the included flag on relations:
387 # Libr_recordhide add relation.included
388 # to unhide the relation or the relation.included flag:
389 # Libr_recordhide delete relation
390 # Libr_recordhide delete relation.included
391 #-------------------------------------------------------------------
392 proc Libr_recordhide {option typename args} {
393 global ascLibrVect
394 set argc [llength $args]
395 if {$argc} {
396 lappend typename $args
397 }
398 switch $option {
399 {add} {
400 if {[info exist ascLibrVect(hiddentypes)] == 0} {
401 set ascLibrVect(hiddentypes) $typename
402 } else {
403 if {[lsearch -exact $ascLibrVect(hiddentypes) $typename] == -1} {
404 lappend ascLibrVect(hiddentypes) $typename
405 }
406 }
407 }
408 {delete} {
409 if {[info exist ascLibrVect(hiddentypes)] == 1} {
410 set ascLibrVect(hiddentypes) \
411 [delete_list_item $ascLibrVect(hiddentypes) $typename]
412 }
413 }
414 default {
415 error "Libr_recordhide called with unknown option (want add/delete)"
416 }
417 }
418 }
419
420 #
421 # proc Libr_updatehidden {}
422 #-------------------------------------------------------------------
423 # rehide everything, in Case any of it is not hidden and should be.
424 #-------------------------------------------------------------------
425 proc Libr_updatehidden {} {
426 global ascLibrVect
427 if {[info exist ascLibrVect(hiddentypes)] == 1} {
428 foreach i $ascLibrVect(hiddentypes) {
429 if {[llength $i]==1} {
430 catch "Libr_hide_type $i" errmsg
431 } else {
432 catch "Libr_hide_type [lindex $i 0] [lindex $i 1]" errmsg
433 }
434 }
435 }
436 }
437
438 # return normal if type is selected.
439 proc LibrTypeSelState {} {
440 global ascLibrVect
441 if {![info exists ascLibrVect(selectedtype)] || \
442 [string compare $ascLibrVect(selectedtype) ""]==0} {
443 return disabled
444 }
445 return normal
446 }
447 # reconfigure label of compile popup
448 proc LibrCreateSimState {} {
449 global ascLibrVect ascPopInfo
450 set lbl "Create $ascLibrVect(selectedtype) simulation..."
451 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
452 return [LibrTypeSelState]
453 }
454 proc LibrSourceState {} {
455 global ascLibrVect ascPopInfo
456 set lbl "Show $ascLibrVect(selectedtype) code..."
457 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
458 return [LibrTypeSelState]
459 }
460 proc LibrAncestryState {} {
461 global ascLibrVect ascPopInfo
462 set lbl "Show $ascLibrVect(selectedtype) ancestry..."
463 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
464 return [LibrTypeSelState]
465 }
466
467 proc LibrSimSelState {} {
468 global ascSimsVect
469 if {![info exists ascSimsVect(selectedsim)] || \
470 [string compare $ascSimsVect(selectedsim) ""]==0} {
471 return disabled
472 }
473 return normal
474 }
475
476 proc LibrSimPendingState {} {
477 global ascSimsVect ascPopInfo
478 set lbl "Check $ascSimsVect(selectedsim) for pending statements"
479 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
480 return [LibrSimSelState]
481 }
482
483 proc LibrSimSolverState {} {
484 global ascSimsVect ascPopInfo
485 set lbl "Export $ascSimsVect(selectedsim) to solver"
486 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
487 return [LibrSimSelState]
488 }
489
490 proc LibrSimBrowserState {} {
491 global ascSimsVect ascPopInfo
492 set lbl "Browse $ascSimsVect(selectedsim)"
493 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
494 return [LibrSimSelState]
495 }
496
497 proc LibrSimDeleteState {} {
498 global ascSimsVect ascPopInfo
499 set lbl "Delete $ascSimsVect(selectedsim)"
500 $ascPopInfo(menu) entryconfigure $ascPopInfo(index) -label $lbl
501 return [LibrSimSelState]
502 }
503 #
504 # proc Libr_do_DeleteAll {args}
505 #-------------------------------------------------------------------
506 # remove all definitions from the library
507 # pops a confirm button if called without anything in args.
508 #-------------------------------------------------------------------
509 proc Libr_do_DeleteAll {args} {
510 global ascLibrVect
511 if {$args == ""} {
512 set position [setpos $ascLibrVect(windowname) 40 60]
513 set res [VShowWindow.ascConfirm "220x50$position" "Delete All"]
514 if {$res != 1} {
515 return
516 }
517 }
518 puts stderr "*************************************************"
519 libr_destroy_types
520 ascclearlist $ascLibrVect(typeBox)
521 set ascLibrVect(entryline) ""
522 set ascLibrVect(selectedtype) ""
523 puts stdout "All types and simulations deleted."
524 Libr_updatemod
525 puts stderr "*************************************************"
526 HUB_Message_to_HUB LIBDESTROYED
527 }
528
529 # proc Libr_ModuleBoxSelect {modulename}
530 #-------------------------------------------------------------------
531 # Simply selects the modulename given in the module box.
532 #-------------------------------------------------------------------
533 proc Libr_ModuleBoxSelect {modulename} {
534 global ascLibrVect
535 set modulelist [lsort -dictionary [libr_query -modulelist -mtype 0]]
536 if {[llength $modulelist] == 0} {
537 return;
538 }
539 set ndx [lsearch $modulelist $modulename]
540 $ascLibrVect(moduleBox) selection clear 0 end
541 $ascLibrVect(moduleBox) selection set $ndx
542 }
543
544 #
545 # proc Libr_do_StatusLine {type}
546 #-------------------------------------------------------------------
547 # set status line to type IN file
548 # The status line is being controlled by a -textvariable bound
549 # to the entry box. To write to the box, then just set the below variable.
550 # See the code in library.tcl for details.
551 #-------------------------------------------------------------------
552 proc Libr_do_StatusLine {type} {
553 global ascLibrVect
554 set moduleinfo [libr_moduleinfo [libr_query -findtype -type $type]]
555 set filename [lindex $moduleinfo 1]
556 set ascLibrVect(selectedtype) $type
557 set ascLibrVect(entryline) "$type IN "
558 append ascLibrVect(entryline) $filename
559 }
560
561 #
562 # proc Libr_updatetype {modname typename}
563 #-------------------------------------------------------------------
564 # stuff module contents into typebox. overwritten modules appear empty
565 # set status line. If typename is provided, highlight that type.
566 #-------------------------------------------------------------------
567 proc Libr_updatetype {modname {typename ""}} {
568
569 global ascLibrVect
570 set typelist [lsort [libr_types_in_module $modname]];
571 ascclearlist $ascLibrVect(typeBox);
572 if {[llength $typelist] == 0} {
573 return;
574 }
575 foreach type $typelist {
576 $ascLibrVect(typeBox) insert end $type;
577 }
578 if {$typename != ""} {
579 set ndx [lsearch $typelist $typename]
580 $ascLibrVect(typeBox) see $ndx
581 $ascLibrVect(typeBox) selection set $ndx
582 Libr_do_StatusLine $typename
583 }
584 }
585
586 #
587 # proc Libr_do_ModuleBox {ndx}
588 #-------------------------------------------------------------------
589 # If c library list size nonzero, transforms listbox index to c index
590 # and stuffs typebox accordingly.
591 # A little math required as the list is displayed in
592 # the reverse order or which it is stored internally.
593 # Here ndx is the unadjusted listbox index. The int_ndx is short for
594 # internal index (in Case you had not figured).
595 #-------------------------------------------------------------------
596 proc Libr_do_ModuleBox {ndx} {
597 global ascLibrVect
598 if {$ndx == ""} {
599 return;
600 }
601 if {[$ascLibrVect(moduleBox) size] == 0} {
602 return;
603 }
604 set modulename [$ascLibrVect(moduleBox) get $ndx]
605 Libr_updatetype $modulename
606 }
607
608 #
609 # Libr_Redraw {}
610 #-------------------------------------------------------------------
611 # repaint after restart of libr window
612 #-------------------------------------------------------------------
613 proc Libr_Redraw {} {
614 Libr_updatemod
615 }
616 #
617 # proc Libr_file_get {fullname}
618 #-------------------------------------------------------------------
619 # read a file to library
620 # Now takes an additional arguement which gets passed onto
621 # librread. This flag if set to 0, will disable the parsing
622 # of relations.
623 #-------------------------------------------------------------------
624 proc Libr_file_get {fullname {dorelns "1"}} {
625
626 global ascLibrVect
627 set fullname [file nativename $fullname]
628 global ascLibrVect
629 # puts -nonewline stderr "libr_file_get args: "
630 # puts stderr $fullname
631 if {[file isfile $fullname]} {
632 # puts stdout "File $fullname was found. Now opening...\n";
633 set ascLibrVect(fullfilename) $fullname;
634 #
635 # read and parse the file and update the module and
636 # type boxes. This the only file-based interface call to the compiler
637 # as of jun 1 1997. lets keep it that way.
638 asc_compiler_option -parserWarnings $ascLibrVect(parserWarnings)
639 asc_compiler_option -compilerWarnings $ascLibrVect(compilerWarnings)
640 asc_compiler_option -simplifyRelations $ascLibrVect(simplifyRelations)
641 set modulename [librread $fullname $dorelns];
642 Libr_updatemod;
643 Libr_updatehidden;
644 Libr_updatetype $modulename;
645 #
646 # set up the status line. and select the
647 # main module that was opened.
648 set ascLibrVect(entryline) ""
649 Libr_ModuleBoxSelect $modulename;
650 HUB_Message_to_HUB SOURCEREAD $fullname
651 return 0;
652 } else {
653 set errmsg "File\n"
654 append errmsg $fullname
655 append errmsg "\n not found!"
656 puts stderr $errmsg
657 Script_Raise_Alert $errmsg "File Error"
658 return 1;
659 }
660 }
661
662 #
663 # proc Libr_do_read {}
664 #-------------------------------------------------------------------
665 # libr read button
666 #-------------------------------------------------------------------
667 proc Libr_do_read {} {
668 global ascLibrVect ascGlobalVect asc_tkfbox
669 set defaultname [file dirname "$ascLibrVect(fullfilename)"]
670 if {$defaultname == "."} { set defaultname [pwd]}
671 set asc_tkfbox(otherdirs) $ascGlobalVect(librarypathdirs)
672
673 set fullname [tk_getOpenFile \
674 -defaultextension "" \
675 -filetypes $ascLibrVect(filetypes) \
676 -initialdir $defaultname \
677 -title {Read Ascend IV atoms/models} \
678 -parent .library]
679
680 if {$fullname == "" || [file isdirectory $fullname]} {
681 if {!$asc_tkfbox(cancelled)} {
682 tk_dialog .fileerr FYI \
683 "\"$fullname\" cannot be read." "" 0 OK
684 }
685 return
686 }
687 if {[file extension $fullname] != ""} {
688 set ascLibrVect(lastreadextension) [file extension $fullname]
689 ascresort_filetypes ascLibrVect lastreadextension
690 lappend ascGlobalVect(librarypathdirs) [file dirname $fullname]
691 }
692 Libr_file_get $fullname
693 }
694
695
696 #
697 # proc Libr_updatemod
698 #-------------------------------------------------------------------
699 # stuff module box in library from c struct
700 #-------------------------------------------------------------------
701 proc Libr_updatemod {} {
702 global ascLibrVect
703 set modulelist [lsort -dictionary [libr_query -modulelist -mtype 0]];
704 ascclearlist $ascLibrVect(moduleBox);
705 if {[llength $modulelist] == 0} {
706 return;
707 }
708 foreach module $modulelist {
709 $ascLibrVect(moduleBox) insert end $module;
710 }
711 }
712
713 #
714 # proc newraise {w}
715 #-------------------------------------------------------------------
716 # raise a window, deiconifying if need be -- uses raise.
717 #-------------------------------------------------------------------
718 proc newraise {w} {
719 if {![winfo exists $w]} {
720 return
721 }
722 if {![winfo ismapped $w]} {
723 switch $w {
724 {.browser} {Toggle_Remote ascBrowVect}
725 {.units} {Toggle_Remote ascUnitVect}
726 {.solver} {Toggle_Remote ascSolvVect}
727 {.library} {Toggle_Remote ascLibrVect}
728 {.display} {Toggle_Remote ascDispVect}
729 {.toolbox} {Toggle_Remote ascToolVect}
730 {.probe} {Toggle_Remote ascProbVect}
731 default {wm deiconify $w}
732 }
733 } else {
734 raise $w
735 }
736 }
737
738 #
739 # proc Libr_do_compile {}
740 #-------------------------------------------------------------------
741 # library create compile button
742 # For ease of code reading this procedure is now in the file SimsProc.tcl.
743 #-------------------------------------------------------------------
744
745 # internal use only
746 # proc Libr_do_FindFuzzy_ftmessage {}
747 #-------------------------------------------------------------------
748 #-------------------------------------------------------------------
749 proc Libr_do_FindFuzzy_ftmessage {} {
750 global AscMonoEntry1
751 set help "Enter a name of the sort of thing you want,"
752 append help " and this finds reasonable matches for it."
753 append help " You can use * to match any characters or ? to match a "
754 append help " single character."
755 if {$AscMonoEntry1(button)==3} {
756 Script_Raise_Alert $help "Find type by fuzzy name"
757 return 1
758 }
759 }
760
761 # internal use only
762 # proc Libr_do_FindAtom_message {}
763 #-------------------------------------------------------------------
764 #-------------------------------------------------------------------
765 proc Libr_do_FindAtom_message {} {
766 global AscMonoEntry1
767 set help "Enter the units you want in a real,"
768 append help " and this finds matching atoms and real_constants."
769 append help " This works better when atoms.a4l is loaded."
770 if {$AscMonoEntry1(button)==3} {
771 Script_Raise_Alert $help "Find atoms by their units"
772 return 1
773 }
774 }
775
776 #
777 # proc Libr_do_FindAtom {}
778 #-------------------------------------------------------------------
779 # The library find ATOM button. This button will take the units given
780 # and search the entire type library for matching atoms
781 #-------------------------------------------------------------------
782 proc Libr_do_FindAtom {} {
783 global ascLibrVect
784 global AscMonoEntry1
785 if {[$ascLibrVect(moduleBox) size] == 0 } {
786 return 1;
787 }
788 #
789 # Grab the units from the user
790 #
791 set AscMonoEntry1(font) $ascLibrVect(font)
792 set target_units [lindex [VShowWindow.ascMonoEntry1 \
793 "Match units?" \
794 "600x100[setpos .library 100 50]" \
795 $ascLibrVect(target_units) \
796 "" \
797 Libr_do_FindAtom_message] \
798 1]
799 if {$AscMonoEntry1(button)==2} {
800 return 1
801 }
802 if {[catch {set atoms [u_get_atoms $target_units]} err]} {
803 Script_Raise_Alert "Unable to match $target_units. $err" " failure"
804 return 1
805 }
806 set ascLibrVect(target_units) $target_units
807 if {[llength $atoms] == 0} {
808 Script_Raise_Alert \
809 "No matches of $target_units found. You need to define a new ATOM." \
810 " failure"
811 return 1
812 }
813 Libr_Setup_UnitsMatches $target_units $atoms
814 }
815 #
816 # proc Libr_do_FindFuzzy {}
817 #-------------------------------------------------------------------
818 # The library find button. This button will take the name given
819 # and search the entire type library for it ignoring Case and
820 # leading/trailing characters and _s.
821 #-------------------------------------------------------------------
822 proc Libr_do_FindFuzzy {} {
823 global ascLibrVect
824 global AscMonoEntry1
825 if {[$ascLibrVect(moduleBox) size] == 0 } {
826 return 1;
827 }
828 #
829 # Grab the name of the type from the user
830 #
831 set AscMonoEntry1(font) $ascLibrVect(font)
832 set target_type [lindex [VShowWindow.ascMonoEntry1 \
833 "Match pattern?" \
834 "600x100[setpos .library 100 50]" \
835 $ascLibrVect(target_type) \
836 "" \
837 Libr_do_FindFuzzy_ftmessage] \
838 1]
839 if {$AscMonoEntry1(button)==2} {
840 return 1
841 }
842 if {$target_type == ""} {
843 return 1
844 }
845 set types [libr_query -catalog]
846 set base [stringcompact [string tolower $target_type]]
847 set matches ""
848 foreach i $types {
849 set t [string tolower $i]
850 # check against user wildcards
851 if {[string match $base $t]} {
852 lappend matches $i
853 continue
854 }
855 # check against embedded possibility
856 if {[string match *$base* $t]} {
857 lappend matches $i
858 continue
859 }
860 # check against embedded possibility
861 if {[string match *$base* $t]} {
862 lappend matches $i
863 continue
864 }
865 regsub -all -- _ $t "" noub
866 # check against embedded possibility
867 if {[string match $base $noub]} {
868 lappend matches $i
869 continue
870 }
871 # check against embedded possibility
872 if {[string match *$base* $noub]} {
873 lappend matches $i
874 continue
875 }
876 }
877 if {$matches == ""} {
878 Script_Raise_Alert "No matches of $target_type found." "Fuzz failure"
879 return 1
880 }
881 Libr_Setup_FuzzyMatches $target_type $matches
882 }
883
884 # internal use only
885 # proc Libr_do_FindType_ftmessage {}
886 #-------------------------------------------------------------------
887 #-------------------------------------------------------------------
888 proc Libr_do_FindType_ftmessage {} {
889 global AscMonoEntry1
890 set help "Enter the exact name of the type you want,"
891 append help " and this takes you to its module"
892 if {$AscMonoEntry1(button)==3} {
893 Script_Raise_Alert $help "Find type by name"
894 return 1
895 }
896 }
897 #
898 # proc Libr_do_FindType {}
899 #-------------------------------------------------------------------
900 # The library find button. This button will take the name selected
901 # and search the entire type library for it. When found will focus
902 # the selection in the typebox onto the name of the type found.
903 # the module associated with the type will also be focused in the
904 # ModuleBox.
905 #-------------------------------------------------------------------
906 proc Libr_do_FindType {} {
907 global ascLibrVect
908 global AscMonoEntry1
909 if {[$ascLibrVect(moduleBox) size] == 0 } {
910 return 1;
911 }
912 #
913 # Grab the name of the type from the user
914 #
915 set target_type [lindex [VShowWindow.ascMonoEntry1 \
916 "Find Which Type?" \
917 "400x100[setpos .library 100 50]" \
918 $ascLibrVect(target_type) \
919 "" \
920 Libr_do_FindType_ftmessage] \
921 1]
922 if {$AscMonoEntry1(button)==2} {return 1}
923 if {$target_type ==""} { return 1 }
924 Libr_FocusType $target_type
925 }
926
927 proc Libr_FocusType {target_type} {
928 global ascLibrVect
929 set ascLibrVect(target_type) $target_type;
930 #
931 # Call the c-routine to get the filename
932 #
933 set nok [catch {libr_query -findtype -type $target_type} name_or_errmsg]
934 if {$nok} {
935 Script_Raise_Alert $name_or_errmsg "Find Error";
936 return;
937 }
938 set modulename $name_or_errmsg
939 #
940 # Now that we have the associated file name, then set it in
941 # C-land, and prepare to update the boxes. We wont use the
942 # normal Libr_update type procs as we need to do some focusing, and
943 # we dont want to call "updatetype" twice; updateype is fairly expensive.
944 #
945 Libr_updatetype $modulename $target_type
946 Libr_ModuleBoxSelect $modulename
947 }
948
949 #
950 # proc Libr_Update_File_Buttons {}
951 #-------------------------------------------------------------------------
952 # This procedure is bound to the File Menu Button.
953 # Used for enabling/disabling the items depending on the whether selections
954 # exist within the ascLibrVect(typeBox)
955 # selected instance
956 #-------------------------------------------------------------------------
957 proc Libr_Update_File_Buttons {} {
958 # Read file entry is always valid, so just return
959 #global ascLibrVect
960 #set mb .library.menubar.file
961 return
962 }
963
964 # proc LibrDeleteAllState {}
965 #-------------------------------------------------------------------------
966 # returns the state for the delete all menu button.
967 # Basically requires that some modules must exist.
968 #-------------------------------------------------------------------------
969 proc LibrDeleteAllState {} {
970 global ascLibrVect
971 if {[$ascLibrVect(moduleBox) size] > 0} {
972 return normal
973 }
974 return disabled
975 }
976
977 #
978 # proc Libr_Update_Edit_Buttons {}
979 #-------------------------------------------------------------------------
980 # For disabling the Edit Menu Button
981 # Used for enabling/disabling the items depending on the whether
982 # files exist within the ascLibrVect(moduleBox)
983 #-------------------------------------------------------------------------
984 proc Libr_Update_Edit_Buttons {} {
985 global ascLibrVect
986 set mb .library.menubar.edit
987
988 foreach i {0 1 3 4} {
989 $mb entryconfigure $i -state disabled;
990 }
991
992 # Create simulation
993 if {[$ascLibrVect(typeBox) curselection] != ""} {
994 $mb entryconfigure 0 -state normal;
995 }
996 # Suggest methods
997 set type "$ascLibrVect(selectedtype)"
998 if {$type != ""} {
999 $mb entryconfigure 1 -state normal;
1000 }
1001 # Delete simulation
1002 if {[$ascLibrVect(simsBox) curselection] != ""} {
1003 $mb entryconfigure 3 -state normal
1004 }
1005 # Delete all types
1006 $mb entryconfigure 4 -state [LibrDeleteAllState]
1007 }
1008
1009 #
1010 # proc Libr_Update_Display_Buttons {}
1011 #-------------------------------------------------------------------------
1012 # This procedure is bound to the Display Menu Button.
1013 # Used for enabling/disabling the items depending on the whether selections
1014 # exist within the ascLibrVect(typeBox) selected instance.
1015 # The enabling/disabling of the Hide/Unhide Type depends also of the
1016 # current status of the type selected. i.e. only the appropriate item
1017 # will be enabled.VRR
1018 #-------------------------------------------------------------------------
1019 proc Libr_Update_Display_Buttons {} {
1020 global ascLibrVect
1021 set mb .library.menubar.display
1022
1023 # External Functions and Hide/Show Fundamentals are always active
1024 $mb entryconfigure 3 -state normal
1025 $mb entryconfigure 6 -state normal
1026
1027 # Disable everything else
1028 $mb entryconfigure 0 -state disabled;
1029 $mb entryconfigure 1 -state disabled;
1030 $mb entryconfigure 2 -state disabled;
1031 $mb entryconfigure 4 -state disabled;
1032 $mb entryconfigure 5 -state disabled;
1033
1034 # If no type is selected, we are done
1035 if {[$ascLibrVect(typeBox) curselection] == ""} {
1036 return
1037 }
1038
1039 set type "$ascLibrVect(selectedtype)"
1040 if {$type != ""} {
1041 $mb entryconfigure 0 -state normal
1042 $mb entryconfigure 1 -state normal
1043 $mb entryconfigure 2 -state normal
1044
1045 # To check if a type is being shown
1046 set is_type_shown [libr_type_is_shown $type]
1047 if {$is_type_shown} {
1048 $mb entryconfigure 4 -state normal;
1049 } else {
1050 $mb entryconfigure 5 -state normal;
1051 }
1052 }
1053 }
1054
1055 #
1056 # proc Libr_Update_Find_Buttons {}
1057 #-------------------------------------------------------------------------
1058 # This procedure is bound to the Find Menu Button.
1059 # Used for enabling/disabling the items depending on the whether
1060 # files exist within the ascLibrVect(moduleBox)
1061 #-------------------------------------------------------------------------
1062 proc Libr_Update_Find_Buttons {} {
1063 global ascLibrVect
1064 set mb .library.menubar.find
1065
1066 if {[$ascLibrVect(moduleBox) size] == 0} {
1067 $mb entryconfigure 0 -state disabled;
1068 $mb entryconfigure 1 -state disabled;
1069 $mb entryconfigure 2 -state disabled;
1070 } else {
1071 $mb entryconfigure 0 -state normal;
1072 $mb entryconfigure 1 -state normal;
1073 $mb entryconfigure 2 -state normal;
1074 }
1075 if {[$ascLibrVect(simsBox) curselection] == ""} {
1076 $mb entryconfigure 3 -state disabled;
1077 } else {
1078 $mb entryconfigure 3 -state normal;
1079 }
1080 }
1081
1082
1083 #
1084 # proc Libr_Update_View_Buttons {}
1085 #-------------------------------------------------------------------------
1086 # This procedure is bound to the View Menu Button.
1087 # Used for enabling/disabling the items depending on the whether
1088 # the ascGlobalVect(saveoptions) is on or off
1089 #-------------------------------------------------------------------------
1090 proc Libr_Update_View_Buttons {} {
1091 global ascLibrVect ascGlobalVect
1092
1093 set mb .library.menubar.view
1094
1095 if {$ascGlobalVect(saveoptions) == 0} {
1096 $mb entryconfigure 2 -state disabled
1097 } else {
1098 $mb entryconfigure 2 -state normal
1099 }
1100
1101 }
1102
1103 #
1104 # proc Libr_Update_Export_Buttons {}
1105 #-------------------------------------------------------------------------
1106 # This procedure is bound to the Export Menu Button.
1107 # Used for enabling/disabling the items depending on the whether
1108 # simulations exist within the ascLibrVect(simsBox)
1109 #-------------------------------------------------------------------------
1110 proc Libr_Update_Export_Buttons {} {
1111 global ascLibrVect
1112 set mb .library.menubar.export
1113
1114 if {[$ascLibrVect(simsBox) curselection] == ""} {
1115 $mb entryconfigure 0 -state disabled;
1116 $mb entryconfigure 1 -state disabled;
1117 $mb entryconfigure 2 -state disabled;
1118 } else {
1119 $mb entryconfigure 0 -state normal;
1120 $mb entryconfigure 1 -state normal;
1121 $mb entryconfigure 2 -state normal;
1122 }
1123 }
1124
1125 #
1126 # proc Libr_do_Help {}
1127 # proc Libr_do_BindHelp
1128 #-------------------------------------------------------------------
1129 # the library help buttons
1130 #-------------------------------------------------------------------
1131 proc Libr_do_Help {} {
1132 Help_button library
1133 }
1134 proc Libr_do_BindHelp {} {
1135 Help_button library.help onlibrary
1136 }
1137
1138 #
1139 proc Libr_hide_type {type} {
1140 if {[catch {libr_hide_type $type} msg]} {
1141 Script_Raise_Alert "For >$type<:\n $msg" "Hide error"
1142 }
1143 }
1144 # proc Libr_do_Hide_Type {}
1145 #-------------------------------------------------------------------
1146 # this procedure calls Libr_hide_type for the type selected by the
1147 # user. It will cause that all of the instances of such a type
1148 # will be ignored for browsing purposes.
1149 #-------------------------------------------------------------------
1150 proc Libr_do_Hide_Type {} {
1151 global ascLibrVect
1152 set type "$ascLibrVect(selectedtype)"
1153 if {$type == ""} {
1154 return;
1155 }
1156
1157 if {[catch {Libr_hide_type $type} msg]} {
1158 Script_Raise_Alert "For >$type<:\n $msg" "Hide error"
1159 }
1160 Libr_recordhide add $type
1161 HUB_Message_to_HUB TYPEHIDDEN
1162 Libr_Update_Display_Buttons;
1163 return
1164 }
1165
1166 # proc Libr_do_Hide_Type_Refinements {}
1167 #-------------------------------------------------------------------
1168 # this procedure calls Libr_hide_type for the type selected by the
1169 # user. It will cause that all of the instances of such a type
1170 # will be ignored for browsing purposes.
1171 # It also hides all refinements.
1172 #-------------------------------------------------------------------
1173 proc Libr_do_Hide_Type_Refinements {} {
1174 global ascLibrVect
1175 set type "$ascLibrVect(selectedtype)"
1176 if {$type == ""} {
1177 return;
1178 }
1179 set list [drefines_meall $type]
1180 lappend list $type
1181 foreach i $list {
1182 Libr_hide_type $i
1183 Libr_recordhide add $i
1184 }
1185 HUB_Message_to_HUB TYPEHIDDEN
1186 Libr_Update_Display_Buttons;
1187 return
1188 }
1189
1190 # proc Libr_do_UnHide_Type {}
1191 #-------------------------------------------------------------------
1192 # this procedure calls libr_unhide_type for the type selected by the
1193 # user. It will cause that all of the instances of such a type
1194 # (previously hidden) will be considered for browsing purposes.
1195 #-------------------------------------------------------------------
1196 proc Libr_do_UnHide_Type {} {
1197 global ascLibrVect
1198 set type "$ascLibrVect(selectedtype)"
1199 if {$type == ""} {
1200 return;
1201 }
1202 libr_unhide_type $type
1203 Libr_recordhide delete $type
1204 HUB_Message_to_HUB TYPEHIDDEN
1205 Libr_Update_Display_Buttons;
1206 return
1207 }
1208 #
1209 # proc Libr_do_UnHide_Type_Refinements {}
1210 #-------------------------------------------------------------------
1211 # this procedure calls libr_unhide_type for the type selected by the
1212 # user. It will cause that all of the instances of such a type
1213 # (previously hidden) will be considered for browsing purposes.
1214 #-------------------------------------------------------------------
1215 proc Libr_do_UnHide_Type_Refinements {} {
1216 global ascLibrVect
1217 set type "$ascLibrVect(selectedtype)"
1218 if {$type == ""} {
1219 return;
1220 }
1221 set list [drefines_meall $type]
1222 lappend list $type
1223 foreach i $list {
1224 libr_unhide_type $i
1225 Libr_recordhide delete $i
1226 }
1227 HUB_Message_to_HUB TYPEHIDDEN
1228 Libr_Update_Display_Buttons;
1229 return
1230 }
1231
1232
1233 # proc Libr_do_Hide_Fundamentals {}
1234 #-------------------------------------------------------------------
1235 # Allows to hide/unhide fundamental type whose definitions are not
1236 # displayed as included in some library.
1237 #-------------------------------------------------------------------
1238 proc Libr_do_Hide_Fundamentals {} {
1239 Libr_Setup_FundamentalsBox
1240 return
1241 }
1242
1243 # proc Libr_Setup_FundamentalsBox
1244 #-------------------------------------------------------------------------
1245 # Sets up the box of fundamental types so that the hidding/unhidding of
1246 # fundamentals may be done.
1247 #-------------------------------------------------------------------------
1248 proc Libr_Setup_FundamentalsBox {} {
1249
1250 global ascListSelectB1Box ascLibrVect
1251 set list ""
1252 catch {set list [libr_query -fundamentals]}
1253
1254 set ascListSelectB1Box(grab) 0
1255 set ascListSelectB1Box(btn2name) TagAll
1256 set ascListSelectB1Box(btn3name) Hide
1257 set ascListSelectB1Box(btn4name) UnHide
1258 set ascListSelectB1Box(btn5name) ""
1259 set ascListSelectB1Box(btn2destroy) 0
1260 set ascListSelectB1Box(btn3destroy) 0
1261 set ascListSelectB1Box(btn4destroy) 0
1262 set ascListSelectB1Box(btn2command) Libr_SelectAll
1263 set ascListSelectB1Box(btn3command) Libr_HideListSelect
1264 set ascListSelectB1Box(btn4command) Libr_UnHideListSelect
1265 set ascListSelectB1Box(title) "Show/Hide Fundamentals"
1266 set ascListSelectB1Box(toplevelname) ".librfund"
1267 set ascListSelectB1Box(selectmode) extended
1268 set ascListSelectB1Box(font) $ascLibrVect(font)
1269 set ascListSelectB1Box(headline) "Fundamental Types:"
1270
1271 if {$list==""} {puts stderr "fundamental types not found" ; return}
1272 set button [AscListSelectB1Box $list \
1273 250x240[setpos .library 150 20]]
1274 }
1275
1276 # internal use only
1277 # proc Libr_FuzzRefines {}
1278 #-------------------------------------------------------------------
1279 #-------------------------------------------------------------------
1280 proc Libr_FuzzRefines {} {
1281 global ascListSelectB1Box
1282 set type $ascListSelectB1Box(itemselected)
1283 Type_OpenTree $type
1284 }
1285
1286 # internal use only
1287 # proc Libr_FuzzCode {}
1288 #-------------------------------------------------------------------
1289 #-------------------------------------------------------------------
1290 proc Libr_FuzzCode {} {
1291 global ascListSelectB1Box
1292 set type $ascListSelectB1Box(itemselected)
1293 Libr_FocusType $type
1294 Disp_do_ShowCode $type
1295 }
1296
1297 # internal use only
1298 # proc Libr_FuzzCompile {}
1299 #-------------------------------------------------------------------
1300 #-------------------------------------------------------------------
1301 proc Libr_FuzzCompile {} {
1302 global ascListSelectB1Box
1303 set type $ascListSelectB1Box(itemselected)
1304 Libr_FocusType $type
1305 Libr_do_compile
1306 }
1307
1308 # proc Libr_Setup_FuzzyMatches
1309 #-------------------------------------------------------------------------
1310 # Sets up the box of matching types so that they may be used.
1311 #-------------------------------------------------------------------------
1312 proc Libr_Setup_FuzzyMatches {query list} {
1313
1314 global ascListSelectB1Box ascLibrVect
1315
1316 set ascListSelectB1Box(grab) 0
1317 set ascListSelectB1Box(btn2name) Code
1318 set ascListSelectB1Box(btn3name) Refines
1319 set ascListSelectB1Box(btn4name) Compile
1320 set ascListSelectB1Box(btn5name) ""
1321 set ascListSelectB1Box(btn2destroy) 0
1322 set ascListSelectB1Box(btn3destroy) 0
1323 set ascListSelectB1Box(btn4destroy) 0
1324 set ascListSelectB1Box(btn2command) Libr_FuzzCode
1325 set ascListSelectB1Box(btn3command) Libr_FuzzRefines
1326 set ascListSelectB1Box(btn4command) Libr_FuzzCompile
1327 set ascListSelectB1Box(font) $ascLibrVect(font)
1328 set ascListSelectB1Box(title) "Fuzzy matches"
1329 set ascListSelectB1Box(toplevelname) .librfuzz
1330 set ascListSelectB1Box(selectmode) single
1331 set ascListSelectB1Box(headline) $query
1332
1333 set button [AscListSelectB1Box $list 350x240[setpos .library 150 20]]
1334 }
1335
1336 # proc Libr_Setup_UnitsMatches
1337 #-------------------------------------------------------------------------
1338 # Sets up the box of matching atoms so that they may be used.
1339 #-------------------------------------------------------------------------
1340 proc Libr_Setup_UnitsMatches {query list} {
1341
1342 global ascListSelectB1Box ascLibrVect
1343
1344 set ascListSelectB1Box(grab) 0
1345 set ascListSelectB1Box(btn2name) Code
1346 set ascListSelectB1Box(btn3name) Refines
1347 set ascListSelectB1Box(btn4name) ""
1348 set ascListSelectB1Box(btn5name) ""
1349 set ascListSelectB1Box(btn2destroy) 0
1350 set ascListSelectB1Box(btn3destroy) 0
1351 set ascListSelectB1Box(btn4destroy) 0
1352 set ascListSelectB1Box(btn2command) Libr_FuzzCode ;# works for atoms too
1353 set ascListSelectB1Box(btn3command) Libr_FuzzRefines ;# works for atoms too
1354 set ascListSelectB1Box(font) $ascLibrVect(font)
1355 set ascListSelectB1Box(title) "real and real_constant matching"
1356 set ascListSelectB1Box(toplevelname) .libratomunits
1357 set ascListSelectB1Box(selectmode) single
1358 set ascListSelectB1Box(headline) $query
1359
1360 set button [AscListSelectB1Box $list 350x240[setpos .library 150 20]]
1361 }
1362
1363 #
1364 # proc Libr_SelectAll {{tl ""}}
1365 #-------------------------------------------------------------------------
1366 # select all in the asclistselectb1box associate with tl, or
1367 # select all in the last asclistselectb1box created if tl == ""
1368 #-------------------------------------------------------------------------
1369 proc Libr_SelectAll {{tl ""}} {
1370 AscListSelectB1SelectAll $tl
1371 }
1372
1373 #
1374 # proc Libr_HideListSelect {}
1375 #-------------------------------------------------------------------------
1376 # for all of the fundamental types selected, it calls Libr_hide_type.
1377 # It will cause that all of the instances of such types
1378 # will be ignored for browsing purposes.
1379 #-------------------------------------------------------------------------
1380 proc Libr_HideListSelect {} {
1381 global ascListSelectB1Box
1382 set list $ascListSelectB1Box(itemselected)
1383 foreach i $list {
1384 Libr_hide_type $i
1385 Libr_recordhide add $i
1386 }
1387 HUB_Message_to_HUB TYPEHIDDEN
1388 Libr_Update_Display_Buttons;
1389 }
1390 #
1391 # proc Libr_UnHideListSelect {}
1392 #-------------------------------------------------------------------------
1393 # for all of the fundamental types selected, it calls libr_unhide_type.
1394 # It will cause that all of the instances of such types
1395 # (previously hidden) will be considered for browsing purposes.
1396 #-------------------------------------------------------------------------
1397 proc Libr_UnHideListSelect {} {
1398 global ascListSelectB1Box
1399 set list $ascListSelectB1Box(itemselected)
1400 foreach i $list {
1401 libr_unhide_type $i
1402 Libr_recordhide delete $i
1403 }
1404 HUB_Message_to_HUB TYPEHIDDEN
1405 Libr_Update_Display_Buttons;
1406 }
1407
1408
1409 # proc Libr_Get_CurrentSim
1410 #------------------------------------------------------------------------
1411 # The following code grabs the currently selected simulation in the
1412 # sims listbox in the Library window. It will return the empty string,
1413 # or the simulation name
1414 #------------------------------------------------------------------------
1415 proc Libr_Get_CurrentSim {} {
1416 global ascLibrVect
1417 set ndx [$ascLibrVect(simsBox) curselection];
1418 if {$ndx == ""} {
1419 return "";
1420 }
1421 return [lindex [$ascLibrVect(simsBox) get $ndx] 0];
1422 }
1423
1424 #
1425 # proc Sims_update_SimsBox
1426 #------------------------------------------------------------------------
1427 # stuff sims from c structure, autoselect last compiled
1428 #------------------------------------------------------------------------
1429 proc Sims_update_SimsBox {} {
1430 global ascSimsVect;
1431 global ascLibrVect
1432
1433 set simlist [slist];
1434 set len [llength $simlist]
1435 if {$len == 0} {
1436 set ascSimsVect(selectedsim) "";
1437 return;
1438 }
1439 ascclearlist $ascLibrVect(simsBox);
1440 foreach sim $simlist {
1441 set sim_type [simtype $sim]
1442 $ascLibrVect(simsBox) insert end "$sim IS_A $sim_type";
1443 }
1444 set ndx [lsearch $simlist $ascSimsVect(target_instance)]
1445 $ascLibrVect(simsBox) select set $ndx
1446 }
1447
1448 #
1449 # proc Sims_CreateInstance {tinst type}
1450 #------------------------------------------------------------------------
1451 # Creates an instance. returns 1 if failed.,0 if succeeded.
1452 # Tests for uniqueness in tcl and in C. In C so commandline
1453 # create works, and in tcl so we can popup a box based on a test.
1454 # tinst is the target instancee. type is the type of instance.
1455 #------------------------------------------------------------------------
1456 proc Sims_CreateInstance {tinst type} {
1457 global ascSimsVect ascLibrVect
1458
1459 if {$tinst == ""} {
1460 Script_Raise_Alert "You must specify\nan instance name." "Create Error";
1461 return 1;
1462 }
1463 if {![sim_unique $tinst]} {
1464 Script_Raise_Alert "Simulation with name\n$tinst already exists!" \
1465 "Create Error"
1466 return 1;
1467 }
1468 asc_compiler_option -useCopyAnon $ascLibrVect(useCopyAnon)
1469 set nok [catch {
1470 sim_instantiate $tinst $type -m $ascLibrVect(autorun)
1471 } err_msg]
1472 if {$nok} {
1473 puts stderr $err_msg
1474 Script_Raise_Alert \
1475 "CreateInstance\n $tinst failed.\n$err_msg" \
1476 "Create Error"
1477 return 1;
1478 }
1479 return 0;
1480 }
1481
1482 #
1483 #
1484 proc Library_Handle_Configure {inst type} {
1485 # C compiler already does it.
1486 return
1487 }
1488 proc Libr_do_SaveOption {} {
1489 View_Save_Window_Options library
1490 }
1491
1492 #
1493 # proc Sims_InquireInstStatus {}
1494 #------------------------------------------------------------------------
1495 # this takes care of everything required to make a new sim
1496 # ascSimsVect(instanceType) is assumed to have been set.
1497 # type -- the type of the instance.
1498 # tinst -- the target instance.
1499 #------------------------------------------------------------------------
1500 proc Sims_InquireInstStatus {type} {
1501 global ascSimsVect
1502 global AscMonoEntry1
1503
1504 set tinst [lindex [VShowWindow.ascMonoEntry1 \
1505 "Simulation name:" "400x100[setpos .library 50 50]" \
1506 $ascSimsVect(target_instance) "" ""] 1]
1507 if {$AscMonoEntry1(button)==2} {return 1}
1508 if {$AscMonoEntry1(button)==3} {
1509 set expl {Enter a name for the new simulation. No "." or "[" or "]" or "'" allowed.}
1510 Script_Raise_Alert $expl "Name help:"
1511 return 1
1512 }
1513 if {$tinst ==""} {
1514 Script_Raise_Alert "You must specify an instance name." "Create Error";
1515 return 1;
1516 }
1517 # cache the instance name for the next call
1518 set ascSimsVect(target_instance) [string trim $tinst]
1519 set result [Sims_CreateInstance $tinst $type];
1520 return $result;
1521 }
1522
1523 #
1524 # proc Libr_do_compile {}
1525 #-------------------------------------------------------------------
1526 # library create compile button
1527 # For ease of code reading this code is now in the
1528 # file SimsProc.tcl.
1529 #-------------------------------------------------------------------
1530 proc Libr_do_compile {} {
1531
1532 global ascSimsVect ascLibrVect
1533 set type $ascLibrVect(selectedtype)
1534 if {$type == ""} {
1535 return;
1536 }
1537 if {[Sims_InquireInstStatus $type] != 0} {
1538 return;
1539 }
1540 newraise $ascSimsVect(windowname);
1541 HUB_Message_to_HUB SIMCREATED $ascSimsVect(target_instance) $type
1542 Sims_update_SimsBox ;
1543 }
1544
1545 #
1546 # proc Sims_Redraw {}
1547 #------------------------------------------------------------------------
1548 # standard Proc to restart after interface reload
1549 #------------------------------------------------------------------------
1550 proc Sims_Redraw {} {
1551 Sims_update_SimsBox
1552 }
1553
1554
1555 #
1556 # proc Sims_Export2Browser {sim}
1557 #------------------------------------------------------------------------
1558 # just what it says
1559 #------------------------------------------------------------------------
1560 proc Sims_Export2Browser {sim} {
1561
1562 global ascSimsVect ascLibrVect
1563 global ascBrowVect
1564
1565 if {$sim == ""} {
1566 return;
1567 } else {
1568 # set the external sim -- used ONLY for bringing up the
1569 # name of the simulation in the entry box, for subsequent
1570 # calls.
1571 set ascBrowVect(currentsim) $sim;
1572 # set the internal sim -- this is the important one.
1573 if {[bnumpendings simulation $sim] > 0} {
1574 Script_Raise_Alert \
1575 "Simulation $sim\nhas pending instances.\n Please correct code\nbefore \
1576 proceeding." "Create Error"
1577 puts "\n--------------------------------------------------------------\n\
1578 Pendings statements for simulation $sim\n"
1579 bwritependings $sim
1580 puts "\n--------------------------------------------------------------"
1581 }
1582 Script_ClearInterrupt
1583 BROWSE $sim
1584 }
1585 }
1586
1587 proc Sims_do_Export2Browser {} {
1588 set sim [Libr_Get_CurrentSim]
1589 if {$sim == ""} {return}
1590 Sims_Export2Browser $sim
1591 }
1592
1593 #
1594 # proc Sims_Delete {sim}
1595 #------------------------------------------------------------------------
1596 # This function deletes a simulation. It will send a message to the HUB
1597 # that the named simulation is about to be destroyed. This will tell
1598 # everyone to take their hands off, and to clean up the windows displaying
1599 # information related to the sim.
1600 # Do not call sim_destroy from _anywhere_ else.
1601 #------------------------------------------------------------------------
1602 proc Sims_Delete {sim} {
1603 if {$sim != "" && "[lsearch -exact [slist] $sim]" != "-1"} {
1604 HUB_Message_to_HUB "SIMDELETED" $sim;
1605 sim_destroy $sim;
1606 } else {
1607 if {$sim != ""} {
1608 puts "Simulation $sim doesn't exist or already deleted"
1609 }
1610 }
1611 }
1612
1613 #
1614 # proc Sims_do_Delete {args}
1615 #------------------------------------------------------------------------
1616 # This is the command bound to the simulation delete menubutton. It grabs
1617 # the currently selected simulation to be deleted and passes it to
1618 # Sims_Delete to do the real work. It then cleans up its listbox.
1619 # This function asks for confirmation unless `args' is non-empty
1620 #------------------------------------------------------------------------
1621 proc Sims_do_Delete {args} {
1622 # The command bound to the MenuuButton
1623 global ascLibrVect;
1624
1625 set ndx [$ascLibrVect(simsBox) curselection];
1626 if {$ndx == ""} {
1627 return;
1628 }
1629 set sim [Libr_Get_CurrentSim];
1630
1631 if {$args == ""} {
1632 set position [setpos $ascLibrVect(windowname) 40 60]
1633 set res [VShowWindow.ascConfirm "220x50$position" "Delete $sim"]
1634 if {$res != 1} {
1635 return
1636 }
1637 }
1638
1639 Sims_Delete $sim
1640 $ascLibrVect(simsBox) delete $ndx $ndx
1641 }
1642
1643 #
1644 # proc Sims_Pendings_To_Stdout {}
1645 #------------------------------------------------------------------------
1646 # This command is bound to a menu item in the Sims window and will write
1647 # the pendings instance list to stdout.
1648 #------------------------------------------------------------------------
1649 proc Sims_Pendings_To_Stdout {} {
1650
1651 set sim [Libr_Get_CurrentSim]
1652 if {$sim == ""} {return}
1653 if {0 && [bnumpendings simulation $sim] > 3} {
1654 # here we should be checking the number of pendings
1655 # and asking for the filename to write them to if too big.
1656 simlistpending $sim
1657 }
1658 simlistpending $sim
1659 }
1660
1661 #
1662 # proc Sims_Pendings_To_File {}
1663 #------------------------------------------------------------------------
1664 # This command is bound to a menu item in the Sims window and will write
1665 # the pendings instance list to stdout.
1666 #------------------------------------------------------------------------
1667 proc Sims_Pendings_To_File {} {
1668 global ascSimsVect
1669
1670 set sim [Libr_Get_CurrentSim]
1671 if {$sim == ""} {
1672 return;
1673 }
1674 puts [bnumpendings simulation $sim]
1675
1676 set defaultname $ascSimsVect(filename)
1677 set filename [tk_getSaveFile \
1678 -defaultextension "" \
1679 -filetypes $ascSimsVect(filetypes) \
1680 -initialfile $defaultname \
1681 -parent .library \
1682 -title {Write pending file}]
1683
1684 if {$filename == ""} {
1685 return 1;
1686 } {
1687 set ascSimsVect(filename) $filename
1688 simlistpending $sim $filename
1689 puts "Wrote pendings file $filename."
1690 }
1691 }
1692
1693 #
1694 # proc Sims_Export2solver {}
1695 #------------------------------------------------------------------------
1696 # just what it says. needs work. baa
1697 #------------------------------------------------------------------------
1698 proc Sims_Export2Solver {sim} {
1699
1700 if {$sim == ""} {return}
1701 return [Solve_Import_Any $sim]
1702 }
1703
1704 proc Sims_do_Export2Solver {} {
1705 global ascSimsVect
1706 set sim $ascSimsVect(selectedsim)
1707 if {$sim == ""} {
1708 return;
1709 }
1710 Sims_Export2Solver $sim
1711 }
1712
1713 #
1714 # proc Sims_export2probe {}
1715 #------------------------------------------------------------------------
1716 # just what it says. needs work. baa
1717 #------------------------------------------------------------------------
1718 proc Sims_Export2Probe {sim} {
1719 if {$sim == ""} {return}
1720 PROBE ALL $sim
1721 }
1722
1723 proc Sims_do_Export2Probe {} {
1724 set sim [Libr_Get_CurrentSim]
1725 if {$sim == ""} {
1726 return;
1727 }
1728 Sims_Export2Probe $sim
1729 }
1730
1731 #
1732 # proc Sims_HandleInstanceMoved {args}
1733 #------------------------------------------------------------------------
1734 # redraw sims, in Case any types have changed
1735 #------------------------------------------------------------------------
1736 proc Sims_HandleInstanceMoved {args} {
1737 Sims_Redraw
1738 }
1739
1740 #
1741 # proc Sims_HandleTypesDelete {args}
1742 #------------------------------------------------------------------------
1743 # redraw sims, in Case any types have changed
1744 #------------------------------------------------------------------------
1745 proc Sims_HandleTypesDelete {args} {
1746 global ascLibrVect
1747 $ascLibrVect(simsBox) select set 0 end
1748 set sellist [$ascLibrVect(simsBox) curselection]
1749 if {$sellist==""} {return}
1750 foreach i $sellist {
1751 set item [$ascLibrVect(simsBox) get $i]
1752 if {$item!=""} {
1753 set sim [lindex [lindex $item 0] 0];
1754 Sims_Delete $sim
1755 }
1756 }
1757 $ascLibrVect(simsBox) delete 0 end
1758 Sims_Redraw
1759 }
1760
1761 # call the method generation functions and stuff output in the
1762 # display window where user can copy/paste to models file.
1763 proc Libr_SuggestMethods {} {
1764 global ascUtilVect ascDispVect ascLibrVect
1765
1766 set type "$ascLibrVect(selectedtype)"
1767 if {$type == ""} { return }
1768
1769 DispClear;
1770 set outputfile [FileUniqueName "$ascUtilVect(asctmp)/ascsuggmeth"]
1771 set fid [open $outputfile w+]
1772 asc_suggest_methods $fid $type
1773 close $fid
1774 # read chunks of 10k
1775 set fid [open $outputfile r]
1776 while {![eof $fid]} {
1777 $ascDispVect(textBox) insert end [read $fid 10000]
1778 }
1779 close $fid
1780 file delete $outputfile
1781 DispSetEntry "Suggested methods code for $type"
1782 newraise .display
1783 }
1784
1785 proc Libr_File_do_Copy {} {
1786 global ascLibrVect
1787 asc_export_selection $ascLibrVect(entryBox)
1788 event generate $ascLibrVect(entryBox) <<Copy>>
1789 }

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