This file is indexed.

/usr/share/blt2.4/demos/dnd2.tcl is in blt-demo 2.4z-4.2ubuntu1.

This file is owned by root:root, with mode 0o755.

The actual contents of the file can be viewed below.

  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
#!/usr/bin/wish

package require BLT
# --------------------------------------------------------------------------
# Starting with Tcl 8.x, the BLT commands are stored in their own 
# namespace called "blt".  The idea is to prevent name clashes with
# Tcl commands and variables from other packages, such as a "table"
# command in two different packages.  
#
# You can access the BLT commands in a couple of ways.  You can prefix
# all the BLT commands with the namespace qualifier "blt::"
#  
#    blt::graph .g
#    blt::table . .g -resize both
# 
# or you can import all the command into the global namespace.
#
#    namespace import blt::*
#    graph .g
#    table . .g -resize both
#
# --------------------------------------------------------------------------
if { $tcl_version >= 8.0 } {
    namespace import blt::*
    namespace import -force blt::tile::*
}
source scripts/demo.tcl

if { ([info exists tcl_platform]) && ($tcl_platform(platform) == "windows") } {
    error "This script works only under X11"
}

canvas .c -width 320 -height 320 -background white

blt::table . .c -fill both 

set lastCell ""
set cellWidth 1
set cellHeight 1
proc RedrawWorld { canvas } {
    global cells cellWidth cellHeight

    $canvas delete all

    set width [winfo width $canvas]
    set height [winfo height $canvas]

    set cellWidth [expr $width / 8]
    set cellHeight [expr $height / 8]

    for { set row 0 } { $row < 8 } { incr row } {
	set y [expr $row * $cellHeight]
	set h [expr $y + $cellHeight]
	for { set column 0 } { $column < 8 } { incr column } {
	    set x [expr $column * $cellWidth]
	    set w [expr $x + $cellWidth]
	    $canvas create rectangle $x $y $w $h -fill white -outline "" \
		-tags "$row,$column"
	}
    }

    for { set row 0 } { $row < 8 } { incr row } {
	set y [expr $row * $cellHeight]
	$canvas create line 0 $y $width $y 
    }
    
    for { set column 0 } { $column < 8 } { incr column } {
	set x [expr $column * $cellWidth]
	$canvas create line $x 0 $x $height 
    }
    foreach name [array names cells] {
	set rc [split $name ,]
	set row [lindex $rc 0]
	set column [lindex $rc 1]
	set x [expr ($column * $cellWidth) + 5]
	set y [expr ($row * $cellHeight) + 5]
	set w [expr $cellWidth - 10]
	set h [expr $cellHeight - 10]
	set color [lindex $cells($name) 0]
	set type [lindex $cells($name) 1]
	set pi1_2 [expr 3.14159265358979323846/180.0]
	set points {}
	switch $type {
	    hexagon { 
		lappend points $x [expr $y + $h/2] [expr $x + $w * 1/3] \
		    $y [expr $x + $w * 2/3] $y [expr $x + $w] [expr $y + $h/2] \
		    [expr $x + $w * 2/3] [expr $y + $h] \
		    [expr $x + $w * 1/3] [expr $y + $h] 
	    }
	    parallelogram   { 
		lappend points $x [expr $y + $h * 2/3] \
		    [expr $x + $w * 2/3] $y \
		    [expr $x + $w] [expr $y + $h * 1/3] \
		    [expr $x + $w * 1/3] [expr $y + $h]
	    }
	    triangle { 
		lappend points \
		    $x [expr $y + $h] \
		    [expr $x + $w * 1/2] $y \
		    [expr $x + $w] [expr $y + $h] 
	    }
	}
	eval .c create polygon $points -fill $color -outline black 
    }
}

bind .c <Configure> { RedrawWorld %W }

# ----------------------------------------------------------------------
#  USAGE:  random ?<max>? ?<min>?
#
#  Returns a random number in the range <min> to <max>.
#  If <min> is not specified, the default is 0; if max is not
#  specified, the default is 1.
# ----------------------------------------------------------------------

proc random {{max 1.0} {min 0.0}} {
    global randomSeed

    set randomSeed [expr (7141*$randomSeed+54773) % 259200]
    set num  [expr $randomSeed/259200.0*($max-$min)+$min]
    return $num
}
set randomSeed [clock clicks]

set itemTypes { parallelogram hexagon triangle }
set itemTypes { hexagon triangle parallelogram }

for { set i 0 } { $i < 20 } { incr i } {
    while { 1 } {
	set row [expr int([random 8])]
	set column [expr int([random 8])]
	set type [expr int([random 3])]
	set type [lindex $itemTypes $type]
	if { ![info exists cells($row,$column)] } {
	    set r [expr int([random 256 128])]
	    set g [expr int([random 256 128])]
	    set b [expr int([random 256 128])]
	    set cells($row,$column) [format "#%.2x%.2x%.2x %s" $r $g $b $type]
	    break
	}
    }
}

proc ScreenToCell { widget x y }  {
    global cellWidth cellHeight 
    set column [expr $x / $cellWidth]
    set row [expr $y / $cellHeight]
    return $row,$column
}


set count 0
foreach i [winfo interps] {
    puts $i
    if { [string match "dnd2.tcl*" $i] } {
	incr count
    }
}

