1 # ui-canvas.tcl --
2 #
3 # This is the class which MediaBoard uses to draw items on
4 #
5 # Copyright (c) 1993-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30
31
32 # Class MBCanvas
33 # This is the class which MediaBoard uses to draw items on
34 # It accepts all commands that tkCanvas understand and more.
35 #
36
37 # creates the underlying canvas canvas <br>
38 # <u>parent</u>: parent widget path
39 # <u>ops</u>: additional parameters for the underlying tkcanvas
40 #
41 MBCanvas public create_canvas {parent ops} {
42 $self instvar path_ hilitC_
43
44 $self add_default canvHighlighColor blue
45 $self add_default showOwnerTip 1
46
47 set path_ [eval canvas $parent.$self $ops -closeenough 2 \
48 -confine 0 \
49 -bd 0 -highlightthickness 0 -relief flat \
50 -highlightcolor grey]
51
52 $self setpath $path_
53 # sets transparent GIF's to be white
54 WidgetClass transparent_gif [$path_ cget -bg]
55
56 mtrace trcVerbose "created canvas $path_"
57
58 set hilitC_ [$self get_option canvHighlightColor]
59 if {$hilitC_ == {}} {
60 set hilitC_ blue
61 }
62 $self set ownerTip_ [$self get_option showOwnerTip]
63 $self set after_id_ 0
64 $self set omittedSrc_ {}
65 $self set zoomPolicy_ "fix to view"
66 bind $path_ <Configure> [list $self reconfig %w %h]
67 }
68
69 # tells canvas to omit showing owner banners for src
70 # <i>the current implementation can only omit one (i.e. the last) source
71 #
72 MBCanvas public omitShowOwner {src} {
73 # can only omit one source for now
74 $self set omittedSrc_ $src
75 }
76
77 # if <u>show</u> is 1, turn owner banners on, else off
78 #
79 MBCanvas instproc showOwner {show} {
80 $self set ownerTip_ $show
81 }
82
83 # retrieves the underlying tkcanvas. <br>
84 # this function is here for efficiency reason, use of it should be restricted
85 #
86 MBCanvas public get_win {} {
87 return [$self set path_]
88 }
89
90 # hides the marker for the current item
91 #
92 MBCanvas public unhilit {} {
93 $self instvar path_ marker_
94 if ![info exists marker_] { return }
95
96 $path_ itemconfig marker -outline {}
97
98 # FIXME: Canvas bug: rectangles with no outline and fill should not
99 # be in the outline calculation!
100 #
101 # use the bbox another item on the canvas so that the marker
102 # will not interfere with the actual bounding box of the canvas
103 #
104 #puts "in unhilit"
105 set tags [$path_ gettags current]
106 set item [$path_ find withtag current]
107 if {$tags == {}} {
108 set item [$path_ find closest 0 0]
109 if {$item == {}} {
110 return
111 }
112 set tags [$path_ gettags $item]
113 }
114 #puts "current item is '$item', tags is '$tags'"
115 while {-1 != [lsearch -exact $tags ignore]} {
116 set item [$path_ find above $item]
117 #uts "nextItem is '$item'"
118 if {$item == {}} {
119 return
120 }
121 set tags [$path_ gettags $item]
122 #puts "tags in $tags"
123 }
124 # since bbox's usu over estimate,
125 eval $path_ coords marker [$path_ bbox $item]
126 }
127
128 # highlights an item <br>
129 # if <u>itemId</u> is not null, the current item under the cursor is hilited
130 #
131 MBCanvas public hilit { {itemId {}} } {
132 $self instvar marker_ path_ hilitC_
133 if {$itemId == {}} {
134 set tags [$path_ gettags current]
135 if {-1 != [lsearch -exact $tags ignore]} {
136 return
137 }
138 set currId [$path_ find withtag current]
139 set coords [$path_ bbox $currId]
140 } else {
141 set coords [$path_ bbox $itemId]
142 set currId $itemId
143 }
144 if {$coords!={}} {
145 if ![info exists marker_] {
146 set marker_ [$path_ create rect 1 1 1 1 \
147 -tags {marker ignore} \
148 -width 1 -outline {}]
149 }
150 $path_ coords $marker_ \
151 [expr {[lindex $coords 0] - 2}] \
152 [expr {[lindex $coords 1] - 2}] \
153 [expr {[lindex $coords 2] + 2}] \
154 [expr {[lindex $coords 3] + 2}]
155 $path_ itemconfigure $marker_ -outline $hilitC_
156 $path_ raise $marker_
157 }
158 }
159
160 # specify whether to display the owner tip under the cursor
161 # (on if <u>tipping</u> is 1, off if it is zero)
162 #
163 MBCanvas public enable_tip {tipping} {
164 $self instvar ownerTip_ path_ arAfterId_ tip_id_
165 set ownerTip_ $tipping
166 if {$ownerTip_} {
167 set tip_id_ 0
168 $path_ bind all <Enter> "$self sched_tip 0 1"
169 } else {
170 foreach i [array names arAfterId_] {
171 after cancel $arAfterId_($i)
172 set arAfterId_($i) 0
173 }
174 $path_ bind all <Enter> {}
175 $path_ bind all <Leave> {}
176 }
177 }
178
179 # schedules tip for item <u>id</u> <br>
180 # if <u>atpoint</u> is 1, displays the tip under the cursor, otherwise
181 # it is displayed near the corner of the item's bounding box
182 #
183 MBCanvas private sched_tip {id atpoint} {
184 $self instvar tip_id_
185 after cancel $tip_id_
186 set tip_id_ [after 1000 "$self show_owner $id $atpoint"]
187 }
188
189 # displays the owner banner for <u>id</u>. <br>
190 # if <u>atpoint</u> is 1, displays the tip under the cursor, otherwise
191 # it is displayed near the corner of the item's bounding box
192 #
193 MBCanvas private show_owner {id atpoint} {
194 $self instvar path_ arLabelw_ arLabel_ arAfterId_ tip_id_ omittedSrc_
195 if {$id == 0} {
196 set id [$path_ find withtag current]
197 if {$id == {}} return
198 set tags [$path_ gettags $id]
199 # don't add tip for local items
200 # if {-1 != [lsearch -exact $tags local]} {
201 # return
202 # }
203 #uts "newid is $id"
204 }
205 set owner [$self owner $id]
206 if {$owner == {}} {
207 # puts stderr "cannot find owner for $id"
208 return
209 }
210 if {$owner == $omittedSrc_} {
211 return
212 }
213 #uts "$owner is $owner"
214 if $atpoint {
215 set rx [winfo rootx $path_]
216 set wx [winfo pointerx $path_]
217 set ry [winfo rooty $path_]
218 set wy [winfo pointery $path_]
219 set px [$path_ canvasx [expr {$wx - $rx + 5}]]
220 set py [$path_ canvasy [expr {$wy - $ry + 10}]]
221 set anchor nw
222 } else {
223 set bbox [$path_ bbox $id]
224 set result [$self clipxy [expr {[lindex $bbox 0] - 5}] \
225 [expr {[lindex $bbox 1] - 5}]]
226 set px [lindex $result 0]
227 set py [lindex $result 1]
228 set anchor [lindex $result 2]
229 }
230 if {![info exists arLabel_($owner)]} {
231 set arLabel_($owner) [label .l$self$owner \
232 -font [$self get_option smallfont] \
233 -bg beige -relief raised -text [$owner cname]]
234 } else {
235 $arLabel_($owner) configure -text [$owner cname]
236 }
237 if {![info exists arLabelw_($owner)]} {
238 set arLabelw_($owner) [$path_ create window $px $py \
239 -anchor nw]
240 set arAfterId_($owner) {}
241 }
242 $path_ itemconfigure $arLabelw_($owner) -window $arLabel_($owner) \
243 -anchor $anchor
244 $path_ coord $arLabelw_($owner) $px $py
245 after cancel $arAfterId_($owner)
246 if {$atpoint} {
247 $path_ bind $id <Leave> "$self hide_owner $owner"
248 set arAfterId_($owner) [after 5000 "$self hide_owner $owner"]
249 } else {
250 set arAfterId_($owner) [after 5000 "$self hide_owner $owner"]
251 }
252 }
253
254 # hide the owner banner for <u>owner</u>. <u>owner</u> is a source object
255 #
256 MBCanvas private hide_owner {owner} {
257 # puts "in hide owner $owner"
258 $self instvar arLabelw_ arLabel_ arAfterId_ path_
259 after cancel $arAfterId_($owner)
260 set arAfterId_($owner) 0
261 if [info exists arLabel_($owner)] {
262 destroy $arLabel_($owner)
263 unset arLabel_($owner)
264 }
265 }
266
267 # resets the state of the canvas, including standard bindings, focus,
268 # hiliting of markers etc.
269 #
270 MBCanvas public resetBindings {} {
271 $self instvar path_
272
273 $path_ bind local <Enter> {}
274 bind $path_ <Button-1> {}
275 bind $path_ <B1-Motion> {}
276 bind $path_ <ButtonRelease-1> {}
277 $path_ focus {}
278 $self unhilit
279 $self enable_tip [$self set ownerTip_]
280 }
281
282 # updates the current marker position, this is called e.g. when an item
283 # gets deleted, so that the marker won't be over a non-existing item
284 #
285 MBCanvas public resetMarker {} {
286 $self instvar path_
287
288 set tags [$path_ gettags current]
289 if {-1 != [lsearch -exact $tags local]} {
290 $self hilit
291 } else {
292 $self unhilit
293 }
294 }
295
296 # turns on showing of marker over the current item
297 #
298 MBCanvas public setHilit {} {
299 $self instvar path_ marker_
300
301 $path_ bind local <Enter> "$self hilit"
302 if [info exists marker_] {
303 $path_ bind $marker_ <Enter> {}
304 }
305 }
306
307 # returns if <u>itemid</u> overlaps the region {x1 y1 x2 y2}
308 #
309 MBCanvas private overlap {itemid x1 y1 x2 y2} {
310 # this is a slow algoritshm, we could use the item's bbox to check
311 # as well, but that may not be accurate (e.g. wrt filled/unfilled rects)
312 set overlap [[$self set path_] find overlapping $x1 $y1 $x2 $y2]
313 return [expr {([lsearch -exact $overlap $itemid]==-1) ? 0 : 1}]
314 }
315
316 # change the contents of the canvas to postscript
317 # <ul>
318 # <li><u>content</u>: if this is <tt>full</tt> the whole canvas is output
319 # to postscript. Otherwise only the visible region is converted to
320 # postscript.
321 # <li><u>orient</u>: if this is <tt>portrait</tt>, prints to portrait,
322 # else landscape is assumed.
323 # <li><u>header</u>: additional page header to be included
324 # <li><u>args</u>: additional arguments to be passed down to the tkcanvas's
325 # postscript command.
326 # <li> empty pages are ignored.
327 # </ul>
328 MBCanvas public to_ps {content orient header args} {
329 $self instvar path_
330
331 # overwrite default behavior
332 # so that it prints whole canvas
333
334 set hdrStart "gsave
335 %helv font size 10
336 /Helvetica-Bold findfont 10 scalefont ISOEncode setfont
337 %black
338 0.000 0.000 0.000 setrgbcolor AdjustColor\n"
339 set hdrEnd ") show\ngrestore\n"
340 if {$orient == "portrait"} {
341 # inches
342 set ph 10
343 set pw 7.5
344 # 1/72 of an inch
345 set hx 27
346 set hy 27
347 } else {
348 set pw 10
349 set ph 7.5
350 set hx 27
351 set hy -27
352 lappend args -rotate 1
353 append hdrStart "90 rotate\n"
354 }
355 append hdrStart "$hx $hy moveto\n("
356 set str $hdrStart
357 append str $header
358 append str $hdrEnd
359 lappend args -pageheader $str
360
361 if {$content == "full"} {
362 set size [$path_ bbox all]
363 if {$size == {}} {
364 # empty pages are ignored
365 return
366 }
367 set x [lindex $size 0]
368 set y [lindex $size 1]
369 set w [expr {[lindex $size 2] - [lindex $size 0]}]
370 set h [expr {[lindex $size 3] - [lindex $size 1]}
371 ]
372 } else {
373 set x [$path_ canvasx 0]
374 set y [$path_ canvasy 0]
375 set w [$path_ canvasx [winfo width $path_]]
376 set h [$path_ canvasy [winfo height $path_]]
377 }
378 # use the more limiting dimension to scale, so that
379 # we can always see the whole picture
380 if {$w>0 && ($h/double($w) > $ph/double($pw))} {
381 lappend args -pageheight [append ph i]
382 } else {
383 lappend args -pagewidth [append pw i]
384 }
385 lappend args -x $x -y $y -width $w -height $h
386
387 eval $path_ postscript $args
388 }
389
390 # returns the canvas x-y coordinate for the pointer
391 MBCanvas public pointerxy {} {
392 $self instvar path_
393 set rx [winfo rootx $path_]
394 set wx [winfo pointerx $path_]
395 set ry [winfo rooty $path_]
396 set wy [winfo pointery $path_]
397
398 if {($wx == -1) || ($wy == -1)} {
399 return {}
400 }
401 return [$self canvasxy [expr {$wx - $rx}] [expr {$wy - $ry}]]
402 }
403
404 # if newRegion is larger than the scrollregion, update it
405 # <u>inc</u> is the amount of increase for the region (all around)
406 # $newRegion is a list of coordinates {x0 y0 x1 y1} and any of the
407 # ordinates can be null to mean "nocare"
408 #
409 MBCanvas private expandScrReg {newRegion {inc 0}} {
410
411 $self instvar path_
412 set region [$path_ cget -scrollregion]
413 set oldRegion $region
414 set rsz 0
415 # puts "expandScrReg: $newRegion"
416 # new size could be a bounding box, which includes insets
417 foreach i {2 3} {
418 set newVal [lindex $newRegion $i]
419 if {$newVal != {} && $newVal > [lindex $region $i]} {
420 set region [lreplace $region $i $i \
421 [expr {$newVal + $inc}]]
422 set rsz 1
423 }
424 }
425 foreach i {0 1} {
426 set newVal [lindex $newRegion $i]
427 if {$newVal != {} && $newVal < [lindex $region $i]} {
428 set region [lreplace $region $i $i \
429 [expr {$newVal - $inc}]]
430 set rsz 1
431 }
432 }
433 if $rsz {
434 mtrace trcMB "expandScrReg: new $region old:$oldRegion"
435 $path_ configure -scrollregion $region
436 }
437 }
438
439 # Change zoom policy <p>
440 # if $policy is "fix to view", scale will adjusted so that roughly
441 # the same view is displayed as window size changes <br>
442 # if $policy is a number (possibly followed by '%'), sets scale to $policy
443 # (in percentage of normal size) <br>
444 # if $policy is "fit width", the scale is adjusted to fit the <i>current</i>
445 # width of the bounding box. (Note: automatic update as bounding box changes
446 # not supported) <br>
447 # if $policy is "fit height", the scale is adjusted to fit the <i>current</i>
448 # height of the bounding box. (Note: automatic update as bounding box changes
449 # not supported) <br>
450 # if $policy is "fit all", the scale is adjusted to fit the <i>current</i>
451 # bounding box. (Note: automatic update as bounding box changes
452 # not supported) <br>
453 #
454 MBCanvas public zoom_policy {policy} {
455 $self instvar path_
456 $self set zoomPolicy_ $policy
457 set leftFract 0
458 set topFract 0
459 set changeSR 1
460 switch -exact $policy {
461 "fix to view" {
462 set changeSR 0
463 }
464 "fit width" {
465 set bbox [$path_ bbox all]
466 if {$bbox == {}} { return }
467 set width [expr {[lindex $bbox 2] - [lindex $bbox 0]}]
468 if {$width > 1} {
469 $self fit $width 0
470 }
471 }
472 "fit height" {
473 set bbox [$path_ bbox all]
474 if {$bbox == {}} { return }
475 set height [expr {[lindex $bbox 3] - [lindex $bbox 1]}]
476 if {$height > 1} {
477 $self fit 0 $height
478 }
479 }
480 "fit all" {
481 set bbox [$path_ bbox all]
482 if {$bbox == {}} { return }
483 set width [expr {[lindex $bbox 2] - [lindex $bbox 0]}]
484 set height [expr {[lindex $bbox 3] - [lindex $bbox 1]}]
485 $self fit $width $height
486 }
487 default {
488 set topLeft [$self canvasxy 0 0]
489 puts "topLeft = $topLeft"
490 if [regexp {([0-9]+)%?} $policy {} scale] {
491 $self rescale [expr {$scale / 100.0}]
492 } else {
493 error "invalid zoom policy: $policy"
494 return
495 }
496 set changeSR 0
497 # move back so that the top left corner is still
498 # at the same location
499 $self scrollTopLeft $topLeft
500 }
501 }
502 if $changeSR {
503 set bbox [$path_ bbox all]
504 if {$bbox == {}} { return }
505 $path_ configure -scrollregion $bbox
506
507 # note: since we trap xview and yview commands,
508 # must not call $path_ directly for them
509 $self yview moveto 0
510 $self xview moveto 0
511 }
512 }
513
514 # scrolls the canvas so that xy (in normalized coordinates) is at the
515 # top left corner
516 MBCanvas private scrollTopLeft {topLeft} {
517 $self instvar path_
518 set sr [$path_ cget -scrollregion]
519 set scale [$self getscale]
520 set x [expr {[lindex $topLeft 0]*$scale}]
521 set y [expr {[lindex $topLeft 1]*$scale}]
522 # puts "x = $x, y = $y, sr=$sr"
523 set leftFract [expr {($x - [lindex $sr 0])/([lindex $sr 2] \
524 - [lindex $sr 0])}]
525 set topFract [expr {($y - [lindex $sr 1])/([lindex $sr 3] \
526 - [lindex $sr 1])}]
527 # puts "topFract = $topFract, leftFract = $leftFract"
528 $self yview moveto $topFract
529 $self xview moveto $leftFract
530 }
531
532 # reconfigure the canvas to {w h}
533 MBCanvas private reconfig {w h} {
534 $self instvar path_ zoomPolicy_
535 # puts "in reconfig, zoomPolicy_=$zoomPolicy_"
536 if {$zoomPolicy_ == "fix to view"} {
537 set topleft [$self canvasxy 0 0]
538 set inset [expr {[$path_ cget -borderwidth] \
539 + [$path_ cget -highlightthickness]}]
540 $self resize [expr {$w - 2*$inset}] [expr {$w - 2*$inset}]
541
542 # scroll back so that the top left corner is still at
543 # the same location
544 $self scrollTopLeft $topleft
545 }
546 $self updScrReg 5
547 return
548 }
549
550 # sets the scroll region to be the union of the displayed area and
551 # the bounding box, inc gives the extra boundary
552 MBCanvas private updScrReg { {inc 0} } {
553 # puts "in updScrReg, inc=$inc"
554 $self instvar path_
555 set w [winfo width $path_]
556 set h [winfo height $path_]
557 set x [$path_ canvasx 0]
558 set y [$path_ canvasy 0]
559 set bbox [$path_ bbox all]
560 set x1 $x
561 set x2 [expr {$x + $w}]
562 set y1 $y
563 set y2 [expr {$y + $h}]
564 if {$bbox == {}} {
565 $self expandScrReg [list $x1 $y1 $x2 $y2]
566 return
567 }
568 foreach {bx1 by1 bx2 by2} $bbox {
569 if {$x1 > $bx1} { set x1 $bx1 }
570 if {$y1 > $by1} { set y1 $by1 }
571 if {$x2 < $bx2} { set x2 $bx2 }
572 if {$y2 < $by2} { set y2 $by2 }
573 }
574 $self expandScrReg [list $x1 $y1 $x2 $y2]
575 return
576 }
577
578 # shows the busy cursor in the canvas <br>
579 # if <u>isBusy</u> is 1, return the displaced cursor, it is then the caller's
580 # reponsibily to restore the old cursor by call show_busy 0 oldcursorname
581 #
582 MBCanvas public show_busy {isBusy {prevCursor {}}} {
583 $self instvar path_
584 if {$isBusy} {
585 set oldCursor [$path_ cget -cursor]
586 $path_ configure -cursor watch
587 return $oldCursor
588 } elseif {$prevCursor != {}} {
589 $path_ configure -cursor $prevCursor
590 }
591 }
592
593 # attaches a pair of scrollbars to the canvas
594 MBCanvas public attach_scrollbar {xscroll yscroll} {
595 $path_ configure -xscrollcommand [list $xscroll set] \
596 -yscrollcommand [list $yscroll set]
597 }
598
599 # transfers configurations from one canvas to another, useful when
600 # we hide one canvas and displays another but want the displayed canvas to
601 # have the same configuration as the about to be hidden one
602 #
603 MBCanvas public transfer_state_from {canvas} {
604 $self enable_tip [$canvas set ownerTip_]
605
606 # transfer zoom scale. If view is fixed don't rescale
607 # (otherwise view will not be fixed. Otherwise, change the zoom
608 # value.
609 set zoomPolicy [$canvas set zoomPolicy_]
610 if ![regexp {fix*} $zoomPolicy] {
611 # puts "rescaling to [$canvas getscale]"
612 $self rescale [$canvas getscale]
613 }
614 if ![regexp "fit*" $zoomPolicy] {
615 $self zoom_policy $zoomPolicy
616 } else {
617 $self set zoomPolicy_ $zoomPolicy
618 }
619 }
620
621 # resizes the canvas to fit the new bounding box
622 #
623 MBCanvas public refreshScrReg {} {
624 $self instvar path_
625 # puts "in refreshScrReg"
626 $self updScrReg 5
627 }
628
629 # tells the canvas to pack itself
630 MBCanvas public pack {args} {
631 $self instvar path_
632 $self refreshScrReg
633 bind $path_ <Enter> "focus $path_"
634 bind $path_ <Leave> "focus ."
635 eval pack $path_ $args
636 }
637
638 # tells the canvas to unpack itself
639 MBCanvas public unpack {} {
640 $self resetBindings
641 pack forget [$self set path_]
642 }
643
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.