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
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
|
# 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: freetext.tcl,v 2.52 2005/01/02 00:45:07 jfontain Exp $
class freeText {
proc freeText {this parentPath args} composite {
[new text $parentPath\
-background $viewer::(background) -font $font::(mediumNormal) -wrap word -borderwidth 0 -highlightthickness 0\
] $args
} viewer {} {
set path $widget::($this,path)
setupTextBindings $path
viewer::setupDropSite $this $path ;# allow dropping of data cells
set ($this,labels) {}
$path tag configure bold -font $font::(mediumBold)
$path tag configure italic -font $font::(mediumItalic)
$path tag configure bolditalic -font $font::(mediumBoldItalic)
$path tag configure underline -underline 1
$path tag configure overstrike -overstrike 1
if {$global::readOnly} {
$path configure -state disabled
} else {
set bindings [new bindings $path 0]
# break from class bindings to avoid potentially harmful code and do not fail when there is no selection:
bindings::set $bindings <Control-b>\
"catch {$path tag add bold sel.first sel.last; freeText::mergeBoldItalic $path}; break"
bindings::set $bindings <Control-i>\
"catch {$path tag add italic sel.first sel.last; freeText::mergeBoldItalic $path}; break"
bindings::set $bindings <Control-o> "catch {$path tag add overstrike sel.first sel.last}; break"
bindings::set $bindings <Control-u> "catch {$path tag add underline sel.first sel.last}; break"
bindings::set $bindings <Control-r> "
catch {foreach name {bold italic bolditalic overstrike underline} {$path tag remove \$name sel.first sel.last}}
break
"
set ($this,bindings) $bindings
set ($this,tip) [new widgetTip -path $path -text\
[mc "selection formatting Control keys:\nB(old), I(talic), U(nderline), O(verstrike), R(eset)"]\
]
}
composite::complete $this
initializeTags $this
if {[string length $composite::($this,-endtext)] == 0} { ;# only in empty viewer
centerMessage $path [mc "free text:\ndrop data cell(s), input text"] $viewer::(background) $global::viewerMessageColor
set ($this,event) [after 2000 "centerMessage $path {}; unset freeText::($this,event)"] ;# remove message after a while
}
}
proc ~freeText {this} {
catch {after cancel $($this,event)}
if {[info exists ($this,bindings)]} {
delete $($this,bindings) $($this,tip)
}
if {[info exists ($this,drag)]} {
delete $($this,drag)
}
eval delete $($this,labels)
if {[info exists ($this,selector)]} {
delete $($this,selector)
}
if {[string length $composite::($this,-deletecommand)] > 0} {
uplevel #0 $composite::($this,-deletecommand) ;# always invoke command at global level
}
}
proc iconData {} {
return {
R0lGODlhJAAkAMYAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgwMDA0NDQ4PDg8QDxAQEBISEhMTExUWFRgYGBobGh4fHiAhICIjIiMjIyYn
JigpKC8vLy8wLzAxMDIzMjM0MzY3Njg4ODo8Oj4/Pj9AP0BBQENEQ0VHRUZIRk5PTk9QT1lbWVpbWmZoZnBycHJ0cnZ4dnh4eHd5d3h8eHt9e3x+fH2AfYCE
gIKEgoaIhoeJh4iKiIiLiImMiYuNi4iQiI2PjY6RjpCTkJGUkZCYkJOWk5aZlpmcmZyfnJ6hnqCkoKSnpKisqKmtqa6yrrG0sbi8uLm8ubzAvMDEwMXIxcbK
xsjQyMzQzM/Tz9DU0NHV0dLW0tDY0NPX09ba1tfb19jc2ODk4Ojs6Pj8+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAH/oBjgoOCMYSHhoeDiYWKhIyKkIiPjoMzlWOXlZqNYzExM6Gio6SlpqKf
kpaYnIqtqoSth7KxlIcAuLm6u7y8nZ+hAJjDigCjkMLEymPJtMnLw83F0MQAhonAM8/FBtAAIaOE27fdy9ae05UA5crnqsJUKRACDidSzAYyCw8ugzkWAya8
EOSukChhIwBIMJEBQAdmAAhwGABgx5ghABKUiADABjNwoZCNUYEiCpgqABBABAKGBwAOYzwAMDLmyQCYBW8JKsICRIN1zAJ0AaMFwIExC8YxuzZtBQARNZIA
BSAUzJYA3ZIWY+rp4BgGAK6AWTIVQBAwPQBsGLMBgJAxrk4GfPiIStyYCwAwkFAQESKBDhSBjPFhtAQEADqWotPZRIOADEfAIgFQoEUCBzAG4agwgAINglzt
UsOUc9do0rtGKT1NkNSN1zdWszYG+8aP2z9knzaG+weR30R6CR+eawZwIkqSJz/FvLlyJUyiS59Ovbr161Cya9/Ovbv371PCix9Pvrz581bSq1/Pvr3791zi
y59Pv779+2Hy69/Pv7///2IEKOCABBZo4IGBAAA7
}
}
proc options {this} {
# force size values:
return [list\
[list -cellindices {} {}]\
[list -deletecommand {} {}]\
[list -draggable 0 0]\
[list -endtext {} {}]\
[list -height 3]\
[list -taginformation {} {}]\
[list -width 40]\
]
}
proc set-cellindices {this value} { ;# indexes of soon to be created cells when initializing from file
if {$composite::($this,complete)} {
error {option -cellindices cannot be set dynamically}
}
set ($this,nextCellIndex) 0 ;# initialize cell insertion index in list of indexes
}
proc set-endtext {this value} {
set path $widget::($this,path)
set state [$path cget -state]
$path configure -state normal
$path insert end $value
$path configure -state $state
}
proc set-deletecommand {this value} {}
proc set-draggable {this value} {
if {$composite::($this,complete)} {
error {option -draggable cannot be set dynamically}
}
if {!$value} return ;# no dragging
set ($this,drag) [new dragSite -path $widget::($this,path) -validcommand "freeText::validateDrag $this 0"]
dragSite::provide $($this,drag) OBJECTS "freeText::dragData $this"
set ($this,selector) [new selector -selectcommand "freeText::setLabelsState $this"]
}
foreach option {-height -width} {
proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
}
proc set-taginformation {this value} {} ;# actual tags initialization delayed after completion since text must be loaded first
proc initializeTags {this} {
set path $widget::($this,path)
foreach {action tag index} $composite::($this,-taginformation) {
switch $action {
tagon {
set first($tag) $index
}
tagoff {
if {[info exists first($tag)]} {
$path tag add $tag $first($tag) $index
unset first($tag)
}
}
}
}
}
proc dragData {this format} {
switch $format {
OBJECTS {
set list [selector::selected $($this,selector)]
if {[llength $list] > 0} {
return $list ;# return selected labels if there are any
} elseif {[empty $this]} {
return $this ;# return text object itself if empty
} else {
return {} ;# return nothing otherwise
}
}
DATACELLS {
return [cellsFromLabels $this [selector::selected $($this,selector)]]
}
}
}
proc validateDrag {this label x y} {
if {($label == 0) && [empty $this]} { ;# dragging from text area
return 1 ;# empty viewer may be dragged into trash
} elseif {[lsearch -exact [selector::selected $($this,selector)] $label] >= 0} {
return 1 ;# allow dragging from selected label only
} else {
return 0
}
}
proc supportedTypes {this} {
return $global::dataTypes
}
proc monitorCell {this array row column} { ;# allow duplicate monitored cells
set path $widget::($this,path)
if {[info exists ($this,event)]} {centerMessage $path {}} ;# keep displaying help message only in empty viewer
viewer::registerTrace $this $array
if {[info exists ($this,nextCellIndex)]} { ;# recreate data cell labels placement from recorded configuration
set index [lindex $composite::($this,-cellindices) $($this,nextCellIndex)]
if {[string length $index] == 0} { ;# indexes list exhausted: we are done initializing from recorded data
unset ($this,nextCellIndex)
set index insert ;# position cell window at insertion cursor
} else {
incr ($this,nextCellIndex) ;# get ready for upcoming cell
}
} else {
set index insert ;# insert cell label text and window at insertion cursor
$path insert $index "[lindex [viewer::label $array $row $column] 0]: "
}
set label [new label $path]
set labelPath $label::($label,path)
switched::configure $label -deletecommand "freeText::deletedLabel $this $array $label" ;# keep track of label existence
if {$composite::($this,-draggable)} { ;# setup dragging and selection for label
set drag [new dragSite -path $labelPath -validcommand "freeText::validateDrag $this $label"]
dragSite::provide $drag OBJECTS "freeText::dragData $this"
dragSite::provide $drag DATACELLS "freeText::dragData $this"
set ($this,drag,$label) $drag
set selector $($this,selector)
selector::add $selector $label
bind $labelPath <ButtonPress-1> "freeText::buttonPress $selector $label"
bind $labelPath <Control-ButtonPress-1> "selector::toggle $selector $label"
bind $labelPath <Shift-ButtonPress-1> "freeText::extendSelection $this $label"
bind $labelPath <ButtonRelease-1> "freeText::buttonRelease $selector $label 0"
bind $labelPath <Control-ButtonRelease-1> "freeText::buttonRelease $selector $label 1"
bind $labelPath <Shift-ButtonRelease-1> "freeText::buttonRelease $selector $label 1"
}
lappend ($this,labels) $label
$path window create $index -window $labelPath
set ($this,cell,$label) ${array}($row,$column)
}
proc update {this array} { ;# update display using cells data
foreach label $($this,labels) {
set cell $($this,cell,$label)
if {[string first $array $cell] != 0} continue ;# check that cell belongs to updated array
if {[info exists $cell]} {
switched::configure $label -text [set $cell] ;# may be the ? character
} else {
switched::configure $label -text ?
}
}
}
proc deletedLabel {this array label} {
if {$composite::($this,-draggable)} {
delete $($this,drag,$label)
selector::remove $($this,selector) $label
}
viewer::unregisterTrace $this $array ;# trace may no longer be needed on this array
ldelete ($this,labels) $label
unset ($this,cell,$label)
}
proc cellsFromLabels {this labels} {
set cells {}
foreach label $labels {
lappend cells $($this,cell,$label)
}
return $cells ;# may contain duplicates
}
proc cells {this} { ;# note: always return cells in the same order
return [cellsFromLabels $this $($this,labels)]
}
proc setLabelsState {this labels select} {
foreach label $labels {
label::select $label $select
}
}
proc extendSelection {this endLabel} {
set selector $($this,selector)
if {[info exists selector::($selector,lastSelected)]} { ;# extend from previously selected label
# build path to label mapping table (reasonable since it is likely that there is only a few embedded labels in the text)
foreach label $($this,labels) {
set labelFromPath($label::($label,path)) $label
}
# build ordered label list from windows returned ordered according to their position (index) in the text
set list {}
foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
if {[string length $path] == 0} continue ;# ignore deleted windows
lappend list $labelFromPath($path)
}
set start [lsearch -exact $list $selector::($selector,lastSelected)]
set end [lsearch -exact $list $endLabel]
if {$end < $start} { ;# make sure limits are in increasing order
set index $start
set start $end
set end $index
}
selector::clear $selector
selector::set $selector [lrange $list $start $end] 1
} else {
selector::select $selector $endLabel
}
}
proc empty {this} { ;# if no labels exist and there is no visible text left
return [expr {([llength $($this,labels)] == 0) && ([string length [string trim [$widget::($this,path) get 1.0 end]]] == 0)}]
}
proc initializationConfiguration {this} { ;# note: always return configurations in the same order
set options {}
set text {}
foreach {key string index} [$widget::($this,path) dump -text 1.0 end] {
append text $string
}
lappend options -endtext [string trimright $text \n] ;# remove useless trailing lines
foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
if {[string length $path] == 0} continue ;# ignore deleted windows
set position($path) $index
}
if {[info exists position]} {
foreach label $($this,labels) { ;# get labels in creation order
lappend indexes $position($label::($label,path))
}
lappend options -cellindices $indexes ;# so that labels may be placed properly when reloading from file
}
set list {}
foreach {action tag index} [$widget::($this,path) dump -tag 1.0 end] {
if {[string equal $tag sel]} continue ;# ignore selection
lappend list $action $tag $index
}
if {[llength $list] > 0} {
lappend options -taginformation $list
}
return $options
}
proc setCellColor {this cell color} { ;# color can be empty
foreach label $($this,labels) {
if {[string equal $($this,cell,$label) $cell]} {
switched::configure $label -background $color
} ;# not done since there can be duplicate monitored cells
}
}
proc monitored {this cell} {
foreach label $($this,labels) {
if {[string equal $($this,cell,$label) $cell]} {
return 1
} ;# not done since there can be duplicate monitored cells
}
return 0
}
proc mergeBoldItalic {path} {
set end [$path index end]
set index 1.0
while {![string equal $index $end]} {
set names [$path tag names $index]
if {([lsearch -exact $names bold] >= 0) && ([lsearch -exact $names italic] >= 0)} {
$path tag remove bold $index
$path tag remove italic $index
$path tag add bolditalic $index
}
set index [$path index $index+1c]
}
}
proc buttonPress {selector label} {
foreach selected [selector::selected $selector] {
if {[string equal $selected $label]} return ;# in an already selected label, do not change selection
}
selector::select $selector $label
}
proc buttonRelease {selector label extended} { ;# extended means that there is an extended selection in process
if {$extended} return
set list [selector::selected $selector]
if {[llength $list] <= 1} return ;# nothing to do if there is no multiple selection
foreach selected $list {
if {[string equal $selected $label]} { ;# in an already selected label
selector::select $selector $label ;# set selection to sole label
return
}
}
}
}
class freeText {
class label {
proc label {this parentPath args} switched {$args} {
set label [new label $parentPath -font $font::(mediumBold) -padx 0 -pady 0 -borderwidth 1 -cursor left_ptr]
# keep track of label existence as it may be deleted by directly editing in the parent text widget
bind $widget::($label,path) <Destroy> "delete $this"
set ($this,path) $widget::($label,path)
set ($this,label) $label
switched::complete $this
}
proc ~label {this} {
bind $($this,path) <Destroy> {} ;# remove binding to avoid recursion
delete $($this,label)
if {[string length $switched::($this,-deletecommand)] > 0} {
uplevel #0 $switched::($this,-deletecommand) ;# always invoke command at global level
}
}
proc options {this} {
return [list\
[list -background {}]\
[list -deletecommand {} {}]\
[list -text {} {}]\
]
}
proc set-background {this value} {
if {[string length $value] == 0} {
$($this,path) configure -background $widget::option(label,background)
} else {
$($this,path) configure -background $value
}
}
proc set-deletecommand {this value} {} ;# data is stored at switched level
proc set-text {this value} {
$($this,path) configure -text $value
}
proc select {this select} {
if {$select} {
$($this,path) configure -relief sunken
} else {
$($this,path) configure -relief flat
}
}
}
}
|