if { $count == 1 }  {
    toplevel .info
    raise .info
    text .info.text -width 65 -height 12 -font { Helvetica 10 } -bg white \
	-tabs { 0.25i } 
    .info.text insert end {
	This is a more involved example of the new "dnd" command.  
	Run this script again to get another window. You can then drag
	and drop symbols between the windows by clicking with the left 
	mouse button on a symbol.  

	It demonstates how to 
		o Drag-and-drop on specific areas (canvas items) of a widget.
		o How to receive and handle Enter/Leave/Motion events in the target.
		o How to send drag feedback to the source.
		o Use a drag threshold. 
    }
    button .info.quit -text "Dismiss" -command { destroy .info }
    blt::table .info \
	0,0 .info.text -fill both \
	1,0 .info.quit
}


# -----------------------------------------------------------------
# 
#  Setup finished.  Start of drag-and-drop code here.
# 

# Set up the entire canvas as a drag&drop source.

dnd register .c -source yes  -dragthreshold 5 -button 1

# Register code to pick up the information about a canvas item

dnd getdata .c color GetColor

proc GetColor { widget args } {
    array set info $args
    global itemInfo
    set id $itemInfo($info(timestamp))
    set color [$widget itemcget $id -fill]
    set ncoords [llength [$widget coords $id]]
    if { $ncoords == 6 } {
	set type triangle
    } elseif { $ncoords == 8 } {
	set type parallelogram
    } elseif { $ncoords ==  12 } {
        set type hexagon
    } else {
	error "unknown type n=$ncoords"
    }
    return [list $color $type]
}

dnd configure .c -package PackageSample 

proc PackageSample { widget args } {
    array set info $args
    
    # Check if we're over a canvas item
    set items [$widget find overlapping $info(x) $info(y) $info(x) $info(y)]
    set pickedItem ""
    foreach i $items {
	if { [$widget type $i] == "polygon" } {
	    set pickedItem $i
	    break
	}
    }
    if { $pickedItem == "" } {
	# Cancel the drag
	puts "Cancel the drag x=$info(x) y=$info(y)"
	return 0
    }
    set fill [$widget itemcget $pickedItem -fill]
    set outline [$widget itemcget $pickedItem -outline]

    set ncoords [llength [$widget coords $pickedItem]]
    if { $ncoords == 6 } {
	set type triangle
    } elseif { $ncoords == 8 } {
	set type parallelogram
    } elseif { $ncoords ==  12 } {
        set type hexagon
    } else {
	error "unknown type n=$ncoords"
    }
    set tag [ScreenToCell $widget $info(x) $info(y)]
    $info(token).label configure -background $fill -foreground $outline \
	-text $type 
    update idletasks
    update
    global itemInfo
    set itemInfo($info(timestamp)) $pickedItem 
    return 1
}

# Configure a set of animated cursors.

dnd configure .c -cursors {
    { @bitmaps/hand/hand01.xbm bitmaps/hand/hand01m.xbm  black white }
    { @bitmaps/hand/hand02.xbm bitmaps/hand/hand02m.xbm  black white }
    { @bitmaps/hand/hand03.xbm bitmaps/hand/hand03m.xbm  black white }
    { @bitmaps/hand/hand04.xbm bitmaps/hand/hand04m.xbm  black white }
    { @bitmaps/hand/hand05.xbm bitmaps/hand/hand05m.xbm  black white }
    { @bitmaps/hand/hand06.xbm bitmaps/hand/hand06m.xbm  black white } 
    { @bitmaps/hand/hand07.xbm bitmaps/hand/hand07m.xbm  black white }
    { @bitmaps/hand/hand08.xbm bitmaps/hand/hand08m.xbm  black white }
    { @bitmaps/hand/hand09.xbm bitmaps/hand/hand09m.xbm  black white }
    { @bitmaps/hand/hand10.xbm bitmaps/hand/hand10m.xbm  black white }
    { @bitmaps/hand/hand11.xbm bitmaps/hand/hand11m.xbm  black white }
    { @bitmaps/hand/hand12.xbm bitmaps/hand/hand12m.xbm  black white }
    { @bitmaps/hand/hand13.xbm bitmaps/hand/hand13m.xbm  black white }
    { @bitmaps/hand/hand14.xbm bitmaps/hand/hand14m.xbm  black white }
}

# Create a widget to place in the drag-and-drop token

set token [dnd token window .c]

label $token.label -bd 2 -highlightthickness 1  
pack $token.label
dnd token configure .c \
    -borderwidth 2 \
    -relief raised -activerelief raised  \
    -outline pink -fill red \
    -anchor s


dnd configure .c -target yes

dnd setdata .c color { 
    NewObject 
}

proc NewObject { widget args } {
    array set info $args
    set tag [ScreenToCell $widget $info(x) $info(y)]
    global cells
    if { [info exists cells($tag)] } {
	error "Cell already exists"
    }
    set cells($tag) $info(value)
    RedrawWorld $widget

}

dnd configure .c -onmotion OnMotion -onenter OnMotion -onleave OnMotion 

proc OnMotion { widget args } {
    global cells lastCell

    array set info $args
    set tag [ScreenToCell $widget $info(x) $info(y)]
    if { $lastCell != "" } {
	$widget itemconfigure $lastCell -fill white -outline "" -width 1 \
	    -stipple ""
    }
    # Check that we're not over a canvas item
    if { ![info exists cells($tag)] } {
	$widget itemconfigure $tag -outline lightblue -fill lightblue \
	    -width 2 -stipple BLT
	set lastCell $tag
	return 1
    }
    return 0
}