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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
|
# copyright (C) 1997-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
# $Id: canvview.tcl,v 1.39 2005/01/02 00:45:07 jfontain Exp $
class canvas { ;# note: already initialized in scwoop
class viewer { ;# a viewer made of canvas items
set (list) {}
proc viewer {this parentPath tag} ::viewer {} { ;# parent is a canvas
set ($this,canvas) $parentPath
set ($this,tag) $tag
# use an empty image as an origin marker with only 2 coordinates
set ($this,origin) [$parentPath create image 0 0 -tags $tag]
viewer::setupDropSite $this $parentPath ;# allow dropping of data cells
switched::configure $viewer::($this,drop) -regioncommand "canvas::viewer::dropRegion $this"
lappend (list) $this
}
proc ~viewer {this} {
if {[info exists ($this,menu)]} {destroy $($this,menu)}
$($this,canvas) delete $($this,tag) ;# delete all components
ldelete (list) $this
}
proc supportedTypes {this} {
return $global::dataTypes
}
proc validateDrag {canvas x y} {
set drag $canvasWindowManager::($global::windowManager,drag)
foreach viewer $(list) {
if {[lsearch -exact [$canvas gettags current] $($viewer,tag)] >= 0} { ;# found viewer
if {$composite::($viewer,-draggable)} {
dragSite::provide $drag OBJECTS "canvas::viewer::dragData $viewer"
if {[llength [cells $viewer]] > 0} { ;# there are monitored cells
dragSite::provide $drag DATACELLS "canvas::viewer::dragData $viewer"
}
dragSite::provide $drag CANVASVIEWER "canvas::viewer::dragData $viewer"
return 1
}
}
}
return 0 ;# not in a viewer
}
proc dragData {viewer format} {
switch $format {
CANVASVIEWER - OBJECTS {return $viewer}
DATACELLS {return [dragCells $viewer]}
}
}
proc dropRegion {this} {
set canvas $($this,canvas)
foreach {left top right bottom} [$canvas cget -scrollregion] {}
set xOffset [expr {$left + round([lindex [$canvas xview] 0] * ($right - $left))}]
set yOffset [expr {$top + round([lindex [$canvas yview] 0] * ($bottom - $top))}]
foreach {left top right bottom} [$canvas bbox $($this,tag)] {}
incr left -$xOffset; incr top -$yOffset; incr right -$xOffset; incr bottom -$yOffset
set X [winfo rootx $canvas]; set Y [winfo rooty $canvas]
return [list [incr left $X] [incr top $Y] [incr right $X] [incr bottom $Y]] ;# absolute region
}
virtual proc dragCells {this}
virtual proc monitorCell {this array row column}
virtual proc update {this array}
virtual proc cells {this}
proc manageable {this} {return 0}
virtual proc initializationConfiguration {this} {
return {}
}
virtual proc setCellColor {this cell color} {}
virtual proc monitored {this cell}
proc page {viewer} {
if {[lsearch -exact $(list) $viewer] < 0} {return {}} ;# not a canvas viewer
return [pages::tagOrItemPage $($viewer,tag)]
}
proc moveAll {xMaximum} {
foreach viewer $(list) {
if {$composite::($viewer,-x) >= $xMaximum} {
composite::configure $viewer -x [expr {round($composite::($viewer,-x)) % $xMaximum}]
}
}
}
virtual proc flash {this}
proc createPopupMenu {this} {
set ($this,menu) [menu $($this,canvas).menu$this -tearoff 0]
$($this,canvas) bind $($this,tag) <ButtonPress-3> "tk_popup $($this,menu) %X %Y"
}
virtual proc updateLabels {this}
}
class iconic { ;# viewer made of an image and a label
proc iconic {this parentPath args} composite {
[new frame $parentPath -background {} -highlightthickness 0 -borderwidth 0 -width 0 -height 0] $args
} canvas::viewer {$parentPath canvas::iconic($this)} { ;# use an unused empty frame as base as a viewer must be a composite
set tag $canvas::viewer::($this,tag)
set ($this,image) [$parentPath create image 0 0 -anchor center -tags $tag]
set ($this,text) [$parentPath create text 0 0 -font $font::(smallNormal) -justify center -anchor n -tags $tag]
composite::complete $this
set ($this,cell) {} ;# monitored cell
if {!$global::readOnly} {
canvas::viewer::createPopupMenu $this
$canvas::viewer::($this,menu) add command -label [mc Image]... -command "canvas::iconic::changeImage $this"
}
if {!$composite::($this,-static)} {
$parentPath bind $tag <ButtonPress-1> "canvas::iconic::select $this %x %y"
$parentPath bind $tag <Button1-Motion> "canvas::iconic::moving $this %x %y"
$parentPath bind $tag <ButtonRelease-1> "canvas::iconic::release $this"
}
}
proc ~iconic {this} { ;# note: all data trace unregistering occurs in viewer layer destructor
freeImage $this
if {[string length $composite::($this,-deletecommand)] > 0} {
uplevel #0 $composite::($this,-deletecommand) ;# always invoke command at global level
}
}
proc freeImage {this} {
if {[string length $composite::($this,-creationfile)] > 0} {
images::release $composite::($this,-creationfile) ;# free existing image
}
}
proc iconData {} {
return {
R0lGODdhJAAkAOcAAAICAl2R2Iaz6PK2PvrcWk5Ohv6KCtLa0urWuv6AAv68UxISHu7ursqKKv7IZnp6emNjjWma4xJRtdK2koKKjqri/lJwsP7eqvKu
NvTu2MWCJf7KdsLGwtbz/pqeriJeus6cOp7O+rrW/mKK0v7qZr56JqamunZ2fnZ6gp6+/uP0/NbW4rp6JLPO+V6GzrLK1iZiwnqKtgg+osDu/v6bGfX0
226axvbevtLW3t7e7YqSiv765mqe1jJqurq+uv7ukn6Suv7osoaq0o7C8v7WcpK+6qamykpWmnp6lm6i3jZyyv7+s83N4n5+ntjq9sLC28Le9rS2zv7u
pv724tLS5v6mGv7OTkF6x6CgwHFzm3Wk7GqCuv7mdpqatlpmoqLI6rnl/uLm4qeqxf7quJeYwVZamv766sjK2fKmJpKaktHR3v7utoSEoPrqzsre9P7W
gvr++m1uqJam0v7yev7CQH6u4oey/np+ep+iuuru6pe6/kZ+zur0+urOov7mvu7uyO7ipoqLoXFypeLi7l5qsN7q/v72cr2+1f72usrSyoODpsju/v76
7oqKtr7a9v6mKv768v7+n9Dm+/6aMnqq7vLy5vLksoqKut7u+v77hH5+gv7+zO7epv7mxzpeprLC1oKCsZKWrk5+uvb06np6rpaWthpClqKmoqaqvvy4
SP6WBnJyraLO8mpqo/3alJC2/qjC8IaKpv7+/u7u9urq7v7qwqXJ+cLq/NLx/WRkqufp9PH09R5QokZ2xq7q/pi+/n5+t9HS4oq67oKu/qjR/l6a2vy6
On2BmP7uzf7lrv7+ks7e/v6sOYaGtP7qnsLC0qquqgxGsP6iGJCQvP6TE1ZWlqGhx0qF0oGFgv6iJ5K67mJim3Km/rzQ/P6yNrfq/v7qzHys+4K66vfl
xpbK9q2tzVxelo2Nr3qaysnZ+sDCzv7SfsbG3dLi/rq6zKvJ+ub6/vPdumZqirnd/tna54i2/nR2pH5+rI+6/mRmnXV2rfb2+qvO8+bm7pfC7t6+liwA
AAAAJAAkAAAI/gDhCBwo8AHBgwYPDkxYUOC+fSbU7cOBh9YJE4f2BfOgZl8UPCd0lQrm0cNDSCf2wXn44KHAWIHcnYPW5RiemM3KnYvSaBqSaXjuRVml
b+AdSAIhoSh4QhObZ7Rk0WOyLw+7frJyPNsH6QwVSIOsCUJxBwXZO2jvPHhwAg6jA+f2FVrWrm47unWX6XXjJl2hHKDoObwDz4zKtivhsDkjq0WKxyl+
Rf5FWY/lV6/S7RMTRyUcg/Dg7FjqWV2gfe9+4fulh7UefK/xvbLzali3QaQ+MRK41GHvEydQKJr1rp5sfMhl15ttx86wcN2CxSGL4gHatWrvIFbkTpat
esMo/mkZH65e82HPw4V7t6vLKoE17hBMyBVLKVnaBNhKVzcdLHTFJKFFONxEwA0sK+hDhmco7ACPg/KppNI0/RQiyYUX8vWJPltYQMgILhAiBxb56MJB
LHDIEwgcqJiA2FpN3OcIPzSywg8x/NhiThleWLMjGfnk46MXjZjTSinmVAPBdSvFEoUs/HzxxTv+FDGENkKgA4osXHbpJSQP7cKEPSglBccugQwigo3E
CCBAHZTYYM4hkHQCDjh24nnnnZ10Mos9sZC2UhSgQOIIMcQIk8SiSUTgBRmQ3ImMpHvaaSc9cRyC2Al3kMLOPvOEUEwxAZQagCgWABOppJPu2Won/kyU
wal2btFzzyDzkHPNrrz2UsYzdY5zQzzjxHNDLX4kmywtoDSBmEo4gELLPBUM0cseVyihRA+egDLKODUwAskUoyCDQB/JJHPBBWfEEYZBEtrzxC5gVFCB
LxUU88EHvBxhDSTIBCxwwOP848o6DtDTSjkJcYoEMIOA4Ysv33wjgAQYVxMFI8mMUcsY6SbjRzJvlJCKMbjJQxZifDRDzy0wL7IIK9FEI4MpoEwxxhhr
XOCKK2+ss4EDxmhAxyH2wPEsJKuUQ4ski+DSwdS9yMCLxjs444zQGwytwNfMaDAAYLHAK1Apl+iyyNTw8KGCI/7cEsMlU/zgQCoKpJKK/jfeMOMNDWg0
wMQ27CAGwOHbMOGECirwwccufLTzAhCNTDEHF8xko7nmj1ShShUsMFHAAocDsJYgwLBDxSBnsJPDCk+wo0Y1wYwzhyGZGDIJNQZQk4001NDAQg73QIAd
NtgAo489cZARRxzNAJNFLtNsc4/tykSiTDYJGGAACTTQQUAD7CyJPDY66GBPEzo0YQ8FOqxijw7HxFEGFjVkv8QSCiSQgBUkUEUCMAACHLQiC/BLnw7S
kIb0MbCBD0xDPrpQif1tYhNrmMQ6MsGMVBgABATAgSBO0EAdnOKEKEzhCT1wiljcIw81qEElKpGBP2SAAZxggCUmAAh25CMNwCiEximECA1UnMKIRhzi
KarRimaw4xyXOAQoogiKabCDFF2Igj6qkYU0FNEHYAyjGMVYDXuwoQzNYEM1YkGKbYTCHmXoQhy24YFtxEEHYOSAOjiQRx9w4I+A3CM0oAFEVHiRkIPU
wSCB+EA9JuKRkHwkByJJyUpaspIHSEQmM6nJR3IyETjoJChHSUocbBKSOBhEGFbJyla6kpWqfCUsXZmHPNDClrT4wy1pwcs/2LKWYfBlHsJwy1oO85jG
5GVAAAA7
}
}
proc options {this} {
return [list\
[list -creationfile {} {}]\
[list -deletecommand {} {}]\
[list -draggable 0 0]\
[list -file {} {}]\
[list -static 0 0]\
[list -x 0 0] [list -y 0 0]\
]
}
proc set-deletecommand {this value} {}
proc set-draggable {this value} {
if {$composite::($this,complete)} {
error {option -draggable cannot be set dynamically}
}
}
proc set-static {this value} {
if {$composite::($this,complete)} {
error {option -static cannot be set dynamically}
}
}
proc set-creationfile {this value} {
# reference in images repository, also stored in save file, used by record layer to detect changes
$canvas::viewer::($this,canvas) itemconfigure $($this,image) -image [images::use $value]
refresh $this
}
proc set-file {this value} {
freeImage $this
# use full file path as key, as current directory may change during the lifetime of the application or the dashboard
if {[package vcompare $::tcl_version 8.4] < 0} {
if {[string length $value] > 0} {set value [file join [pwd] $value]}
} else {
set value [file normalize $value] ;# note: image file validity must have been checked before
}
images::load $value $value {} ;# load into images repository
composite::configure $this -creationfile $value ;# then use image
# for initial placement in upper left corner or in case image has grown
fence $canvas::viewer::($this,canvas) $canvas::viewer::($this,tag)
foreach {x y} [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] break
composite::configure $this -x [expr {round($x)}] -y [expr {round($y)}] ;# synchronize composite layer
}
proc set-x {this value} { ;# note: all canvas viewers must support -x and -y options
set x [lindex [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] 0]
$canvas::viewer::($this,canvas) move $canvas::viewer::($this,tag) [expr {$value - $x}] 0
}
proc set-y {this value} {
set y [lindex [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] end]
$canvas::viewer::($this,canvas) move $canvas::viewer::($this,tag) 0 [expr {$value - $y}]
}
proc monitorCell {this array row column} {
set cell ${array}($row,$column)
if {[string equal $cell $($this,cell)]} return ;# already monitored
if {[string length $($this,cell)] > 0} { ;# a cell was already monitored
viewer::parse $($this,cell) value ignore ignore ignore
viewer::unregisterTrace $this $value ;# no longer monitor
}
set ($this,cell) $cell
viewer::registerTrace $this $array
set canvas $canvas::viewer::($this,canvas)
foreach [list ($this,label) incomplete] [viewer::label $array $row $column] {}
$canvas itemconfigure $($this,text) -text $($this,label)
if {$incomplete} {set ($this,relabel) {}} ;# label cannot be determined yet
}
proc update {this array} { ;# update data display
set cell $($this,cell)
if {[string first $array $cell] != 0} return ;# check that cell belongs to updated array
if {[info exists ($this,relabel)]} { ;# if label is not yet defined, update it
viewer::parse $cell ignore row column ignore
foreach [list ($this,label) incomplete] [viewer::label $array $row $column] {}
if {!$incomplete} {unset ($this,relabel)} ;# label now completely defined
}
set value ?; catch {set value [set $cell]} ;# data cell may be void
$canvas::viewer::($this,canvas) itemconfigure $($this,text) -text "$($this,label): $value"
}
proc cells {this} {
if {[string length $($this,cell)] > 0} {
return [list $($this,cell)]
} else {
return {}
}
}
proc initializationConfiguration {this} {
return [list -x $composite::($this,-x) -y $composite::($this,-y) -creationfile $composite::($this,-creationfile)]
}
proc monitored {this cell} {
return [string equal $($this,cell) $cell]
}
proc refresh {this} {
set canvas $canvas::viewer::($this,canvas)
foreach {x y} [$canvas coords $canvas::viewer::($this,origin)] {}
set image [$canvas itemcget $($this,image) -image]
$canvas coords $($this,image) $x $y
$canvas coords $($this,text) $x [expr {$y + ([image height $image] / 2.0) + 1}]
}
proc chooseFile {{current {}}} {
if {[string length $current] == 0} {
set directory .
} else {
set directory [file dirname $current]; set current [file tail $current]
}
set file [tk_getOpenFile\
-title [mc {moodss: Icon image file}] -initialdir $directory -initialfile $current\
-filetypes [list [list [mc {image files}] .gif]]\
] ;# note: returns the full pathname or nothing
if {[string length $file] > 0} {
if {[catch {set image [image create photo -file $file]} message]} {
tk_messageBox -title [mc {moodss: Icon image file error}] -type ok -icon error -message $message
return {}
}
}
return $file
}
proc select {this x y} {
lifoLabel::push $global::messenger {} ;# in case no other string is pushed before button release event pops messenger
set canvas $canvas::viewer::($this,canvas)
foreach {(xFrom) (yFrom)} [$canvas coords $canvas::viewer::($this,origin)] {}
set (xLast) $x; set (yLast) $y
set (cursor) [$canvas cget -cursor]
$canvas configure -cursor fleur
}
proc moving {this x y} {
set canvas $canvas::viewer::($this,canvas)
$canvas move $canvas::viewer::($this,tag) [expr {$x - $(xLast)}] [expr {$y - $(yLast)}]
set (xLast) $x; set (yLast) $y
fence $canvas $canvas::viewer::($this,tag)
foreach {x y} [$canvas coords $canvas::viewer::($this,origin)] break
lifoLabel::pop $global::messenger ;# remove previous coordinates or size
lifoLabel::push $global::messenger "[expr {round($x) - [lindex [$canvas cget -scrollregion] 0]}] [expr {round($y)}]"
}
proc release {this} {
foreach {x y} [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] {}
composite::configure $this -x [expr {round($x)}] -y [expr {round($y)}] ;# synchronize composite layer
$canvas::viewer::($this,canvas) configure -cursor $(cursor)
lifoLabel::pop $global::messenger
}
proc dragCells {this} {
# save current location:
foreach {(xLast) (yLast)} [$canvas::viewer::($this,canvas) coords $canvas::viewer::($this,origin)] {}
# return to initial location when not destroyed
composite::configure $this -x [expr {round($(xFrom))}] -y [expr {round($(yFrom))}]
return [list $($this,cell)]
}
proc setCellColor {this cell color} {
if {![string equal $cell $($this,cell)]} return ;# not monitored
set canvas $canvas::viewer::($this,canvas)
if {[string length $color] == 0} {
if {[info exists ($this,background)]} {
$canvas delete $($this,background)
unset ($this,background)
}
} else {
if {![info exists ($this,background)]} {
foreach {left top right bottom} [$canvas bbox $($this,image)] {}
# draw a filled rectangle with slightly rounded corners
set ($this,background) [$canvas create polygon\
[expr {$left - 2}] [expr {$top - 1}] [expr {$right + 1}] [expr {$top - 1}]\
[expr {$right + 2}] $top [expr {$right + 2}] [expr {$bottom - 1}]\
[expr {$right + 1}] $bottom [expr {$left - 2}] $bottom\
[expr {$left - 3}] [expr {$bottom - 1}] [expr {$left - 3}] $top\
-tags $canvas::viewer::($this,tag) -width 1\
]
$canvas lower $($this,background) $($this,image)
}
$canvas itemconfigure $($this,background) -fill $color -outline $color
}
}
proc flash {this {seconds 1}} {
set canvas $canvas::viewer::($this,canvas)
foreach {left top right bottom} [$canvas bbox $canvas::viewer::($this,tag)] {}
set highlight [new highlighter]
highlighter::show $highlight [expr {[winfo rootx $canvas] + $left}] [expr {[winfo rooty $canvas] + $top}]\
[expr {$right - $left}] [expr {$bottom - $top}]
after [expr {$seconds * 1000}] "delete $highlight"
}
proc changeImage {this} {
if {[string length [set name [chooseFile $composite::($this,-creationfile)]]] > 0} {
composite::configure $this -file $name
}
}
proc updateLabels {this} {
if {[string length $($this,cell)] == 0} return
viewer::parse $($this,cell) array ignore ignore ignore
set ($this,relabel) {}
update $this $array
}
}
}
|
