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

Annotation of /trunk/ascend4/TK/LibraryProc.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (17 years, 8 months ago) by aw0a
File MIME type: text/x-tcl
File size: 57599 byte(s)
Setting up web subdirectory in repository
1 aw0a 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