1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
# copyright (C) 1995-2004 Jean-Luc Fontaine (mailto:jfontain@free.fr)
package require Tk 8.3
package require stooop
::stooop::class canvasLabelsArray {
proc canvasLabelsArray {this canvas args} switched {$args} {
set ($this,canvas) $canvas
# use an empty image as an origin marker with only 2 coordinates
set ($this,origin)\
[$canvas create image 0 0 -tags canvasLabelsArray($this)]
set ($this,labels) {}
switched::complete $this
}
proc ~canvasLabelsArray {this} {
eval ::stooop::delete $($this,labels)
# delete remaining items
$($this,canvas) delete canvasLabelsArray($this)
}
proc options {this} {
# force width initialization for internals initialization:
return [list\
[list -justify left left]\
[list -width 100]\
]
}
proc set-justify {this value} {
if {$switched::($this,complete)} {
error {option -justify cannot be set dynamically}
}
}
proc set-width {this value} {
set ($this,width) [winfo fpixels $($this,canvas) $value]
update $this
}
proc manage {this label} { ;# must be a canvasLabel
$($this,canvas) addtag canvasLabelsArray($this)\
withtag canvasLabel($label)
lappend ($this,labels) $label
update $this
}
proc delete {this label} {
set index [lsearch -exact $($this,labels) $label]
if {$index < 0} {
error "invalid label $label for canvas labels array $this"
}
set ($this,labels) [lreplace $($this,labels) $index $index]
::stooop::delete $label
update $this
}
proc update {this} {
set canvas $($this,canvas)
set halfWidth [expr {round($($this,width) / 2.0)}]
foreach {xOrigin yOrigin} [$canvas coords $($this,origin)] {}
set x 0; set y 0
set height 0
set column 0
foreach label $($this,labels) {
foreach {left top right bottom}\
[$canvas bbox canvasLabel($label)] {}
set wide [expr {($right - $left) > $halfWidth}]
if {$wide} {
# label does not fit in a half width so open a new line
set x 0; incr y $height; set height 0
}
switched::configure $label -anchor nw
# do an absolute positioning using label tag:
foreach {xDelta yDelta} [$canvas coords canvasLabel($label)] {}
$canvas move canvasLabel($label) [expr {$xOrigin + $x - $xDelta}]\
[expr {$yOrigin + $y - $yDelta}]
set value [expr {$bottom - $top}]
if {$value > $height} { ;# keep track of current line height
set height $value
}
if {([incr x $halfWidth] > $halfWidth) || $wide} {
set x 0; incr y $height; set height 0
}
}
}
proc labels {this} {
return $($this,labels)
}
proc height {this} {
set list [$($this,canvas) bbox canvasLabelsArray($this)]
if {[llength $list] == 0} {
return 0
}
foreach {left top right bottom} $list {}
return [expr {$bottom - $top}]
}
}
|
