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
|
# copyright (C) 1997-98 Jean-Luc Fontaine (mailto:jfontain@mygale.org)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
set rcsId {$Id: freetext.tcl,v 1.9 1998/10/18 21:17:53 jfontain Exp $}
class freeText {
proc freeText {this parentPath args} composite {
[new text $parentPath -font $font::(mediumNormal) -wrap word -borderwidth 0 -highlightthickness 0] $args
} viewer {} {
set freeText::($this,drop) [new dropSite\
-path $widget::($this,path) -formats DATACELLS -command "viewer::view $this \$dragSite::data(DATACELLS)"\
]
set freeText::($this,labels) {}
composite::complete $this
}
proc ~freeText {this} {
delete $freeText::($this,drop)
catch {delete $freeText::($this,drag)}
catch {delete $dataTable::($this,selector)}
eval delete $freeText::($this,labels)
if {[string length $composite::($this,-deletecommand)]>0} {
uplevel #0 $composite::($this,-deletecommand) ;# always invoke command at global level
}
}
proc iconData {} {
return {
R0lGODdhKAAoAIQAAHh4eMjMyAAAANDU0Pj8+Hh8eDg4OEBIQLi8uFAIYHAoeHAweGgYeIgQoLgo0KAYuLAYyLAg0GggeNg4+KgYyNhA+LgY2OBI+OBQ+Ngo
+AAAAAAAAAAAAAAAAAAAAAAAACwAAAAAKAAoAAAF/iAgjmRpnugYAELrvnAsz+0qBHgeDDi/6z6fbjhkBQjIJBKgbDKbyecSaTtCCVJo1ql82gZXQiEsJo+j
VKOowG673/B4W2UMn693aN7LAuPNgGgEVUg0hodYaTciMGSOTQJzX4Uvj5YEAmWDdZiVl46ZZ5OdLp+gI5uLLJ6mVwIGBwcAhKQtZLaWAqijjWEtCLm7nL21
lAi4xYXCqr2/x5mlts64rwYGs8OsCMC/0wLPwATbmMt+xDDgnelKuiKpVs3f4L/q9OzljJ703dLf+5mYYF2jda4fv3EvEC6Dx0rcuG0PwzkcR84dwYat7llc
JSOjqxc2Eogk5jGJAAULcxYwsNGgJcmSmFAucGDjAYQIL0sKkKBAwQQbFCBQOERUhswKQClEsMA0pdOnUKNKdXoBqAOmTadq3ZoSKQusWLmKlYrBBtizaNOq
RetVwNq3cMFWmGsjg927ePPq3at3boa6fAMLDgx4sGHDK4goXsyYcQgAOw==
}
}
proc options {this} {
# force size values
return [list\
[list -cellindices cellIndices CellIndices {} {}]\
[list -deletecommand {} {}]\
[list -draggable draggable Draggable 0 0]\
[list -endtext endText EndText {} {}]\
[list -height height Height 1]\
[list -width width Width 40]\
]
}
proc set-cellindices {this value} { ;# indices of soon to be created cells when initializing from file
if {$composite::($this,complete)} {
error {option -cellindices cannot be set dynamically}
}
set freeText::($this,nextCellIndex) 0 ;# initialize cell insertion index index in list of indices
}
proc set-endtext {this value} {
$widget::($this,path) insert end $value
}
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 freeText::($this,drag) [new dragSite -path $widget::($this,path) -validcommand "freeText::validateDrag $this 0"]
dragSite::provide $freeText::($this,drag) OBJECTS "freeText::dragData $this"
set freeText::($this,selector) [new selector -selectcommand "freeText::setLabelsState $this"]
}
foreach option {-height -width} {
proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
}
proc dragData {this format} {
switch $format {
OBJECTS {
set list [selector::selected $freeText::($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 $freeText::($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 $freeText::($this,selector)] $label]>=0} {
return 1 ;# allow dragging from selected label only
} else {
return 0
}
}
proc supportedTypes {this} {
return {ascii dictionary integer real}
}
proc monitorCell {this array row column} {
viewer::registerTrace $this $array
set cell ${array}($row,$column)
if {[lsearch -exact [cellsFromLabels $this $freeText::($this,labels)] $cell]>=0} return ;# already displayed, abort
set path $widget::($this,path)
if {[info exists freeText::($this,nextCellIndex)]} { ;# recreate data cell labels placement from recorded configuration
set index [lindex $composite::($this,-cellindices) $freeText::($this,nextCellIndex)]
if {[string length $index]==0} { ;# indices list exhausted: we are done initializing from recorded data
unset freeText::($this,nextCellIndex)
set index insert ;# position cell window at insertion cursor
} else {
incr freeText::($this,nextCellIndex) ;# get ready for upcoming cell
}
} else {
set index insert ;# insert cell label text and window at insertion cursor
$path insert $index "[viewer::label $array $row $column]: "
}
set label [new label $path $cell]
set labelPath $label::($label,path)
# keep track of label existence
switched::configure $label -deletecommand "freeText::deletedLabel $this $array $label"
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 freeText::($this,drag,$label) $drag
set selector $freeText::($this,selector)
selector::add $selector $label
bind $labelPath <ButtonRelease-1> "selector::select $selector $label"
bind $labelPath <Control-ButtonRelease-1> "selector::toggle $selector $label"
bind $labelPath <Shift-ButtonRelease-1> "freeText::extendSelection $this $label"
}
lappend freeText::($this,labels) $label
$path window create $index -window $labelPath
set freeText::($this,cell,$label) $cell
}
proc update {this array args} { ;# update display using cells data. ignore eventual trace arguments
foreach label $freeText::($this,labels) {
if {[catch {set $freeText::($this,cell,$label)} value]} { ;# handle invalid cells
switched::configure $label -text ?
} else {
switched::configure $label -text $value
}
}
}
proc deletedLabel {this array label} {
if {$composite::($this,-draggable)} {
delete $freeText::($this,drag,$label)
selector::remove $freeText::($this,selector) $label
}
viewer::unregisterTrace $this $array ;# trace may no longer be needed on this array
ldelete freeText::($this,labels) $label
unset freeText::($this,cell,$label)
}
proc cellsFromLabels {this labels} {
set cells {}
foreach label $labels {
lappend cells $freeText::($this,cell,$label)
}
return $cells
}
proc cells {this} {
return [cellsFromLabels $this $freeText::($this,labels)]
}
proc setLabelsState {this labels select} {
foreach label $labels {
label::select $label $select
}
}
proc extendSelection {this endLabel} {
set selector $freeText::($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 $freeText::($this,labels) {
set labelFromPath($label::($label,path)) $label
}
# build ordered label list from windows returned ordered according to their postion (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 $freeText::($this,labels)]==0)&&([string length [string trim [$widget::($this,path) get 1.0 end]]]==0)}\
]
}
proc initializationConfiguration {this} {
set options {}
set text {}
foreach {key string index} [$widget::($this,path) dump -text 1.0 end] {
append text $string
}
lappend options -endtext $text
set indices {}
foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
if {[string length $path]==0} continue ;# ignore deleted windows
lappend indices $index
}
if {[llength $indices]>0} {
lappend options -cellindices $indices
}
return $options
}
}
class freeText {
class label {
proc label {this parentPath cell args} switched {$args} {
set label [new label $parentPath\
-font $font::(mediumBold) -relief sunken -padx 0 -pady 0 -borderwidth 1 -cursor top_left_arrow\
]
# 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
set ($this,cell) $cell
switched::complete $this
}
proc ~label {this} {
bind [set ($this,path)] <Destroy> {} ;# remove binding to avoid recursion
delete [set ($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 -deletecommand {} {}]\
[list -text {} {}]\
]
}
proc set-deletecommand {this value} {} ;# data is stored at switched level
proc set-text {this value} {
[set ($this,path)] configure -text $value
}
proc select {this select} {
if {$select} {
[set ($this,path)] configure -background white
} else {
[set ($this,path)] configure -background $widget::(default,ButtonBackgroundColor)
}
}
}
}
|
