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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 10 - (show annotations) (download) (as text)
Sat Nov 13 16:40:11 2004 UTC (17 years ago) by aw0a
File MIME type: text/x-tcl
File size: 21374 byte(s)
try again to commit moving tcl stuff
1 # DisplayProc.tcl: Tcl Code for Display window
2 # by Benjamin A. Allan and Kirk A. Abbott
3 # Created: January 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.44 $
6 # Last modified on: $Date: 1998/06/18 15:54:43 $
7 # Last modified by: $Author: mthomas $
8 # Revision control file: $RCSfile: DisplayProc.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_Display_Defaults {}
31 #----------------------------------------------------------------------
32 # Display startup setting
33 #----------------------------------------------------------------------
34 proc set_Display_Defaults {} {
35
36 # puts "setting Display buttons"
37
38 global ascDispVect
39 # used for controlling indentation in the Display
40 set ascDispVect(indent) 0
41
42 set ascDispVect(windowname) .display
43 set ascDispVect(ShowComments) 1
44 set ascDispVect(entry) ""
45 set ascDispVect(textBox) .display.main_frm.display_box.text2
46 set ascDispVect(entryBox) .display.entry_frm.entry_box
47 # set ptr
48 .display configure -cursor left_ptr
49 Configure_Display;
50
51 # Update Enabled/Disabled entries when a menu is posted
52 #
53 .display.menubar.view configure \
54 -postcommand Disp_Update_View_Buttons
55 }
56
57 #
58 # Configure_Display {}
59 #----------------------------------------------------------------------
60 # set more stuff
61 #----------------------------------------------------------------------
62 proc Configure_Display {} {
63 global ascDispVect
64 $ascDispVect(textBox) configure -font $ascDispVect(font);
65 catch {emacs-bind $ascDispVect(textBox)}
66 bind $ascDispVect(textBox) <F2> Disp_do_Cut
67 bind $ascDispVect(textBox) <F3> Disp_do_Copy
68 bind $ascDispVect(entryBox) <F3> Disp_do_CopyEntry
69 bind $ascDispVect(textBox) <F4> Disp_do_Paste
70 }
71
72 proc Disp_do_CopyEntry {} {
73 global ascDispVect
74 asc_export_selection $ascDispVect(entryBox)
75 event generate $ascDispVect(entryBox) <<Copy>>
76 }
77
78 proc Disp_do_Copy {} {
79 global ascDispVect
80 asc_export_selection $ascDispVect(textBox)
81 event generate $ascDispVect(textBox) <<Copy>>
82 }
83
84 proc Disp_do_Paste {} {
85 global ascDispVect
86 event generate $ascDispVect(textBox) <<Paste>>
87 }
88
89 proc Disp_do_Cut {} {
90 global ascDispVect
91 event generate $ascDispVect(textBox) <<Cut>>
92 }
93
94 #
95 # proc DispSetEntry {line}
96 #----------------------------------------------------------------------
97 # set the subtitle of the display window to $line
98 #----------------------------------------------------------------------
99 proc DispSetEntry {line} {
100 global ascDispVect
101 set ascDispVect(entry) $line
102 }
103
104 proc Disp_do_SaveOptions {} {
105 View_Save_Window_Options display
106 }
107
108 #
109 # proc Disp_Update_View_Buttons {}
110 #----------------------------------------------------------------------
111 # Configure state of the buttons in the view menu
112 #---------------------------------------------------------------------
113 proc Disp_Update_View_Buttons {} {
114 # save option item
115 global ascGlobalVect
116
117 set mb .display.menubar.view
118
119 if {$ascGlobalVect(saveoptions) == 0} {
120 $mb entryconfigure 3 -state disabled
121 } else {
122 $mb entryconfigure 3 -state normal
123 }
124 }
125
126 #
127 # proc DispClear {}
128 #----------------------------------------------------------------------
129 # empty DispTextBox
130 #----------------------------------------------------------------------
131 proc DispClear {} {
132 global ascDispVect
133 $ascDispVect(textBox) delete 1.0 end;
134 }
135
136 #
137 # proc DispInsert2 {infolist {pos "end"}}
138 #----------------------------------------------------------------------
139 # insert list double spaced at pos to ascDispVect(textBox)
140 #----------------------------------------------------------------------
141 proc DispInsert2 {infolist {pos "end"}} {
142 global ascDispVect
143 foreach info $infolist {
144 $ascDispVect(textBox) insert $pos "$info\n\n";
145 }
146 }
147
148 #
149 # proc DispInsert {infolist {pos "end"}}
150 #----------------------------------------------------------------------
151 # insert list at pos to ascDispVect(textBox)
152 #----------------------------------------------------------------------
153 proc DispInsert {infolist {pos "end"}} {
154 global ascDispVect
155 foreach info $infolist {
156 $ascDispVect(textBox) insert $pos "$info\n";
157 }
158 }
159 #
160
161 #
162 # proc DispInsert3 {info {pos "end"}}
163 #----------------------------------------------------------------------
164 # insert list at pos to ascDispVect(textBox)
165 #----------------------------------------------------------------------
166 proc DispInsert3 {info {pos "end"}} {
167 global ascDispVect
168 $ascDispVect(textBox) insert $pos ${info}\n;
169 }
170
171
172 # proc FastFileInText {w file}
173 #----------------------------------------------------------------------
174 # read in first 10000 bytes from file to text w
175 #----------------------------------------------------------------------
176 proc FastFileInText {w file} {
177 set f [open $file]
178 $w delete 1.0 end
179 while {![eof $f]} {
180 $w insert end [read $f 10000]
181 }
182 close $f
183 }
184
185
186 #
187 # FileUniqueName {{prefix "/tmp/"}}
188 # FileUniqueName {{prefix "c:/tmp/"}} windoze only
189 #----------------------------------------------------------------------
190 # (guaranteed unique result, within reason,by appending ver)
191 # filename returned will not exist
192 # Returns an id mashed from the process id and the current date.
193 # Assumes the tmp path set on utilities page unless told otherwise.
194 # Prefix should include a trailing / if no leaf prefix is supplied.
195 # eg, if you want a file in /tmp with just a number:
196 # FileUniqueName (because /tmp/ is the FileUniqueName default)
197 # or
198 # FileUniqueName /tmp/
199 # will return /tmp/1234.23454 or similar.
200 # If you want a file with some prefix give full pathname up to end of
201 # prefix:
202 # FileUniqueName /tmp/scratchplot
203 # returns /tmp/scratchplot1234.23545
204 # For a real example see: DispWriteSelection
205 #---------------------------------------------------------------------
206 global tcl_platform
207 ;#ifdef windoze
208 if {[string compare $tcl_platform(platform) "windows"]==0} {
209 proc FileUniqueName {{prefix "c:/temp/"}} {
210 global env
211 if {![file exists $prefix] &&
212 [info exists env(TMPDIR)] && [file exists $env(TMPDIR)]} {
213 set prefix $env(TMPDIR)/
214 }
215 set pidvar [pid]
216 set datevar [clock format [clock seconds] -format %y%m%d%H%M%S]
217 set fid "$prefix$pidvar\.$datevar"
218 set ifid $fid
219 set i 1
220 while {[file exists $ifid]} {set ifid "$fid\.$i" ; incr i}
221 return $ifid
222 }
223 #else
224 } else {
225 proc FileUniqueName {{prefix "/tmp/"}} {
226 set pidvar [pid]
227 set datevar [clock format [clock seconds] -format %y%m%d%H%M%S]
228 set fid "$prefix$pidvar\.$datevar"
229 set ifid $fid
230 set i 1
231 while {[file exists $ifid]} {set ifid "$fid\.$i" ; incr i}
232 return $ifid
233 }
234 }
235 #endif /* windoze */
236 #
237 # DispWriteSelection {win}
238 #---------------------------------------------------------------------
239 # saves to a scratch file the selection of a window
240 # of class Listbox or Text. If no selection is made, saves whole window.
241 # returns name of scratchfile
242 #---------------------------------------------------------------------
243 proc DispWriteSelection {win} {
244
245 global ascUtilVect
246
247 set dispfile [FileUniqueName "$ascUtilVect(asctmp)/ascdissel"];
248 set fid 4
249 # puts "Opening File $dispfile with fd = $jnk";
250 #
251 # Write the entire file if nothing selected.
252 switch [winfo class $win] {
253 {Text} { if {[catch {set l [$win get sel.first sel.last]} ]} {
254 set l [$win get 1.0 end]
255 }
256 catch {set fid [open $dispfile w+]} jnk;
257 puts $fid $l
258 }
259 {Listbox} {
260 catch {set fid [open $dispfile w+]} jnk;
261 if {[$win curselection] == ""} {
262 set last [$win size]
263 for {set l 0} {$l < $last} {incr l} {
264 puts $fid [$win get $l]
265 }
266 } {
267 foreach l [$win curselection] {
268 puts $fid $l
269 }
270 }
271 }
272 {Canvas} {
273 set corners [$win bbox all]
274 set x [lindex $corners 0]
275 set y [lindex $corners 1]
276 set w [expr [lindex $corners 2] - $x]
277 set h [expr [lindex $corners 3] - $y]
278 set ar [expr (1.0*$w)/(1.0*$h)]
279 set rotate 0
280 set pageopt "-pagewidth 6.5i"
281 if {$ar < 0.7222222222} {
282 set pageopt "-pageheight 9.0i"
283 }
284 if {$ar > 1.3846} {
285 set pageopt "-pagewidth 9.0i"
286 set rotate 1
287 }
288 eval $win postscript -file $dispfile -x $x -y $y -width $w \
289 -height $h -rotate $rotate $pageopt
290 }
291 default {error "DispWriteSelection called on unsupported window class"}
292 }
293 catch {close $fid}
294 return $dispfile;
295 }
296
297 #
298 # DispWriteCanvasRegion {win corners}
299 #---------------------------------------------------------------------
300 # saves to a scratch file the region given by corners
301 # of class Canvas. If no selection is made, saves whole window.
302 # returns name of scratchfile
303 #---------------------------------------------------------------------
304 proc DispWriteCanvasRegion {win corners} {
305
306 global ascUtilVect
307
308 set dispfile [FileUniqueName "$ascUtilVect(asctmp)/ascdissel"];
309 set fid 4
310 # puts "Opening File $dispfile with fd = $jnk";
311 #
312 # Write the entire file if nothing selected.
313 set x [lindex $corners 0]
314 set y [lindex $corners 1]
315 set w [expr [lindex $corners 2] - $x]
316 set h [expr [lindex $corners 3] - $y]
317 set ar [expr (1.0*$w)/(1.0*$h)]
318 set rotate 0
319 set pageopt "-pagewidth 6.5i"
320 if {$ar < 0.7222222222} {
321 set pageopt "-pageheight 9.0i"
322 }
323 if {$ar > 1.3846} {
324 set pageopt "-pagewidth 9.0i"
325 set rotate 1
326 }
327 eval $win postscript -file $dispfile -x $x -y $y -width $w \
328 -height $h -rotate $rotate $pageopt
329 catch {close $fid}
330 return $dispfile;
331 }
332
333 #
334 # proc DispPrint {file}
335 #---------------------------------------------------------------------
336 # also used in Probe_do_Print
337 # prints the file with the ToolVect print command set on utils page
338 # OR through dialog
339 #---------------------------------------------------------------------
340 proc DispPrint {file} {
341
342 global ascToolVect
343 if {$file==""} {error "DispPrint called without filename"}
344 if {[file size $file] < 2} { #want more than a newline
345 puts "Will not print empty files!!"
346 return
347 }
348 if {$ascToolVect(printargs) == ""} {
349 set printcmd "lpr";
350 } else {
351 set printcmd $ascToolVect(printargs);
352 puts "Executing process : $printcmd $file";
353 if {[catch {eval exec $printcmd $file} returnval]} {
354 puts stderr "Printing Error : $returnval"
355 }
356 }
357 catch {file delete $file}
358 }
359
360 #
361 # proc DispExecutePrint {}
362 #---------------------------------------------------------------------
363 # display execute.print button
364 #---------------------------------------------------------------------
365 proc DispExecutePrint {} {
366 global ascDispVect
367 Print_configure $ascDispVect(textBox)
368 if {[Print_cancelcheck]} {
369 return
370 }
371 DispPrint [DispWriteSelection $ascDispVect(textBox)]
372 HUB_Message_to_HUB WINDOWPRINTED DISPLAY
373 }
374
375 #
376 # proc Is_Fundamental_Type {type}
377 #---------------------------------------------------------------------
378 # boolean check if type is one of the know compiler types.
379 # This code should really be based on the fundamental type list in
380 # C-land. Otherwise if new fundamental types are added or removed
381 # we could be caught flat footed.
382 #---------------------------------------------------------------------
383 proc Is_Fundamental_Type {type} {
384 if {$type == "real" || $type == "integer" ||
385 $type == "boolean" || $type == "set" ||
386 $type == "symbol" || $type == "mutable_integer"} {
387 return 1;
388 } {
389 return 0;
390 }
391 }
392
393 #
394 # proc Disp_Raise_Alert {errmsg {label "Error"} {geom "200x70+480+200"}}
395 #---------------------------------------------------------------------
396 # display error box
397 #---------------------------------------------------------------------
398 proc Disp_Raise_Alert {errmsg {label "Error"} {geom "200x70+480+200"}} {
399 Script_Raise_Alert $errmsg $label $geom
400 }
401 #
402 # proc Disp_ShowCode {type inputfile outputfile}
403 #---------------------------------------------------------------------
404 # button internals for Disp_do_ShowCode
405 #---------------------------------------------------------------------
406 proc Disp_ShowCode {type inputfile outputfile} {
407 # cant show code for fundamental types
408 global ascDispVect env
409 if {$type == "" || [Is_Fundamental_Type $type]} {
410 Script_Raise_Alert "Cannot show code for fundamental types" FYI
411 }
412 set nok 0
413 if {$ascDispVect(ShowComments)} {
414 set nok \
415 [catch \
416 {libr_extract_type -c $type $inputfile -s} \
417 err_msg]
418 } else {
419 set nok \
420 [catch \
421 {libr_extract_type $type $inputfile -s} \
422 err_msg]
423 }
424 if {$nok} {
425 Disp_Raise_Alert "Error encountered \n in displaying code :$err_msg"
426 return 1;
427 }
428 set ascDispVect(lastcode) $err_msg
429 return 0;
430 }
431
432 #
433 # proc Disp_do_ShowCode {}
434 #---------------------------------------------------------------------
435 # library display.code button
436 #---------------------------------------------------------------------
437 proc Disp_do_ShowCode {args} {
438 global ascLibrVect ascDispVect ascUtilVect
439 set type $args
440 if {$args == ""} {
441 set type $ascLibrVect(selectedtype);
442 if {$type == ""} {
443 return;
444 }
445 }
446 set inputfile [file_by_type $type]
447 set outputfile [FileUniqueName "$ascUtilVect(asctmp)/ascdiscode"]
448 # outputfile unused in Disp_ShowCode
449 set result [Disp_ShowCode $type $inputfile $outputfile]
450 if {!$result} {
451 DispClear
452 $ascDispVect(textBox) insert end $ascDispVect(lastcode)
453 } else {
454 return
455 }
456 if {0} { #ifdef ignore, obsolete
457 if {[file exists $outputfile]} {
458 file delete $outputfile
459 }
460 }
461 DispSetEntry "Code for $type"
462 newraise .display
463 }
464 #
465 # proc Disp_do_ShowAncestry {}
466 #---------------------------------------------------------------------
467 # library display.ancestry button
468 #---------------------------------------------------------------------
469 proc Disp_do_ShowAncestry {} {
470 global ascLibrVect
471 if {$ascLibrVect(selectedtype) == ""} {
472 return;
473 }
474 Type_OpenTree $ascLibrVect(selectedtype)
475 return
476 }
477 #
478 # proc Disp_do_ShowPendings {}
479 #---------------------------------------------------------------------
480 # library display.code button
481 #---------------------------------------------------------------------
482 proc Disp_do_ShowPendings {} {
483 global ascDispVect ascUtilVect ascSimsVect
484 set sim $ascSimsVect(selectedsim)
485 if {$sim == ""} {
486 return;
487 }
488 set outputfile [FileUniqueName "$ascUtilVect(asctmp)/ascdispending"]
489 simlistpending $sim $outputfile
490 if {[file exists $outputfile]} {
491 FastFileInText $ascDispVect(textBox) $outputfile
492 file delete $outputfile
493 }
494 DispSetEntry "Pendings for $sim"
495 # puts "raising display"
496 newraise .display
497 }
498 #
499 # proc DispHkeep {{prefix "adisp"}}
500 #---------------------------------------------------------------------
501 # remove files /tmp/prefix*
502 #---------------------------------------------------------------------
503 proc DispHkeep {{prefix "adisp"}} {
504 catch {file delete [glob /tmp/$prefix*]}
505 }
506
507 #
508 # proc revlist {list}
509 #---------------------------------------------------------------------
510 # return a list in reverse order of the one sent
511 #---------------------------------------------------------------------
512 proc revlist {list} {# used for reversing lists.
513 set b "";
514 foreach i $list {
515 set b [linsert $b 0 $i]
516 }
517 return $b;
518 }
519
520 #
521 # proc DispPrintTypeTree {type}
522 #---------------------------------------------------------------------
523 # pretty print a type to ascDispVect(textBox) for DispDoHierarchy
524 #---------------------------------------------------------------------
525 proc DispPrintTypeTree {type} {# used by DispDoHierrarchy
526 global ascDispVect
527 set TAB 4
528 set reflist [drefines_me $type]
529 set nch [llength $reflist]
530 if {$nch == "0"} {
531 return
532 }
533 set reflist [lsort $reflist]
534 incr ascDispVect(indent) $TAB
535 foreach ref $reflist {
536 if {$ref != "$type"} {
537 for {set i 1} {$i <= $ascDispVect(indent)} {incr i} {
538 $ascDispVect(textBox) insert end " "
539 }
540 $ascDispVect(textBox) insert end "$ref\n"
541 DispPrintTypeTree "$ref"
542 }
543 }
544 incr ascDispVect(indent) -$TAB
545 }
546
547 #
548 # proc DispPrintHierarchy {{dlist ""}}
549 #---------------------------------------------------------------------
550 # print hierarchy. used to Disp_do_Hierarchy
551 #---------------------------------------------------------------------
552 proc DispPrintHierarchy {{dlist ""}} {# used to Display hierarchy
553 global ascDispVect
554 foreach type $dlist {
555 if {[disroot_type $type] == "1"} {
556 $ascDispVect(textBox) insert end "$type\n"
557 DispPrintTypeTree $type
558 }
559 }
560 }
561
562 #
563 # proc Disp_do_Hierarchy
564 #---------------------------------------------------------------------
565 # library display.hierarchy button
566 #---------------------------------------------------------------------
567 proc Disp_do_Hierarchy {} { # attached to the Library Hierarchy Button
568 global ascDispVect ascLibrVect
569
570 catch {DispClear} jnk;
571 DispPrintHierarchy [disp define];
572 DispSetEntry "Refinement line for all types"
573 set location [$ascDispVect(textBox) search \
574 -exact $ascLibrVect(selectedtype) 1.0 end]
575 $ascDispVect(textBox) see $location
576 newraise .display
577 }
578
579 #
580 # proc Disp_do_PrintExtFuncLibrary
581 #---------------------------------------------------------------------
582 # write to window the external functions library.
583 #---------------------------------------------------------------------
584 proc Disp_do_PrintExtFuncLibrary {} {
585 global ascDispVect
586 set result [libr_query -externalfunctions]
587 if {[string compare $result {}] == 0} {
588 set result {NONE-LOADED {There are no external, global functions defined}}
589 }
590 catch {DispClear}
591 foreach info $result {
592 foreach p $info {
593 $ascDispVect(textBox) insert end "$p\n"
594 }
595 $ascDispVect(textBox) insert end "\n"
596 }
597 newraise .display
598 }
599
600 #
601 # proc Disp_do_Font {}
602 #---------------------------------------------------------------------
603 # font select button for display window
604 # uses xfontsel widget for display fonts. wrapper baa
605 #---------------------------------------------------------------------
606 proc Disp_do_Font {args} {
607 global ascDispVect
608 set font ""
609 if {$args != ""} {
610 set font $args
611 } else {
612 set font [ascFontGet]
613 }
614 if {"$font" == ""} {
615 return;
616 }
617 $ascDispVect(textBox) configure -font $font
618 set ascDispVect(font) [lindex [$ascDispVect(textBox) configure -font] 4]
619 DispRepack
620 }
621
622 #
623 # proc DispRepack {}
624 #---------------------------------------------------------------------
625 # repack the listbox after fontset
626 #---------------------------------------------------------------------
627 proc DispRepack {} {
628 pack forget .display.main_frm .display.entry_frm
629 pack append .display .display.main_frm {top frame center expand fill} \
630 .display.entry_frm {top frame center fillx}
631
632 }
633 #
634 # Disp_do_Help {}
635 # Disp_do_BindHelp {}
636 #---------------------------------------------------------------------
637 # help calls for On viewing and On DISPLAY
638 #----------------------------------------------------------------------
639 proc Disp_do_Help {} {
640 Help_button display
641 }
642 proc Disp_do_BindHelp {} {
643 Help_button display.help ondisplay
644 }
645
646 #
647 # proc TextSearch {w string tag}
648 #----------------------------------------------------------------------
649 # Some fun stuff
650 # The utility procedure below searches for all instances of a
651 # given string in a text widget and applies a given tag to each
652 # instance found.
653 # Arguments:
654 #
655 # w - The window in which to search. Must be a text widget.
656 # string - The string to search for. The search is done using
657 # exact matching only; no special characters.
658 # tag - Tag to apply to each instance of a matching string.
659 #----------------------------------------------------------------------
660 proc TextSearch {w string tag} {
661 $w tag remove search 0.0 end
662 scan [$w index end] %d numLines
663 set l [string length $string]
664 for {set i 1} {$i <= $numLines} {incr i} {
665 if {[string first $string [$w get $i.0 $i.1000]] == -1} {
666 continue
667 }
668 set line [$w get $i.0 $i.1000]
669 set offset 0
670 while 1 {
671 set index [string first $string $line]
672 if {$index < 0} {
673 break
674 }
675 incr offset $index
676 $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l]
677 incr offset $l
678 set line [string range $line [expr $index+$l] 1000]
679 }
680 }
681 }

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