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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 516 - (show annotations) (download) (as text)
Thu Apr 20 08:07:53 2006 UTC (13 years, 10 months ago) by ben.allan
File MIME type: text/x-tcl
File size: 29075 byte(s)
foo
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 switch $tk_version {
366 8.5 -
367 8.4 {
368 if {$tk_strictMotif} {
369 tk::MbMotion %W up %X %Y
370 } else {
371 tk::MbMotion %W down %X %Y
372 }
373 }
374 8.3 {
375 if {$tk_strictMotif} {
376 tkMbMotion %W up %X %Y
377 } else {
378 tkMbMotion %W down %X %Y
379 }
380 }
381 }
382 }
383 # puts "Adding cmu Entry and Text bindings"
384 #
385 # Entries:
386 #
387 # define Ctrl-u for unix folks.
388 bind Entry <Control-Key-u> {
389 if !$tk_strictMotif {
390 %W delete 0 end
391 }
392 }
393 #
394 #define delete and backspace to be backspace.
395 bind Entry <Key-Delete> {
396 if !$tk_strictMotif {
397 tkEntryBackspace %W
398 }
399 }
400 #
401 #Texts
402 #
403 # munge both backspace and delete to
404 if {$tcl_platform(platform)=="unix" && !$tk_strictMotif} {
405 # the standard tcl text bindings. Swap them.
406 # bind Text <Delete> {
407 # if {[%W tag nextrange sel 1.0 end] != ""} {
408 # %W delete sel.first sel.last
409 # } else {
410 # %W delete insert
411 # %W see insert
412 # }
413 #}
414 #bind Text <BackSpace> {
415 # if {[%W tag nextrange sel 1.0 end] != ""} {
416 # %W delete sel.first sel.last
417 # } elseif [%W compare insert != 1.0] {
418 # %W delete insert-1c
419 # %W see insert
420 # }
421 #}
422 bind Text <BackSpace> {
423 if {[%W tag nextrange sel 1.0 end] != ""} {
424 %W delete sel.first sel.last
425 } else {
426 %W delete insert
427 %W see insert
428 }
429 }
430 bind Text <Delete> {
431 if {[%W tag nextrange sel 1.0 end] != ""} {
432 %W delete sel.first sel.last
433 } elseif [%W compare insert != 1.0] {
434 %W delete insert-1c
435 %W see insert
436 }
437 }
438 }
439 if {!$tk_strictMotif} {
440 if {$tcl_platform(platform) =="windows"} {
441 bind Text <Control-Key-x> {
442 asctk_textCut %W
443 }
444 bind Text <Control-Key-c> {
445 asctk_textCopy %W
446 }
447 bind Text <Control-Key-v> {
448 asctk_textPaste %W
449 }
450 }
451 proc asctk_textCut {w} {
452 set expo [$w cget -exportselection]
453 $w configure -exportselection 1
454 selection own $w
455 tk_textCut $w
456 $w configure -exportselection $expo
457 }
458 proc asctk_textCopy {w} {
459 set expo [$w cget -exportselection]
460 $w configure -exportselection 1
461 selection own $w
462 tk_textCopy $w
463 $w configure -exportselection $expo
464 }
465 proc asctk_textPaste {w} {
466 set expo [$w cget -exportselection]
467 $w configure -exportselection 1
468 tk_textPaste $w
469 $w configure -exportselection $expo
470 }
471 }
472 }
473
474 #
475 # Function to manage which ascend window, if any, claims the
476 # PRIMARY X selection. With this function, PRIMARY should
477 # shadow CLIPBOARD as long as ASCEND owns primary.
478 # We must have no more than 1 widget at a time exporting or
479 # life is very difficult.
480 # calling this function with a widget name makes that widget
481 # the exporting window and unmakes the previous widget exporterness.
482 proc asc_export_selection {w} {
483 global ascGlobalVect
484 if {![string length $w]} {
485 return
486 }
487 if {![winfo exists $w]} {
488 return
489 }
490 catch {$ascGlobalVect(selection_exporter) configure -exportselection 0} err
491 set ascGlobalVect(selection_exporter) $w
492 $w configure -exportselection 1
493 }
494
495 #
496 # proc set_Global_Defaults {}
497 #-----------------------------------------------------------------------
498 # proc set_Global_Defaults
499 # These following must be set here to control window creation in Main.
500 #-----------------------------------------------------------------------
501 proc set_Global_Defaults {} {
502 set_cmuBindings
503
504 global env tcl_platform asc_tkfbox
505 global ascBrowVect ascLibrVect ascSolvVect ascProbVect ascDebuVect
506 global ascToolVect ascSimsVect ascUnitVect ascDispVect ascGlobalVect
507 global ascScripVect ascMtxVect
508
509 #
510 # Check if the directory for saving window options exists or can be
511 # created
512 #
513 if {[string compare $tcl_platform(platform) "unix"]==0} {
514 if { [ file exists ~/ascdata ]} {
515 set ascGlobalVect(saveoptions) 1
516 } else {
517 if { [catch {file mkdir ~/ascdata} direrror] } {
518 set ascGlobalVect(saveoptions) 0
519 puts $direrror
520 } else {
521 set ascGlobalVect(saveoptions) 1
522 puts "directory ~/ascdata has been created"
523 }
524 }
525 set ascGlobalVect(userhome) ""
526 catch {set ascGlobalVect(userhome) "[glob ~/ascdata]"}
527 }
528 if {[string compare $tcl_platform(platform) "windows"]==0} {
529 set uhome {}
530 catch {set uhome [glob ~]}
531 if {[info exists env(HOME)] &&
532 [file isdirectory $env(HOME)] &&
533 [file writable $env(HOME)]} {
534 set uhome $env(HOME)
535 }
536 set upfound 0
537 if {[string length $uhome] < 4} {
538 if {[info exists env(USERPROFILE)] &&
539 [file isdirectory $env(USERPROFILE)] &&
540 [file writable $env(USERPROFILE)]} {
541 set uhome $env(USERPROFILE)
542 set upfound 1
543 }
544 }
545 if {!$upfound && [string length $uhome] < 4} {
546 if {[info exists env(USERHOME)] &&
547 [file isdirectory $env(USERHOME)] &&
548 [file writable $env(USERHOME)]} {
549 set uhome $env(USERHOME)
550 set upfound 1
551 }
552 }
553 append uhome /ascdata
554 puts stderr "data home = $uhome"
555
556 if { [ file exists $uhome ] && \
557 [file writable $uhome] && \
558 [file isdirectory $uhome]} {
559 set ascGlobalVect(saveoptions) 1
560 } else {
561 if { [catch {file mkdir $uhome} direrror] } {
562 set ascGlobalVect(saveoptions) 0
563 puts $direrror
564 } else {
565 set ascGlobalVect(saveoptions) 1
566 puts "directory $uhome has been created"
567 }
568 }
569 set ascGlobalVect(userhome) $uhome
570 }
571
572 if {[info exists env(ASCENDLIBRARY)] == 0} {
573 puts stderr "setting lib in global to [pwd]"
574 set env(ASCENDLIBRARY) [pwd]
575 }
576 if {$ascGlobalVect(saveoptions)} {
577 switch $tcl_platform(platform) {
578 unix {
579 set env(ASCENDLIBRARY) $ascGlobalVect(userhome):$env(ASCENDLIBRARY)
580 }
581 windows {
582 set crap [file nativename $ascGlobalVect(userhome)]
583 append crap ";"
584 append crap $env(ASCENDLIBRARY)
585 set env(ASCENDLIBRARY) $crap
586 }
587 macintosh {
588 puts stderr "ASCEND IV's Tcl/Tk interface has not yet been ported"
589 puts stderr "to Macintosh. Lots and lots of things are broken."
590 error "ASCEND load aborted on macintosh."
591 }
592 }
593 }
594 puts stderr "Library directories:"
595 puts stderr $env(ASCENDLIBRARY)
596 set ascGlobalVect(librarypathdirs) ""
597 if {$tcl_platform(platform) == "unix"} {
598 set ascGlobalVect(librarypathdirs) [split $env(ASCENDLIBRARY) :]
599 } else { #windoze. mac? mac uses : instead of /, ugh.
600 set ascGlobalVect(librarypathdirs) [split $env(ASCENDLIBRARY) \;]
601 }
602 if {$tcl_platform(platform) == "unix"} {
603 set ascGlobalVect(ascend2gms) \
604 [file nativename [file dirname [info nameofexecutable]]]/ascend2gms.pl
605 set ascGlobalVect(gms2ascend) \
606 [file nativename [file dirname [info nameofexecutable]]]/convertoutput.pl
607 }
608
609 # take care of the PRIMARY selection under unix. the last window to
610 # have <<Copy>> call should be the only window to export selection.
611 set ascGlobalVect(selection_exporter) .
612
613 set slist ""
614 set s 0
615 catch {set slist [slv_available]}
616 set ascSolvVect(numberofsolvers) [llength $slist]
617 foreach i $slist {
618 set ascSolvVect(name.$s) $i
619 if {[string range $i 0 2]=="no_"} {
620 set ascSolvVect(available.$s) 0
621 set ascSolvVect(name.$s) [string range $i 3 end]
622 } else { set ascSolvVect(available.$s) 1}
623 incr s
624 }
625
626 set winshortlist \
627 "Solv Brow Libr Prob Debu Tool Scrip Mtx Unit Disp Global"
628 foreach w $winshortlist {
629 set asc${w}Vect(initialstate) "withdrawn"
630 set asc${w}Vect(geometry) "200x200+10+10"
631 set asc${w}Vect(iconname) $w
632 set asc${w}Vect(font) {helvetica 12 bold}
633 set asc${w}Vect(visibility) 1
634 }
635 #this next line sets the toolbitmap under the assumption that GlobalProc
636 # will never be present under xf. toolAttributes is C-registered
637 set ascGlobalVect(toolbitmap) toolAttributes
638
639 set ascToolVect(initialstate) "withdrawn"
640 set ascGlobalVect(maxutilrow) 8
641 set ascGlobalVect(hideinfoforever) 0
642 set ascGlobalVect(warrinfo) 0
643 set ascGlobalVect(liceinfo) 0
644 set ascGlobalVect(authinfo) 0
645
646 set ascDebuVect(windowname) .debug
647 set ascDispVect(windowname) .display
648 set ascMtxVect(windowname) .mtx
649 set ascScripVect(windowname) .script
650 set ascToolVect(windowname) .toolbox
651 set ascUnitVect(windowname) .units
652 set ascSolvVect(windowname) .solver
653 set ascBrowVect(windowname) .browser
654 set ascLibrVect(windowname) .library
655 set ascProbVect(windowname) .probe
656 # do the option database load which will override above settings
657 # the next line sets a dummy value for ScrollCommand at a low
658 # priority. if you see NoFunction returned from an option query
659 # you should apply some default instead. The tk Class default for
660 # ScrollCommand is {} so NoFunction is ok.
661 option add *ScrollComand NoFunction 20
662 #
663 # New tcl file ascend.ad
664 # View contains the procedures required by ascend.ad
665 #
666 puts "source $env(ASCENDTK)/View.tcl"
667 asc_source "$env(ASCENDTK)/View.tcl"
668 puts "source $env(ASCENDTK)/ascend.ad"
669 asc_source $env(ASCENDTK)/ascend.ad
670
671 update
672 if {[file exists $ascGlobalVect(userhome)/ascend.ad]} {
673 if {[catch {asc_source $ascGlobalVect(userhome)/ascend.ad} aderror]} {
674 puts $aderror
675 }
676 }
677 update
678
679 Set_View_Option_Values
680 View_Source_Option_Files
681
682 #
683 # # make ascend global ->Xglobal
684 # # do not add these at priorities >=20 as this will give conflicts
685 # # when reading the options with Foreground in get_opt
686 # option add *Font $ascGlobalVect(font) 60
687 option add *Text*Foreground $ascGlobalVect(tfg) 40
688 option add *Listbox*Foreground $ascGlobalVect(tfg) 40
689 option add *Text*Background $ascGlobalVect(tbg) 40
690 option add *Listbox*Background $ascGlobalVect(tbg) 40
691 # option add *Background $ascGlobalVect(bg) 60
692 # option add *Foreground $ascGlobalVect(fg) 60
693 # # initialize read/write virtual.
694 __userdata_init
695 set ascGlobalVect(w_load) "1"
696 }
697
698 # set color/etc vectors for transients with arrays
699 proc set_Template_defaults {} {
700 global ascGlobalVect
701 global AscMonoEntry1 AscMonoEntry2 AscMonoEntry4 AscConfirm VPaned
702 global AscPopSlide ascParPageVect ascMsgVect
703 global ascListSelectBox ascListSelectB1Box
704 set AscMonoEntry1(font) $ascGlobalVect(font)
705 set AscMonoEntry2(font) $ascGlobalVect(font)
706 set AscMonoEntry4(font) $ascGlobalVect(font)
707 set AscConfirm(font) $ascGlobalVect(font)
708 set VPaned(knobcolor) white
709 set AscPopSlide(font) $ascGlobalVect(font)
710 set ascParPageVect(btn_font) $ascGlobalVect(font)
711 set ascListSelectB1Box(font) $ascGlobalVect(font)
712 set ascListSelectB1Box(grab) 1
713 set ascListSelectBox(font) $ascGlobalVect(font)
714 set ascListSelectBox(grab) 1
715 set ascMsgVect(lbl_font) $ascGlobalVect(font)
716 set ascMsgVect(btn_font) $ascGlobalVect(font)
717 }
718
719 #
720 # proc Glob_do_GNU {}
721 #-----------------------------------------------------------------------
722 # the gnubutton callback
723 #-----------------------------------------------------------------------
724 # d_dumpfile defined in generalk.tcl, so this is silent until main loads
725 # generalk
726 proc Glob_do_GNU {} {
727 # old version
728 # global env
729 # set path "[lindex [split $env(ASCENDHELP) :] 0]/notices/startup"
730 # catch {d_dumpfile stdout $path}
731 # wm iconify .
732 ascShowInfo
733 }
734
735 proc ascShowInfo {{force 0}} {
736 global ascGlobalVect env
737
738 wm withdraw .
739 if {[winfo exists .itop]==1} {
740 destroy .itop
741 }
742 if {$ascGlobalVect(hideinfoforever)==1 && !$force} {
743 return
744 }
745 set f .itop.info
746 wm title . "ASCEND IV"
747 toplevel .itop
748 wm positionfrom .itop user
749 wm title .itop "ASCEND IV"
750 wm iconname .itop "ASCEND IV"
751 frame $f -highlightthickness 2 -borderwidth 2 -relief sunken
752 set t $f.text
753 text $t -yscrollcommand "$f.scroll set" -setgrid true \
754 -font {Helvetica 8} -width 80 -exportselection 0 \
755 -height 35 -wrap word -highlightthickness 0 -borderwidth 0
756 pack append $f $t {right frame center expand fill}
757 scrollbar $f.scroll -command "$t yview"
758 pack append $f $f.scroll {left frame center expand filly}
759 pack append .itop $f {bottom frame center expand fill}
760 $t tag configure center -justify center -spacing1 5m -spacing3 5m
761 $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \
762 -spacing1 3m -spacing2 0 -spacing3 0
763
764 button $t.click -text "Authors" \
765 -command "ascAuthInfo" \
766 -font {Helvetica 8} \
767 -cursor top_left_arrow
768 button $t.delete -text "Help (starts browser)" \
769 -command {Script_getting_started} \
770 -font {Helvetica 8} \
771 -cursor top_left_arrow
772 button $t.goaway -text "Dismiss" \
773 -command {destroy .itop} \
774 -font {Helvetica 8} \
775 -cursor top_left_arrow
776 button $t.die -text "Dismiss forever" \
777 -command "Global_Dismiss_Forever" \
778 -font {Helvetica 8} \
779 -cursor top_left_arrow
780 button $t.gnu_btn \
781 -bitmap "@$env(ASCENDBITMAPS)/gnu-ascend.xbm" \
782 -state normal \
783 -text {}
784
785
786 $t insert end " ASCEND IV\n"
787 $t insert end "Advanced System for Computations in ENgineering Design\n"
788 $t insert end "(C) Copyright 1992-1998 Carnegie Mellon University\n"
789 $t insert end "\tRelease 0.9.0, June 19, 1998\n"
790 $t insert end "\n"
791 $t insert end "Click on the buttons below if you want to see who we are. "
792 $t insert end "By using ASCEND IV you are agreeing to the terms of "
793 $t insert end "the GNU Public License and Warranty in the first Script:."
794 $t insert end "License-Warranty.tcl\n"
795 $t insert end "\n"
796 $t insert end "ASCEND was developed by the students of Art Westerberg "
797 $t insert end "from 1984 to 1998. A number of other students have also "
798 $t insert end "contributed models to the ASCEND libraries. A list "
799 $t insert end "of the known contributors (in any capacity) is here: "
800 $t window create end -window $t.click
801 $t insert end "(Please let us know if we missed you.)"
802 $t insert end "\n"
803 $t insert end "\n"
804 $t insert end "Help for getting started with ASCEND should be available "
805 $t insert end "at "
806 $t insert end "\n"
807 $t insert end " http://www.cs.cmu.edu/~ascend/pdfhelp.htm\n"
808 $t insert end "(you should be able to paste the address above with a mouse)"
809 $t insert end " where you will find links to our on-line help and link to "
810 $t insert end "our bug report form.\n\n"
811 $t insert end " E-mail: ascend+help@cs.cmu.edu\n\n"
812
813 $t insert end " "
814 $t window create end -window $t.goaway
815 $t insert end " "
816 $t window create end -window $t.die
817 $t insert end "\n\n "
818 $t window create end -window $t.gnu_btn
819 $t insert end "\n\n"
820 $t insert end "USER DATA DIRECTORY $ascGlobalVect(userhome)"
821 $t insert end "\n\n"
822 wm deiconify .itop
823 }
824
825 #
826 # proc Global_Dismiss_Forever {}
827 #_________________________________________________________________
828 # Save the value of hideinfoforever = 1 in the file global.a4o
829 #_________________________________________________________________
830 proc Global_Dismiss_Forever {} {
831 entertrace
832 global ascGlobalVect
833
834 if {$ascGlobalVect(saveoptions) == 0} {
835 return
836 }
837
838 Global hideinfoforever 1
839 View_Save_Window_Options global
840 ascShowInfo
841 return
842
843 leavetrace
844 }
845
846 #
847 # proc ascAuthInfo {}
848 #_________________________________________________________________
849 # pops up a tkdialog with the content of TK/WhoDunnit.tcl
850 # all merged into a single string.
851 #_________________________________________________________________
852 proc ascAuthInfo {} {
853 global env ascScripVect
854 set fileInFile [open $env(ASCENDTK)/WhoDunnit.tcl r]
855 set textValue [read $fileInFile]
856 # regsub -all \n $textValue { } textValue2
857 asctk_dialog .authinfo $ascScripVect(font) "ASCEND Authors" \
858 $textValue toolAttributes 0 OK
859 }

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