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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (17 years, 1 month ago) by aw0a
File MIME type: text/x-tcl
File size: 28848 byte(s)
Setting up web subdirectory in repository
1 # GlobalProc.tcl: global commands to do with window management
2 # by Benjamin A. Allan and Kirk A. Abbott
3 # Created: January 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.71 $
6 # Last modified on: $Date: 1998/07/01 09:06:32 $
7 # Last modified by: $Author: ballan $
8 # Revision control file: $RCSfile: GlobalProc.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 ascsetdebug {{on 1}}
31 # -------------------------------------------------------------------------
32 # Note that in the following we see the feature that all tcl procs are
33 # global and that procedures may define procedures.
34 # Use examples:
35 # ascsetdebug 0
36 # this turns debugging spew info off.
37 # ascsetdebug 1
38 # this turns debugging spew info on.
39 # ascsetdebug
40 # this also turns debugging spew on because the DEFAULT given is 1.
41 # -------------------------------------------------------------------------
42 proc ascsetdebug {{on 1}} {
43 if {$on} {
44 proc entertrace {args} {
45 set depth [expr {[info level]-1}]
46 puts "entering [lindex [info level $depth] 0] : $args"
47 }
48 proc leavetrace {args} {
49 set depth [expr {[info level]-1}]
50 puts "leaving [lindex [info level $depth] 0] : $args"
51 }
52 } else {
53 proc entertrace {args} {}
54 proc leavetrace {args} {}
55 }
56 }
57
58 ascsetdebug 0
59
60 # this handles functions with arguments nicely for startup
61 proc asc_catch {func} {
62 if {[catch {$func} errmessage]} {
63 puts stderr "*** Error calling $func"
64 puts stderr $errmessage
65 puts stderr "***"
66 }
67 }
68
69 # requires double braces to deal with xfs dot qualified procedure names.
70
71 #
72 # proc awin {window}
73 #-----------------------------------------------------------------------
74 # start (or destroy) windows. awin help for detail
75 #-----------------------------------------------------------------------
76 proc awin {window} {
77
78 global xfShowWindow.browser xfShowWindow.display xfShowWindow.library
79 global xfShowWindow.probe xfShowWindow.script
80 global xfShowWindow.solver xfShowWindow.toolbox xfShowWindow.units
81 global xfShowWindow.debug xfShowWindow.mtx
82 global ascSolvVect
83 global env
84
85 switch $window {
86 # getting the toolbox requires all its attachments.
87 {t*} -
88 {all} -
89 {t*} -
90 {T*} {
91 set xfShowWindow.browser 1
92 ShowWindow.browser
93 puts -nonewline "."; flush stdout
94 set xfShowWindow.display 1
95 ShowWindow.display
96 puts -nonewline "."; flush stdout
97 set xfShowWindow.library 1
98 ShowWindow.library
99 puts -nonewline "."; flush stdout
100 set xfShowWindow.probe 1
101 ShowWindow.probe
102 puts -nonewline "."; flush stdout
103 set xfShowWindow.script 1
104 ShowWindow.script
105 puts -nonewline "."; flush stdout
106 set xfShowWindow.solver 1
107 ShowWindow.solver
108 puts -nonewline "."; flush stdout
109 set xfShowWindow.units 1
110 ShowWindow.units
111 puts -nonewline "."; flush stdout
112 set xfShowWindow.toolbox 1
113 ShowWindow.toolbox
114 puts "."; flush stdout
115 update idletask
116 # resource everything
117 puts "source $env(ASCENDTK)/ToolboxProc.tcl"
118 asc_source "$env(ASCENDTK)/ToolboxProc.tcl"
119 puts "source $env(ASCENDTK)/UtilProc.tcl"
120 asc_source "$env(ASCENDTK)/UtilProc.tcl"
121 puts "source $env(ASCENDTK)/DisplayProc.tcl"
122 asc_source "$env(ASCENDTK)/DisplayProc.tcl"
123 puts "source $env(ASCENDTK)/UnitsProc.tcl"
124 asc_source "$env(ASCENDTK)/UnitsProc.tcl"
125 puts "source $env(ASCENDTK)/ProbeProc.tcl"
126 asc_source "$env(ASCENDTK)/ProbeProc.tcl"
127 puts "source $env(ASCENDTK)/LibraryProc.tcl"
128 asc_source "$env(ASCENDTK)/LibraryProc.tcl"
129 puts "source $env(ASCENDTK)/TypetreeProc.tcl"
130 asc_source "$env(ASCENDTK)/TypetreeProc.tcl"
131 puts "source $env(ASCENDTK)/BrowserProc.tcl"
132 asc_source "$env(ASCENDTK)/BrowserProc.tcl"
133 puts "source $env(ASCENDTK)/DebugProc.tcl"
134 asc_source "$env(ASCENDTK)/DebugProc.tcl"
135 puts "source $env(ASCENDTK)/MtxProc.tcl"
136 asc_source "$env(ASCENDTK)/MtxProc.tcl"
137 puts "source $env(ASCENDTK)/SolverProc.tcl"
138 asc_source "$env(ASCENDTK)/SolverProc.tcl"
139 puts "source $env(ASCENDTK)/ScriptProc.tcl"
140 asc_source "$env(ASCENDTK)/ScriptProc.tcl"
141 puts "source $env(ASCENDTK)/WWWHelpProc.tcl"
142 asc_source "$env(ASCENDTK)/WWWHelpProc.tcl"
143 puts "source $env(ASCENDTK)/HubProc.tcl"
144 asc_source "$env(ASCENDTK)/HubProc.tcl"
145 puts "source $env(ASCENDTK)/mps.tcl"
146 asc_source "$env(ASCENDTK)/mps.tcl"
147 puts "source $env(ASCENDTK)/CallbackProc.tcl"
148 asc_source "$env(ASCENDTK)/CallbackProc.tcl"
149 puts "source $env(ASCENDTK)/NoteboxProc.tcl"
150 asc_source "$env(ASCENDTK)/NoteboxProc.tcl"
151 puts "source $env(ASCENDTK)/methods.tcl"
152 asc_source "$env(ASCENDTK)/methods.tcl"
153 # puts "Wiring up the buttons..."
154 asc_catch set_Browser_Defaults
155 asc_catch set_Display_Defaults
156 asc_catch set_Library_Defaults
157 asc_catch set_Typetree_Defaults
158 asc_catch set_Probe_Defaults
159 asc_catch set_Script_Defaults
160 asc_catch set_Solver_Defaults
161 # Overwriting with parameters defined by user rc file
162 # but now we don't really need an rc file do we?
163 asc_catch View_Source_Params_Files
164 asc_catch set_Debug_Defaults
165 asc_catch set_Mtx_Defaults
166 asc_catch set_Units_Defaults
167 asc_catch set_Toolbox_Defaults
168 asc_catch set_Util_Defaults
169 asc_catch set_HUB_Defaults
170 asc_catch set_Help_Defaults
171
172 }
173 {b*} -
174 {B*} {set xfShowWindow.browser 1
175 ShowWindow.browser
176 puts "source $env(ASCENDTK)/BrowserProc.tcl"
177 asc_source "$env(ASCENDTK)/BrowserProc.tcl"
178 set_Browser_Defaults
179 update idletask}
180
181 {d*} -
182 {D*} {set xfShowWindow.display 1
183 ShowWindow.display
184 puts "source $env(ASCENDTK)/DisplayProc.tcl"
185 # update idletask
186 asc_source "$env(ASCENDTK)/DisplayProc.tcl"
187 set_Display_Defaults
188 update idletask}
189
190 {l*} -
191 {L*} {set xfShowWindow.library 1
192 ShowWindow.library
193 puts "source $env(ASCENDTK)/LibraryProc.tcl"
194 # update idletask
195 asc_source "$env(ASCENDTK)/LibraryProc.tcl"
196 set_Library_Defaults
197 update idletask}
198
199 {p*} -
200 {P*} {set xfShowWindow.probe 1
201 ShowWindow.probe
202 puts "source $env(ASCENDTK)/ProbeProc.tcl"
203 # update idletask
204 asc_source "$env(ASCENDTK)/ProbeProc.tcl"
205 set_Probe_Defaults
206 update idletask}
207
208 {sc*} -
209 {Sc*} -
210 {SC*} {set xfShowWindow.script 1
211 ShowWindow.script
212 puts "source $env(ASCENDTK)/ScriptProc.tcl"
213 # update idletask
214 asc_source "$env(ASCENDTK)/ScriptProc.tcl"
215 set_Script_Defaults
216 update idletask}
217
218 # theoretically the general parameters are always there
219 {so*} -
220 {So*} -
221 {SO*} { set xfShowWindow.solver 1
222 ShowWindow.solver
223 puts "source $env(ASCENDTK)/SolverProc.tcl"
224 # update idletask
225 asc_source "$env(ASCENDTK)/SolverProc.tcl"
226 set_Solver_Defaults
227 #
228 # Overwriting with parameters defined by user
229 #
230 View_Source_Params_Files
231 update idletask}
232
233 {u*} -
234 {U*} {set xfShowWindow.units 1
235 ShowWindow.units
236 puts "source $env(ASCENDTK)/UnitsProc.tcl"
237 # update idletask
238 asc_source "$env(ASCENDTK)/UnitsProc.tcl"
239 set_Units_Defaults
240 update idletask}
241
242 {noall} -
243 {noT*} -
244 {not*} {
245 if {${xfShowWindow.toolbox}} {DestroyWindow.toolbox
246 DestroyWindow.util}
247 if {${xfShowWindow.browser}} {DestroyWindow.browser}
248 if {${xfShowWindow.display}} {DestroyWindow.display}
249 if {${xfShowWindow.library}} {DestroyWindow.library}
250 if {${xfShowWindow.probe}} {DestroyWindow.probe}
251 if {${xfShowWindow.script}} {DestroyWindow.script}
252 if {${xfShowWindow.solver}} {DestroyWindow.solver}
253 if {${xfShowWindow.units}} {DestroyWindow.units}
254 set xfShowWindow.browser 0
255 set xfShowWindow.display 0
256 set xfShowWindow.library 0
257 set xfShowWindow.probe 0
258 set xfShowWindow.script 0
259 set xfShowWindow.solver 0
260 set xfShowWindow.units 0
261 set xfShowWindow.toolbox 0
262 update idletask }
263
264 {nob*} -
265 {noB*} {if {${xfShowWindow.browser}} {DestroyWindow.browser}
266 set xfShowWindow.browser 0}
267
268 {nod*} -
269 {noD*} {if {${xfShowWindow.browser}} {DestroyWindow.browser}
270 set xfShowWindow.display 0}
271
272 {nol*} -
273 {noL*} {if {${xfShowWindow.library}} {DestroyWindow.library}
274 set xfShowWindow.library 0}
275
276 {nop*} -
277 {noP*} {if {${xfShowWindow.probe}} {DestroyWindow.probe}
278 set xfShowWindow.probe 0}
279
280 {nosc*} -
281 {noSC*} -
282 {noSc*} {if {${xfShowWindow.script}} {DestroyWindow.script}
283 set xfShowWindow.script 0}
284
285 {noso*} -
286 {noSo*} -
287 {noSO*} {
288 if {${xfShowWindow.solver}} {DestroyWindow.solver}
289 set xfShowWindow.solver 0}
290
291 {noU*} -
292 {nou*} {if {${xfShowWindow.units}} {DestroyWindow.units}
293 set xfShowWindow.units 0}
294 default { puts "awin syntax: awin \[no\]arg"
295 puts " where arg is 'all' or the name of a window." }
296 }
297 #end switch
298 set_ascplot_defaults
299 # update idletask
300 # update
301 }
302 # end awin
303
304 #
305 # proc asc_fixiconnames {}
306 #-----------------------------------------------------------------------
307 # asc iconname silliness under twm, maybe mwm. once the hurly burly's done,
308 # call this. still buggy under sun3twm
309 #-----------------------------------------------------------------------
310 proc asc_fixiconnames {} {
311 global ascBrowVect ascLibrVect ascSolvVect ascProbVect
312 global ascToolVect ascSimsVect ascUnitVect ascDispVect
313 global ascScripVect
314
315 catch {wm iconname .browser}
316 catch {wm title .}
317 catch {wm iconname .}
318 catch {wm iconname .display}
319 catch {wm iconname .library}
320 catch {wm iconname .probe}
321 catch {wm iconname .script}
322 catch {wm iconname .solver}
323 catch {wm iconname .units }
324 catch {wm iconname .toolbox}
325 wm title . "Ascend IV"
326 wm iconname . "Ascend IV"
327 # update idletasks
328 wm title . "Ascend IV"
329 wm iconname .browser $ascBrowVect(iconname)
330 wm iconname .display $ascDispVect(iconname)
331 wm iconname .library $ascLibrVect(iconname)
332 wm iconname .probe $ascProbVect(iconname)
333 wm iconname .script $ascScripVect(iconname)
334 wm iconname .solver $ascSolvVect(iconname)
335 wm iconname .toolbox $ascToolVect(iconname)
336 wm iconname .units $ascUnitVect(iconname)
337
338 }
339
340 #
341 # proc Redraw {}
342 #-----------------------------------------------------------------------
343 # Repaint info (as much as possible) from C structure after interface
344 # resourced
345 #-----------------------------------------------------------------------
346 proc Redraw {} {
347 Libr_Redraw
348 Solve_Redraw
349 Probe_Redraw
350 Units_Redraw
351 Sims_Redraw
352 }
353
354 #
355 # Binding hacks for Tk widgets in ASCEND.
356 # Ben Allan, 5/97.
357 #
358 proc set_cmuBindings {} {
359 global tcl_platform tk_strictMotif
360 # we don't understand why scanning is supposed to work only with
361 # b1 down. haven't been able to find any unwanted side effects of this
362 # baa 6/12/97, tk80b1-no patches
363 bind Menubutton <Motion> {
364 global tk_strictMotif
365 if {$tk_strictMotif} {
366 tkMbMotion %W up %X %Y
367 } else {
368 tkMbMotion %W down %X %Y
369 }
370 }
371 # puts "Adding cmu Entry and Text bindings"
372 #
373 # Entries:
374 #
375 # define Ctrl-u for unix folks.
376 bind Entry <Control-Key-u> {
377 if !$tk_strictMotif {
378 %W delete 0 end
379 }
380 }
381 #
382 #define delete and backspace to be backspace.
383 bind Entry <Key-Delete> {
384 if !$tk_strictMotif {
385 tkEntryBackspace %W
386 }
387 }
388 #
389 #Texts
390 #
391 # munge both backspace and delete to
392 if {$tcl_platform(platform)=="unix" && !$tk_strictMotif} {
393 # the standard tcl text bindings. Swap them.
394 # bind Text <Delete> {
395 # if {[%W tag nextrange sel 1.0 end] != ""} {
396 # %W delete sel.first sel.last
397 # } else {
398 # %W delete insert
399 # %W see insert
400 # }
401 #}
402 #bind Text <BackSpace> {
403 # if {[%W tag nextrange sel 1.0 end] != ""} {
404 # %W delete sel.first sel.last
405 # } elseif [%W compare insert != 1.0] {
406 # %W delete insert-1c
407 # %W see insert
408 # }
409 #}
410 bind Text <BackSpace> {
411 if {[%W tag nextrange sel 1.0 end] != ""} {
412 %W delete sel.first sel.last
413 } else {
414 %W delete insert
415 %W see insert
416 }
417 }
418 bind Text <Delete> {
419 if {[%W tag nextrange sel 1.0 end] != ""} {
420 %W delete sel.first sel.last
421 } elseif [%W compare insert != 1.0] {
422 %W delete insert-1c
423 %W see insert
424 }
425 }
426 }
427 if {!$tk_strictMotif} {
428 if {$tcl_platform(platform) =="windows"} {
429 bind Text <Control-Key-x> {
430 asctk_textCut %W
431 }
432 bind Text <Control-Key-c> {
433 asctk_textCopy %W
434 }
435 bind Text <Control-Key-v> {
436 asctk_textPaste %W
437 }
438 }
439 proc asctk_textCut {w} {
440 set expo [$w cget -exportselection]
441 $w configure -exportselection 1
442 selection own $w
443 tk_textCut $w
444 $w configure -exportselection $expo
445 }
446 proc asctk_textCopy {w} {
447 set expo [$w cget -exportselection]
448 $w configure -exportselection 1
449 selection own $w
450 tk_textCopy $w
451 $w configure -exportselection $expo
452 }
453 proc asctk_textPaste {w} {
454 set expo [$w cget -exportselection]
455 $w configure -exportselection 1
456 tk_textPaste $w
457 $w configure -exportselection $expo
458 }
459 }
460 }
461
462 #
463 # Function to manage which ascend window, if any, claims the
464 # PRIMARY X selection. With this function, PRIMARY should
465 # shadow CLIPBOARD as long as ASCEND owns primary.
466 # We must have no more than 1 widget at a time exporting or
467 # life is very difficult.
468 # calling this function with a widget name makes that widget
469 # the exporting window and unmakes the previous widget exporterness.
470 proc asc_export_selection {w} {
471 global ascGlobalVect
472 if {![string length $w]} {
473 return
474 }
475 if {![winfo exists $w]} {
476 return
477 }
478 catch {$ascGlobalVect(selection_exporter) configure -exportselection 0} err
479 set ascGlobalVect(selection_exporter) $w
480 $w configure -exportselection 1
481 }
482
483 #
484 # proc set_Global_Defaults {}
485 #-----------------------------------------------------------------------
486 # proc set_Global_Defaults
487 # These following must be set here to control window creation in Main.
488 #-----------------------------------------------------------------------
489 proc set_Global_Defaults {} {
490 set_cmuBindings
491
492 global env tcl_platform asc_tkfbox
493 global ascBrowVect ascLibrVect ascSolvVect ascProbVect ascDebuVect
494 global ascToolVect ascSimsVect ascUnitVect ascDispVect ascGlobalVect
495 global ascScripVect ascMtxVect
496
497 #
498 # Check if the directory for saving window options exists or can be
499 # created
500 #
501 if {[string compare $tcl_platform(platform) "unix"]==0} {
502 if { [ file exists ~/ascdata ]} {
503 set ascGlobalVect(saveoptions) 1
504 } else {
505 if { [catch {file mkdir ~/ascdata} direrror] } {
506 set ascGlobalVect(saveoptions) 0
507 puts $direrror
508 } else {
509 set ascGlobalVect(saveoptions) 1
510 puts "directory ~/ascdata has been created"
511 }
512 }
513 set ascGlobalVect(userhome) ""
514 catch {set ascGlobalVect(userhome) "[glob ~/ascdata]"}
515 }
516 if {[string compare $tcl_platform(platform) "windows"]==0} {
517 set uhome {}
518 catch {set uhome [glob ~]}
519 if {[info exists env(HOME)] &&
520 [file isdirectory $env(HOME)] &&
521 [file writable $env(HOME)]} {
522 set uhome $env(HOME)
523 }
524 set upfound 0
525 if {[string length $uhome] < 4} {
526 if {[info exists env(USERPROFILE)] &&
527 [file isdirectory $env(USERPROFILE)] &&
528 [file writable $env(USERPROFILE)]} {
529 set uhome $env(USERPROFILE)
530 set upfound 1
531 }
532 }
533 if {!$upfound && [string length $uhome] < 4} {
534 if {[info exists env(USERHOME)] &&
535 [file isdirectory $env(USERHOME)] &&
536 [file writable $env(USERHOME)]} {
537 set uhome $env(USERHOME)
538 set upfound 1
539 }
540 }
541 append uhome /ascdata
542 puts stderr "data home = $uhome"
543
544 if { [ file exists $uhome ] && \
545 [file writable $uhome] && \
546 [file isdirectory $uhome]} {
547 set ascGlobalVect(saveoptions) 1
548 } else {
549 if { [catch {file mkdir $uhome} direrror] } {
550 set ascGlobalVect(saveoptions) 0
551 puts $direrror
552 } else {
553 set ascGlobalVect(saveoptions) 1
554 puts "directory $uhome has been created"
555 }
556 }
557 set ascGlobalVect(userhome) $uhome
558 }
559
560 if {[info exists env(ASCENDLIBRARY)] == 0} {
561 puts stderr "setting lib in global to [pwd]"
562 set env(ASCENDLIBRARY) [pwd]
563 }
564 if {$ascGlobalVect(saveoptions)} {
565 switch $tcl_platform(platform) {
566 unix {
567 set env(ASCENDLIBRARY) $ascGlobalVect(userhome):$env(ASCENDLIBRARY)
568 }
569 windows {
570 set crap [file nativename $ascGlobalVect(userhome)]
571 append crap ";"
572 append crap $env(ASCENDLIBRARY)
573 set env(ASCENDLIBRARY) $crap
574 }
575 macintosh {
576 puts stderr "ASCEND IV's Tcl/Tk interface has not yet been ported"
577 puts stderr "to Macintosh. Lots and lots of things are broken."
578 error "ASCEND load aborted on macintosh."
579 }
580 }
581 }
582 puts stderr "Library directories:"
583 puts stderr $env(ASCENDLIBRARY)
584 set ascGlobalVect(librarypathdirs) ""
585 if {$tcl_platform(platform) == "unix"} {
586 set ascGlobalVect(librarypathdirs) [split $env(ASCENDLIBRARY) :]
587 } else { #windoze. mac? mac uses : instead of /, ugh.
588 set ascGlobalVect(librarypathdirs) [split $env(ASCENDLIBRARY) \;]
589 }
590 if {$tcl_platform(platform) == "unix"} {
591 set ascGlobalVect(ascend2gms) \
592 [file nativename [file dirname [info nameofexecutable]]]/ascend2gms.pl
593 set ascGlobalVect(gms2ascend) \
594 [file nativename [file dirname [info nameofexecutable]]]/convertoutput.pl
595 }
596
597 # take care of the PRIMARY selection under unix. the last window to
598 # have <<Copy>> call should be the only window to export selection.
599 set ascGlobalVect(selection_exporter) .
600
601 set slist ""
602 set s 0
603 catch {set slist [slv_available]}
604 set ascSolvVect(numberofsolvers) [llength $slist]
605 foreach i $slist {
606 set ascSolvVect(name.$s) $i
607 if {[string range $i 0 2]=="no_"} {
608 set ascSolvVect(available.$s) 0
609 set ascSolvVect(name.$s) [string range $i 3 end]
610 } else { set ascSolvVect(available.$s) 1}
611 incr s
612 }
613
614 set winshortlist \
615 "Solv Brow Libr Prob Debu Tool Scrip Mtx Unit Disp Global"
616 foreach w $winshortlist {
617 set asc${w}Vect(initialstate) "withdrawn"
618 set asc${w}Vect(geometry) "200x200+10+10"
619 set asc${w}Vect(iconname) $w
620 set asc${w}Vect(font) {helvetica 12 bold}
621 set asc${w}Vect(visibility) 1
622 }
623 #this next line sets the toolbitmap under the assumption that GlobalProc
624 # will never be present under xf. toolAttributes is C-registered
625 set ascGlobalVect(toolbitmap) toolAttributes
626
627 set ascToolVect(initialstate) "withdrawn"
628 set ascGlobalVect(maxutilrow) 8
629 set ascGlobalVect(hideinfoforever) 0
630 set ascGlobalVect(warrinfo) 0
631 set ascGlobalVect(liceinfo) 0
632 set ascGlobalVect(authinfo) 0
633
634 set ascDebuVect(windowname) .debug
635 set ascDispVect(windowname) .display
636 set ascMtxVect(windowname) .mtx
637 set ascScripVect(windowname) .script
638 set ascToolVect(windowname) .toolbox
639 set ascUnitVect(windowname) .units
640 set ascSolvVect(windowname) .solver
641 set ascBrowVect(windowname) .browser
642 set ascLibrVect(windowname) .library
643 set ascProbVect(windowname) .probe
644 # do the option database load which will override above settings
645 # the next line sets a dummy value for ScrollCommand at a low
646 # priority. if you see NoFunction returned from an option query
647 # you should apply some default instead. The tk Class default for
648 # ScrollCommand is {} so NoFunction is ok.
649 option add *ScrollComand NoFunction 20
650 #
651 # New tcl file ascend.ad
652 # View contains the procedures required by ascend.ad
653 #
654 puts "source $env(ASCENDTK)/View.tcl"
655 asc_source "$env(ASCENDTK)/View.tcl"
656 puts "source $env(ASCENDTK)/ascend.ad"
657 asc_source $env(ASCENDTK)/ascend.ad
658
659 update
660 if {[file exists $ascGlobalVect(userhome)/ascend.ad]} {
661 if {[catch {asc_source $ascGlobalVect(userhome)/ascend.ad} aderror]} {
662 puts $aderror
663 }
664 }
665 update
666
667 Set_View_Option_Values
668 View_Source_Option_Files
669
670 #
671 # # make ascend global ->Xglobal
672 # # do not add these at priorities >=20 as this will give conflicts
673 # # when reading the options with Foreground in get_opt
674 # option add *Font $ascGlobalVect(font) 60
675 option add *Text*Foreground $ascGlobalVect(tfg) 40
676 option add *Listbox*Foreground $ascGlobalVect(tfg) 40
677 option add *Text*Background $ascGlobalVect(tbg) 40
678 option add *Listbox*Background $ascGlobalVect(tbg) 40
679 # option add *Background $ascGlobalVect(bg) 60
680 # option add *Foreground $ascGlobalVect(fg) 60
681 # # initialize read/write virtual.
682 __userdata_init
683 set ascGlobalVect(w_load) "1"
684 }
685
686 # set color/etc vectors for transients with arrays
687 proc set_Template_defaults {} {
688 global ascGlobalVect
689 global AscMonoEntry1 AscMonoEntry2 AscMonoEntry4 AscConfirm VPaned
690 global AscPopSlide ascParPageVect ascMsgVect
691 global ascListSelectBox ascListSelectB1Box
692 set AscMonoEntry1(font) $ascGlobalVect(font)
693 set AscMonoEntry2(font) $ascGlobalVect(font)
694 set AscMonoEntry4(font) $ascGlobalVect(font)
695 set AscConfirm(font) $ascGlobalVect(font)
696 set VPaned(knobcolor) white
697 set AscPopSlide(font) $ascGlobalVect(font)
698 set ascParPageVect(btn_font) $ascGlobalVect(font)
699 set ascListSelectB1Box(font) $ascGlobalVect(font)
700 set ascListSelectB1Box(grab) 1
701 set ascListSelectBox(font) $ascGlobalVect(font)
702 set ascListSelectBox(grab) 1
703 set ascMsgVect(lbl_font) $ascGlobalVect(font)
704 set ascMsgVect(btn_font) $ascGlobalVect(font)
705 }
706
707 #
708 # proc Glob_do_GNU {}
709 #-----------------------------------------------------------------------
710 # the gnubutton callback
711 #-----------------------------------------------------------------------
712 # d_dumpfile defined in generalk.tcl, so this is silent until main loads
713 # generalk
714 proc Glob_do_GNU {} {
715 # old version
716 # global env
717 # set path "[lindex [split $env(ASCENDHELP) :] 0]/notices/startup"
718 # catch {d_dumpfile stdout $path}
719 # wm iconify .
720 ascShowInfo
721 }
722
723 proc ascShowInfo {{force 0}} {
724 global ascGlobalVect env
725
726 wm withdraw .
727 if {[winfo exists .itop]==1} {
728 destroy .itop
729 }
730 if {$ascGlobalVect(hideinfoforever)==1 && !$force} {
731 return
732 }
733 set f .itop.info
734 wm title . "ASCEND IV"
735 toplevel .itop
736 wm positionfrom .itop user
737 wm title .itop "ASCEND IV"
738 wm iconname .itop "ASCEND IV"
739 frame $f -highlightthickness 2 -borderwidth 2 -relief sunken
740 set t $f.text
741 text $t -yscrollcommand "$f.scroll set" -setgrid true \
742 -font {Helvetica 8} -width 80 -exportselection 0 \
743 -height 35 -wrap word -highlightthickness 0 -borderwidth 0
744 pack append $f $t {right frame center expand fill}
745 scrollbar $f.scroll -command "$t yview"
746 pack append $f $f.scroll {left frame center expand filly}
747 pack append .itop $f {bottom frame center expand fill}
748 $t tag configure center -justify center -spacing1 5m -spacing3 5m
749 $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \
750 -spacing1 3m -spacing2 0 -spacing3 0
751
752 button $t.click -text "Authors" \
753 -command "ascAuthInfo" \
754 -font {Helvetica 8} \
755 -cursor top_left_arrow
756 button $t.delete -text "Help (starts browser)" \
757 -command {Script_getting_started} \
758 -font {Helvetica 8} \
759 -cursor top_left_arrow
760 button $t.goaway -text "Dismiss" \
761 -command {destroy .itop} \
762 -font {Helvetica 8} \
763 -cursor top_left_arrow
764 button $t.die -text "Dismiss forever" \
765 -command "Global_Dismiss_Forever" \
766 -font {Helvetica 8} \
767 -cursor top_left_arrow
768 button $t.gnu_btn \
769 -bitmap "@$env(ASCENDBITMAPS)/gnu-ascend.xbm" \
770 -state normal \
771 -text {}
772
773
774 $t insert end " ASCEND IV\n"
775 $t insert end "Advanced System for Computations in ENgineering Design\n"
776 $t insert end "(C) Copyright 1992-1998 Carnegie Mellon University\n"
777 $t insert end "\tRelease 0.9.0, June 19, 1998\n"
778 $t insert end "\n"
779 $t insert end "Click on the buttons below if you want to see who we are. "
780 $t insert end "By using ASCEND IV you are agreeing to the terms of "
781 $t insert end "the GNU Public License and Warranty in the first Script:."
782 $t insert end "License-Warranty.tcl\n"
783 $t insert end "\n"
784 $t insert end "ASCEND was developed by the students of Art Westerberg "
785 $t insert end "from 1984 to 1998. A number of other students have also "
786 $t insert end "contributed models to the ASCEND libraries. A list "
787 $t insert end "of the known contributors (in any capacity) is here: "
788 $t window create end -window $t.click
789 $t insert end "(Please let us know if we missed you.)"
790 $t insert end "\n"
791 $t insert end "\n"
792 $t insert end "Help for getting started with ASCEND should be available "
793 $t insert end "at "
794 $t insert end "\n"
795 $t insert end " http://www.cs.cmu.edu/~ascend/pdfhelp.htm\n"
796 $t insert end "(you should be able to paste the address above with a mouse)"
797 $t insert end " where you will find links to our on-line help and link to "
798 $t insert end "our bug report form.\n\n"
799 $t insert end " E-mail: ascend+help@cs.cmu.edu\n\n"
800
801 $t insert end " "
802 $t window create end -window $t.goaway
803 $t insert end " "
804 $t window create end -window $t.die
805 $t insert end "\n\n "
806 $t window create end -window $t.gnu_btn
807 $t insert end "\n\n"
808 $t insert end "USER DATA DIRECTORY $ascGlobalVect(userhome)"
809 $t insert end "\n\n"
810 wm deiconify .itop
811 }
812
813 #
814 # proc Global_Dismiss_Forever {}
815 #_________________________________________________________________
816 # Save the value of hideinfoforever = 1 in the file global.a4o
817 #_________________________________________________________________
818 proc Global_Dismiss_Forever {} {
819 entertrace
820 global ascGlobalVect
821
822 if {$ascGlobalVect(saveoptions) == 0} {
823 return
824 }
825
826 Global hideinfoforever 1
827 View_Save_Window_Options global
828 ascShowInfo
829 return
830
831 leavetrace
832 }
833
834 #
835 # proc ascAuthInfo {}
836 #_________________________________________________________________
837 # pops up a tkdialog with the content of TK/WhoDunnit.tcl
838 # all merged into a single string.
839 #_________________________________________________________________
840 proc ascAuthInfo {} {
841 global env ascScripVect
842 set fileInFile [open $env(ASCENDTK)/WhoDunnit.tcl r]
843 set textValue [read $fileInFile]
844 # regsub -all \n $textValue { } textValue2
845 asctk_dialog .authinfo $ascScripVect(font) "ASCEND Authors" \
846 $textValue toolAttributes 0 OK
847 }

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