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

Contents of /trunk/tcltk98/TK/TypetreeProc.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: 24187 byte(s)
try again to commit moving tcl stuff
1 # TypetreeProc.tcl: a type hierarchy browser
2 # by Benjamin A. Allan
3 # October 12, 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.14 $
6 # Last modified on: $Date: 1998/06/18 15:55:04 $
7 # Last modified by: $Author: mthomas $
8 # Revision control file: $RCSfile: TypetreeProc.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 # global arrays _ATTV since noone should touch it and it is unset often
30 # _attv since noone should touch it
31 # ascTypetreeVect which may be of some interest
32 # i goes from 0
33 # _ATTV($l) is the number of types at level l
34 # _ATTV($l,name.$i) is the name of the ith type at level l
35 # _ATTV($l,nump.$i) is the number of the parent type at level l-1
36 # of type i on level l
37 # _ATTV($name) is the coordinates of the box for type $name
38 # _ATTV lmax is the maximum depth
39 # _ATTV wmax is the maximum width of all levels.
40 # _ATTV($l.maxname) is the length of the longest name on a given level l
41 # _ATTV(horzwidth) is the character with of the region plotted horizontally
42 # _attv(back.$i) the backtrack info for trees
43 # _attv(backlength) the depth of backtrack history.
44
45 # uses drefinement_tree
46 # predicated on a recursive list of refinements from a given type
47 # assumes no multiple inheritance is allowed.
48 #
49 # proc Type_Handle_Sourceread {args}
50 #------------------------------------------------------------------------
51 # eliminate the backtrace of hierarchies and wipe the canvas
52 #------------------------------------------------------------------------
53 proc Type_Handle_Sourceread {args} {
54 Type_do_OK
55 }
56 #
57 # proc Type_getroot {typename}
58 #------------------------------------------------------------------------
59 # get the name of the root type of a given type.
60 #------------------------------------------------------------------------
61 proc Type_getroot {typename} {
62 if {$typename==""} {return ""}
63 if {![libr_query -exists -type $typename] } {return ""}
64 set list "[hier $typename]"
65 if {$list ==""} {return $typename}
66 set c [llength $list]
67 set root [lindex $list [expr $c - 1]]
68 return $root
69 }
70 #
71 # proc Type_enable_backtrack {past}
72 #------------------------------------------------------------------------
73 #bind the backtrack button to the most recent previous call. if none,
74 #disable the button.
75 #------------------------------------------------------------------------
76 proc Type_enable_backtrack {past} {
77 global _attv ascTypeTreeVect
78 set ascTypeTreeVect(previoustree) $past
79 if {$past < 0} {
80 $ascTypeTreeVect(backbutton) configure -state disabled
81 } else {
82 $ascTypeTreeVect(backbutton) configure -state normal \
83 }
84 }
85 #
86 # proc Type_do_Ancestry {typename xleft ytop}
87 #------------------------------------------------------------------------
88 # plot a type hierarchy for the type given where upleft is x y corner to
89 # start at.
90 #------------------------------------------------------------------------
91 proc Type_do_Ancestry {typename xleft ytop} {
92 global _ATTV _attv
93 set roottype "[Type_getroot "$typename"]"
94 if {$roottype == ""} {return}
95 Type_clearcan
96 if {[info exists _ATTV]} {unset _ATTV}
97 set _ATTV(lmax) 0
98 set _ATTV(wmax) 0
99 set _ATTV(maxchar) 0
100 set _ATTV(horzwidth) 0
101 set newback "[drefinement_tree $roottype]"
102 Type_ModelRefs "$newback" 0 -1
103 if {[info exists _attv(backlength)]} {
104 Type_enable_backtrack [expr $_attv(backlength) -1]
105 set _attv(back.$_attv(backlength)) $newback
106 incr _attv(backlength)
107 } else {
108 set _attv(backlength) 1
109 set _attv(back.0) $newback
110 }
111 for {set i 0} {$i <= $_ATTV(lmax)} {incr i} {
112 incr _ATTV(horzwidth) $_ATTV($i.maxname)
113 if {$_ATTV(wmax) < $_ATTV($i)} {
114 set _ATTV(wmax) $_ATTV($i)
115 }
116 if {$_ATTV(maxchar) < $_ATTV($i.width)} {
117 set _ATTV(maxchar) $_ATTV($i.width)
118 }
119 }
120 if {$_ATTV(wmax) <6} {
121 Type_PlotdagVert "$xleft $ytop"
122 } else {
123 Type_PlotdagHorz "$xleft $ytop"
124 }
125 $_attv(canvas) config -scrollregion [$_attv(canvas) bbox all]
126 Type_boxtext $typename
127 }
128
129 #
130 # proc Type_Redo_Ancestry {number}
131 #------------------------------------------------------------------------
132 # plot a type hierarchy for the type given where upleft is x y corner to
133 # start at.
134 #------------------------------------------------------------------------
135 proc Type_Redo_Ancestry {number} {
136 global _ATTV _attv ascTypeTreeVect
137 set newback "$_attv(back.$number)"
138 set _attv(backlength) [expr $number+1]
139 Type_enable_backtrack [expr $number -1]
140 Type_clearcan
141 if {[info exists _ATTV]} {unset _ATTV}
142 set _ATTV(lmax) 0
143 set _ATTV(wmax) 0
144 set _ATTV(maxchar) 0
145 set _ATTV(horzwidth) 0
146 Type_ModelRefs "$newback" 0 -1
147 for {set i 0} {$i <= $_ATTV(lmax)} {incr i} {
148 incr _ATTV(horzwidth) $_ATTV($i.maxname)
149 if {$_ATTV(wmax) < $_ATTV($i)} {
150 set _ATTV(wmax) $_ATTV($i)
151 }
152 if {$_ATTV(maxchar) < $_ATTV($i.width)} {
153 set _ATTV(maxchar) $_ATTV($i.width)
154 }
155 }
156 if {$_ATTV(wmax) <4} {
157 Type_PlotdagVert "0 0"
158 } else {
159 Type_PlotdagHorz "0 0"
160 }
161 $_attv(canvas) config -scrollregion [$_attv(canvas) bbox all]
162 Type_boxtext ""
163 }
164
165 #
166 # proc Type_PlotdagVert {corner}
167 #------------------------------------------------------------------------
168 # plat the dag contained in _ATTV starting at corner coordinate x y
169 # plot ancestry top to bottom
170 #------------------------------------------------------------------------
171 proc Type_PlotdagVert {corner} {
172 global _ATTV _attv
173 if {[llength $corner]!=2} { error "Type_Plotdag called with bad corner"}
174 set xoff [lindex $corner 0]
175 set yoff [lindex $corner 1]
176 if {$_ATTV(maxchar)==0} {return; # nothing to plot}
177 # get fontsize estimate
178 Type_setlettersize
179 # calc region width
180 set rw [expr $_ATTV(maxchar) * $_attv(fontx)]
181 # calc row height
182 set yh [expr 4* $_attv(fonty)]
183 # calc region height
184 set rh [expr ( $_ATTV(lmax) +1 ) * $yh]
185 set ystart [expr $yoff + $_attv(fonty)]
186 for {set yi 0} {$yi <= $_ATTV(lmax)} {incr yi} { # for all rows
187 set yloc [expr $ystart + $yi*$yh]
188 if {$_ATTV($yi) < $_ATTV(wmax) && $_ATTV($yi.width) < $_ATTV(maxchar)} {
189 # calc x spacing
190 set xw [expr $rw/(1+$_ATTV($yi))]
191 set xstart [expr $xoff + $xw/2]
192 for {set xi 0} {$xi < $_ATTV($yi)} {incr xi} { # for types in row yi
193 set xloc [expr $xstart + $xi*$xw]
194 set child $_ATTV($yi,name.$xi)
195 Type_addtext $child $xloc $yloc
196 if {$yi !=0} {
197 set parent $_ATTV([expr $yi -1],name.$_ATTV($yi,nump.$xi))
198 Type_addarrowvert $child $parent
199 }
200 }
201 } else {
202 set x0 [expr 0.5*[string length $_ATTV($yi,name.0)] * $_attv(fontx)]
203 set child $_ATTV($yi,name.0)
204 Type_addtext $child $x0 $yloc
205 if {$yi !=0} {
206 set parent $_ATTV([expr $yi -1],name.$_ATTV($yi,nump.0))
207 Type_addarrowvert $child $parent
208 }
209 for {set xi 1} {$xi < $_ATTV($yi)} {incr xi} { # for types in row yi
210 set child $_ATTV($yi,name.$xi)
211 set leftchild $_ATTV($yi,name.[expr $xi-1])
212 set left [lindex $_attv(bb.$leftchild) 2]
213 set xloc \
214 [expr $_attv(fontx)*(1 + 0.5* [string length $child]) + $left]
215 Type_addtext $child $xloc $yloc
216 if {$yi !=0} {
217 set parent $_ATTV([expr $yi -1],name.$_ATTV($yi,nump.$xi))
218 Type_addarrowvert $child $parent
219 }
220 }
221 }
222 }
223 }
224
225 #
226 # Type_getxcenter {left name}
227 #------------------------------------------------------------------------
228 # return the xvalue to plot a name at so that the left edge of the
229 # name is at coordinate left
230 #------------------------------------------------------------------------
231 proc Type_getxcenter {left name} {
232 global _attv
233 set _attv(scratch) [$_attv(canvas) create text 0 0]
234 $_attv(canvas) itemconfigure $_attv(scratch) \
235 -justify left \
236 -text $name
237 set _attv(scratchbb) [$_attv(canvas) bbox $_attv(scratch)]
238 $_attv(canvas) delete $_attv(scratch)
239 return [expr $left - [lindex $_attv(scratchbb) 0]]
240 }
241 #
242 # proc Type_PlotdagHorz {corner}
243 #------------------------------------------------------------------------
244 # plat the dag contained in _ATTV starting at corner coordinate x y
245 # plot ancestry left to right
246 #------------------------------------------------------------------------
247 proc Type_PlotdagHorz {corner} {
248 global _ATTV _attv
249 if {[llength $corner]!=2} { error "Type_Plotdag called with bad corner"}
250 set xoff [lindex $corner 0]
251 set yoff [lindex $corner 1]
252 if {$_ATTV(maxchar)==0} {return; # nothing to plot}
253 # get fontsize estimate
254 Type_setlettersize
255 # calc region width
256 set rw [expr ($_ATTV(horzwidth) + 4*$_ATTV(lmax)) * $_attv(fontx)]
257 # calc row height
258 set yh [expr 1.1* $_attv(fonty)]
259 # calc region height
260 set rh [expr ( $_ATTV(wmax) +1 ) * $yh]
261 set xstart $xoff
262 set nextstart $xoff
263 #children are by child xi on level yi, regardless of graph orientation
264 # coordinates are otherwise xsub is a horz and ysub a vert coord
265 for {set yi 0} {$yi <= $_ATTV(lmax)} {incr yi} { # for all levels yi
266 if {$yi==0} {
267 set xstart $xoff
268 } else {
269 set xstart [expr $nextstart + 3 *$_attv(fontx)]
270 }
271 # calc y spacing
272 set yw [expr $rh/(1+$_ATTV($yi))]
273 set ystart [expr $yoff + $_attv(fonty)]
274 for {set xi 0} {$xi < $_ATTV($yi)} {incr xi} { # for types on level yi
275 set yloc [expr $ystart + $xi*$yw]
276 set child $_ATTV($yi,name.$xi)
277 set xloc [Type_getxcenter $xstart $child]
278 Type_addtext $child $xloc $yloc
279 if {$yi !=0} {
280 set parent $_ATTV([expr $yi -1],name.$_ATTV($yi,nump.$xi))
281 Type_addarrowhorz $child $parent
282 }
283 set cright [lindex $_attv(bb.$child) 2]
284 if {$cright > $nextstart} {set nextstart $cright}
285 }
286 }
287 }
288
289
290 #
291 # proc Type_ModelRefs {tlist lvl parent}
292 #------------------------------------------------------------------------
293 # prepare _ATTV with hierarchy data given by tlist.
294 #------------------------------------------------------------------------
295 proc Type_ModelRefs {tlist lvl parent} {
296 global _ATTV
297 if {[llength $tlist] !=0 } {
298 if {$_ATTV(lmax) < $lvl} {set _ATTV(lmax) $lvl}
299 foreach child $tlist {
300 if {![info exists _ATTV($lvl)]} {
301 set _ATTV($lvl) 0
302 set _ATTV($lvl.width) 0
303 set _ATTV($lvl.maxname) 0
304 }
305 set name [lindex $child 0]
306 set sl [string length $name]
307 if {$_ATTV($lvl.maxname) < $sl} {set _ATTV($lvl.maxname) $sl}
308 set _ATTV($lvl,name.$_ATTV($lvl)) $name
309 incr _ATTV($lvl.width) [expr 2 + [string length $name]]
310 set _ATTV($lvl,nump.$_ATTV($lvl)) $parent
311 Type_ModelRefs [lindex $child 1] [expr $lvl + 1] $_ATTV($lvl)
312 incr _ATTV($lvl)
313 }
314 }
315 }
316 #
317 # proc Type_dis {children lvl}
318 #------------------------------------------------------------------------
319 # this gives a quick type list with row indices
320 # children is of the drefinement_tree variety.
321 #------------------------------------------------------------------------
322 proc Type_dis {children lvl} {
323 if {[llength $children] != 0} {
324 foreach child $children {
325 puts "name: [lindex $child 0] level: $lvl"
326 set nextlist [lindex $child 1]
327 dis $nextlist [expr $lvl +1]
328 }
329 }
330 }
331
332 #
333 # proc Type_do_Atoms {}
334 #------------------------------------------------------------------------
335 # display the type definition differential for a type given and
336 # set Up a list of the types referenced by IRT, ISA IN the
337 # complete definition. Type list excludes MODEL types.
338 #------------------------------------------------------------------------
339 proc Type_do_Atoms {} {
340 global ascTypeTreeVect
341 if {$ascTypeTreeVect(curtype)==""} {return}
342 set err [Type_show_diffcode "$ascTypeTreeVect(curtype)"]
343 if {$err} {return}
344 set list ""
345 set list "[dgetparts ATOMS $ascTypeTreeVect(curtype)]"
346 global ascListSelectBox ascLibrVect
347 set ascListSelectBox(grab) 0
348 set ascListSelectBox(btn3name) ""
349 set ascListSelectBox(btn4name) ""
350 set ascListSelectBox(btn5name) ""
351 set ascListSelectBox(btn3destroy) 1
352 set ascListSelectBox(btn4destroy) 0
353 set ascListSelectBox(btn4command) ""
354 set ascListSelectBox(title) "Atom parts"
355 set ascListSelectBox(toplevelname) ".typemodels"
356 set ascListSelectBox(font) $ascLibrVect(font)
357 set ascListSelectBox(selectmode) browse
358 set ascListSelectBox(headline) "ATOM types in $ascTypeTreeVect(curtype):"
359 set alist [lsort $list]
360 set button [AscListSelectBox $alist \
361 250x240[setpos .typetree 50 20]]
362 if {$button==2} {return}
363 Type_do_Ancestry "$ascListSelectBox(itemselected)" 0 0
364 }
365
366 #
367 # proc Type_do_Help {} {
368 #------------------------------------------------------------------------
369 # display help on this widget
370 #------------------------------------------------------------------------
371 proc Type_do_Help {} {
372 Help_button library.typetree
373 }
374
375 #
376 # proc Type_do_Code {} {
377 #------------------------------------------------------------------------
378 # display the code for a type a la ddefine
379 #------------------------------------------------------------------------
380 proc Type_do_Code {} {
381 global ascUtilVect ascTypeTreeVect ascDispVect
382
383 set jnk ""
384 set type "$ascTypeTreeVect(curtype)"
385 if {$type==""} {return}
386 set outputfile [FileUniqueName $ascUtilVect(asctmp)/ascdiscode]
387 set result [catch {ddefine $type $outputfile} jnk]
388 if {$result == "0"} {
389 FastFileInText $ascDispVect(textBox) $outputfile
390 }
391 if {[file exists $outputfile]} {
392 file delete $outputfile
393 }
394 DispSetEntry "Internal code for $type"
395 newraise .display
396 }
397
398 #
399 # proc Type_do_Back {} {
400 #------------------------------------------------------------------------
401 # display all the root types in the system for selection.
402 #------------------------------------------------------------------------
403 proc Type_do_Back {} {
404 global ascTypeTreeVect
405 Type_Redo_Ancestry $ascTypeTreeVect(previoustree)
406 }
407
408 #
409 # proc Type_do_Print {} {
410 #------------------------------------------------------------------------
411 # print the type window
412 #------------------------------------------------------------------------
413 proc Type_do_Print {} {
414 global ascTypeTreeVect
415 Print_configure $ascTypeTreeVect(windowname) Printer
416 if {[Print_cancelcheck]} {
417 return
418 }
419 DispPrint [DispWriteSelection $ascTypeTreeVect(canvas)]
420 HUB_Message_to_HUB WINDOWPRINTED TYPETREE
421 }
422 #
423 # proc Type_do_OK {} {
424 #------------------------------------------------------------------------
425 # close the type window
426 #------------------------------------------------------------------------
427 proc Type_do_OK {} {
428 global ascTypeTreeVect _attv _ATTV
429 if {![winfo exists $ascTypeTreeVect(windowname)]} {return}
430 Type_clearcan
431 unset _attv
432 DestroyWindow.typetree
433 }
434
435 #
436 # proc Type_do_Roots {} {
437 #------------------------------------------------------------------------
438 # display all the root types in the system for selection.
439 #------------------------------------------------------------------------
440 proc Type_do_Roots {} {
441 global ascListSelectBox ascLibrVect
442 set list ""
443 catch {set list [libr_query -roottypes]}
444 set ascListSelectBox(grab) 0
445 set ascListSelectBox(btn3name) ""
446 set ascListSelectBox(btn4name) ""
447 set ascListSelectBox(btn5name) ""
448 set ascListSelectBox(btn3destroy) 1
449 set ascListSelectBox(btn4destroy) 0
450 set ascListSelectBox(btn4command) ""
451 set ascListSelectBox(title) "Root types"
452 set ascListSelectBox(toplevelname) ".typeroots"
453 set ascListSelectBox(font) $ascLibrVect(font)
454 set ascListSelectBox(selectmode) browse
455 set ascListSelectBox(headline) "Hierarchy roots:"
456 set alist [lsort $list]
457 set button [AscListSelectBox $alist \
458 250x240[setpos .typetree 50 20]]
459 if {$button==2} {return}
460 Type_do_Ancestry "$ascListSelectBox(itemselected)" 0 0
461 }
462
463 #
464 # proc Type_show_diffcode {type}
465 #------------------------------------------------------------------------
466 # display the code that is new IN this type compared to the type it
467 # refines. return 1 if bad request, 0 if ok.
468 #------------------------------------------------------------------------
469 proc Type_show_diffcode {type} {
470 global ascUtilVect ascDispVect
471 if {![libr_query -exists -type $type] } {return "1"}
472 set list "[hier $type]"
473 # if {$list==""} {return 0}
474 set outputfile [FileUniqueName "$ascUtilVect(asctmp)/ascdiscode"]
475 set result [catch {ddiffdefine $type $outputfile} jnk]
476 if {$result == "0"} {
477 FastFileInText $ascDispVect(textBox) $outputfile
478 }
479 if {[file exists $outputfile]} {
480 file delete $outputfile
481 }
482 DispSetEntry "Incremental code for $type"
483 newraise .display
484 return 0
485 }
486
487 #
488 # proc Type_do_Parts {} {
489 #------------------------------------------------------------------------
490 # display the type definition differential for a type given and
491 # set Up a list of the types referenced by IRT, ATS, ISA IN the
492 # complete definition. Type list excludes ATOM types.
493 #------------------------------------------------------------------------
494 proc Type_do_Parts {} {
495 global ascTypeTreeVect
496 if {$ascTypeTreeVect(curtype)==""} {return}
497 set err [Type_show_diffcode "$ascTypeTreeVect(curtype)"]
498 if {$err} {return}
499 set list ""
500 set list "[dgetparts MODELS $ascTypeTreeVect(curtype)]"
501 global ascListSelectBox ascLibrVect
502 set ascListSelectBox(grab) 0
503 set ascListSelectBox(btn3name) ""
504 set ascListSelectBox(btn4name) ""
505 set ascListSelectBox(btn5name) ""
506 set ascListSelectBox(btn3destroy) 1
507 set ascListSelectBox(btn4destroy) 0
508 set ascListSelectBox(btn4command) ""
509 set ascListSelectBox(title) "Model parts"
510 set ascListSelectBox(toplevelname) ".typemodels"
511 set ascListSelectBox(font) $ascLibrVect(font)
512 set ascListSelectBox(selectmode) browse
513 set ascListSelectBox(headline) "MODEL types in $ascTypeTreeVect(curtype):"
514 set alist [lsort $list]
515 set button [AscListSelectBox $alist \
516 250x240[setpos .typetree 50 20]]
517 if {$button==2} {return}
518 Type_do_Ancestry "$ascListSelectBox(itemselected)" 0 0
519 }
520
521
522
523 #
524 # proc Type_OpenTree {args}
525 #------------------------------------------------------------------------
526 # startup the typetree window. if args, first element assumed to be type
527 #------------------------------------------------------------------------
528 proc Type_OpenTree {args} {
529 global ascTypeTreeVect _attv
530 set _attv(canvas) $ascTypeTreeVect(canvas)
531 if {![winfo exists $ascTypeTreeVect(windowname)]} {
532 set _attv(backlength) 0
533 set ascTypeTreeVect(geometry) [osgpos 400x300[setpos .library 40 40]]
534 VShowWindow.typetree
535 Type_enable_backtrack -1
536 set _attv(backlength) 0
537 } else {
538 newraise $ascTypeTreeVect(windowname)
539 }
540 if {$args!=""} {
541 set type [lindex $args 0]
542 Type_do_Ancestry $type 0 0
543 }
544 }
545 #
546 # proc set_Typetree_Defaults {} {
547 #------------------------------------------------------------------------
548 # display all the model child declarations of a type
549 #------------------------------------------------------------------------
550 proc set_Typetree_Defaults {} {
551 global _attv ascTypeTreeVect
552 set ascTypeTreeVect(backbutton) .typetree.mb_frm.back_btn
553 set ascTypeTreeVect(windowname) .typetree
554 set ascTypeTreeVect(canvas) .typetree.can.canvas2
555 set _attv(canvas) $ascTypeTreeVect(canvas)
556 set ascTypeTreeVect(geometry) 400x300+20+20
557 }
558
559 # canvas internals
560 #------------------------------------------------------------------------
561 #
562 #------------------------------------------------------------------------
563 #erase the canvas and clean out anything that we can afford to from the
564 # attv array. any persistent working variables should be added here.
565 # destroys the current map of text ids and bboxes.
566 #------------------------------------------------------------------------
567 proc Type_clearcan {} {
568 global _attv
569 Type_setlettersize
570 set fontx $_attv(fontx)
571 set fonty $_attv(fonty)
572 set canvas $_attv(canvas)
573 set bl(num) $_attv(backlength)
574 for {set i 0} {$i < $bl(num)} {incr i} {
575 set bl($i) $_attv(back.$i)
576 }
577 $_attv(canvas) delete all
578 unset _attv
579 for {set i 0} {$i < $bl(num)} {incr i} {
580 set _attv(back.$i) $bl($i)
581 }
582 set _attv(backlength) $bl(num)
583 set _attv(fontx) $fontx
584 set _attv(fonty) $fonty
585 set _attv(canvas) $canvas
586 }
587 #
588 # proc Type_addtext {t x y}
589 #------------------------------------------------------------------------
590 # returns the id of the text added at x y. text is bound and has value t
591 #------------------------------------------------------------------------
592 proc Type_addtext {t x y} { # add text t to canvas at x y with type bindings
593 global _attv
594 set _attv(id.$t) [$_attv(canvas) create text $x $y]
595 $_attv(canvas) itemconfigure $_attv(id.$t) \
596 -justify left \
597 -text $t
598 set _attv(bb.$t) [$_attv(canvas) bbox $_attv(id.$t)]
599 $_attv(canvas) bind $_attv(id.$t) <B1-ButtonRelease> \
600 "Type_boxtext \{$t\}"
601 return $_attv(id.$t)
602 }
603
604 #
605 # proc Type_boxtext {t}
606 #------------------------------------------------------------------------
607 # add a rectangle around an existing text value t and trash last rectangle
608 #------------------------------------------------------------------------
609 proc Type_boxtext {t} {
610 global _attv ascTypeTreeVect
611 catch {$_attv(canvas) delete $_attv(currect)}
612 set ascTypeTreeVect(curtype) $t
613 if {$t==""} {return}
614 set _attv(currect) [eval $_attv(canvas) create rectangle $_attv(bb.$t)]
615 }
616 #
617 # proc Type_setlettersize {}
618 #------------------------------------------------------------------------
619 # get a guess for lettersizes (x,y IN pixels) IN current canvas
620 #------------------------------------------------------------------------
621 proc Type_setlettersize {} {
622 global _attv
623 set uid [$_attv(canvas) create text -10 -10]
624 $_attv(canvas) itemconfigure $uid \
625 -justify left \
626 -text u
627 set corners [$_attv(canvas) bbox $uid]
628 $_attv(canvas) delete $uid
629 set _attv(fontx) [expr [lindex $corners 2] - [lindex $corners 0]]
630 set _attv(fonty) [expr [lindex $corners 3] - [lindex $corners 1]]
631 }
632
633 #------------------------------------------------------------------------
634 # adds an arrow pointing from top of child to bottom of parent, centered
635 #------------------------------------------------------------------------
636 proc Type_addarrowvert {c p} { # c p are text names
637 global _attv
638 # draw an arrow between 2 items c p where c below p
639 set pbox $_attv(bb.$p)
640 set cbox $_attv(bb.$c)
641 set cx [expr ([lindex $cbox 2] - [lindex $cbox 0])/2.0 + [lindex $cbox 0]]
642 set px [expr ([lindex $pbox 2] - [lindex $pbox 0])/2.0 + [lindex $pbox 0]]
643 set cy [expr [lindex $cbox 1] -1]
644 set py [expr [lindex $pbox 3] +1]
645 set _attv(id.a.$c.$p) [$_attv(canvas) create line $cx $cy $px $py]
646 $_attv(canvas) itemconfigure $_attv(id.a.$c.$p) -arrow last
647 }
648 # proc Type_addarrowhorz {child parent}
649 #------------------------------------------------------------------------
650 # adds an arrow pointing from left of child to right of parent, centered
651 #------------------------------------------------------------------------
652 proc Type_addarrowhorz {c p} { # c p are text names
653 global _attv
654 # draw an arrow between 2 items c p where c right of p
655 set pbox $_attv(bb.$p)
656 set cbox $_attv(bb.$c)
657 set cy [expr ([lindex $cbox 3] - [lindex $cbox 1])/2.0 + [lindex $cbox 1]]
658 set py [expr ([lindex $pbox 3] - [lindex $pbox 1])/2.0 + [lindex $pbox 1]]
659 set cx [expr [lindex $cbox 0] -1]
660 set px [expr [lindex $pbox 2] +1]
661 set _attv(id.a.$c.$p) [$_attv(canvas) create line $cx $cy $px $py]
662 $_attv(canvas) itemconfigure $_attv(id.a.$c.$p) -arrow last
663 }
664
665 set_Typetree_Defaults

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