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
|
#!/usr/bin/env tclsh
## -*- tcl -*-
# ### ### ### ######### ######### #########
## DEMO. Slice image into tiles and show them, in order, or randomly
## shuffled. Image can be provided as argument, or uses the
## 'morgens.jpg' from the example directory as default. Accepts
## jpeg and png images.
# ### ### ### ######### ######### #########
## For data files found relative to the example's location.
set selfdir [file dirname [file normalize [info script]]]
## Ideas: It should be possible to get feedback on mouse clicks and
## use that to let the user swaps cells, until the shown image is
## restored to order.
# ### ### ### ######### ######### #########
## Other requirements for this example.
package require Tk
package require widget::scrolledwindow
package require canvas::sqmap
package require crosshair
package require img::jpeg
package require img::png
package require snit ; # canvas::sqmap dependency
package require uevent::onidle ; # ditto
package require cache::async 0.2 ; # ditto
# ### ### ### ######### ######### #########
proc Init {} {
global argv tile scrollw scrollh basepicks maxw maxh
set image [lindex $argv 0]
if {$image eq ""} {
set image [file join [file dirname [file normalize [info script]]] morgens.jpg]
}
set image [image create photo -file $image]
set scrollw [image width $image]
set scrollh [image height $image]
set tile 256
set maxh 0
for {set y 0} {$y < $scrollh} {incr y $tile} {
set y1 $y ; incr y1 $tile
if {$y1 > $scrollh} { set y1 $scrollh }
set maxw 0
for {set x 0} {$x < $scrollw} {incr x $tile} {
set x1 $x ; incr x1 $tile
if {$x1 > $scrollw} { set x1 $scrollh }
set parcel [image create photo -height $tile -width $tile]
$parcel copy $image -from $x $y $x1 $y1
lappend basepicks $parcel
incr maxw
}
incr maxh
}
image delete $image
InitPicksUnordered
return
}
# ### ### ### ######### ######### #########
set location {}
proc GUI {} {
global tile scrollw scrollh
widget::scrolledwindow .sw
canvas::sqmap .map
button .exit -command exit -text Exit
button .shfl -command Shuffle -text Shuffle
button .ord -command Order -text Original
entry .loc -textvariable location \
-bd 2 -relief sunken -bg white -width 40
.sw setwidget .map
# Panning via mouse
bind .map <ButtonPress-2> {%W scan mark %x %y}
bind .map <B2-Motion> {%W scan dragto %x %y}
# Cross hairs ...
.map configure -cursor tcross
crosshair::crosshair .map -width 0 -fill \#999999 -dash {.}
crosshair::track on .map TRACK
#.map configure -grid-show-borders 1 ;# This leaks items = memory
if 0 {
# This routes the requests and results through GOT/GET logging
# commands.
.map configure \
-grid-cell-command GET \
-grid-cell-width $tile \
-grid-cell-height $tile \
-scrollregion [list 0 0 $scrollw $scrollh]
} else {
# This routes the requests directly to the grid provider, and
# results back.
.map configure \
-grid-cell-command Pick \
-grid-cell-width $tile \
-grid-cell-height $tile \
-scrollregion [list 0 0 $scrollw $scrollh]
}
pack .sw -expand 1 -fill both -side bottom
pack .exit -expand 0 -fill both -side left
pack .shfl -expand 0 -fill both -side left
pack .ord -expand 0 -fill both -side left
pack .loc -expand 0 -fill both -side left
return
}
proc Shuffle {} {
InitPicksUnordered
.map flush
return
}
proc Order {} {
InitPicksOrdered
.map flush
return
}
proc InitPicksUnordered {} {
global picks basepicks order
set picks [shuffle5a $basepicks]
set order 0
return
}
proc InitPicksOrdered {} {
global picks basepicks order
set picks $basepicks
set order 1
return
}
# ### ### ### ######### ######### #########
# Basic callback structure, log for logging, facade to transform the
# cache/tiles result into what xcanvas is expecting.
proc GET {__ at donecmd} {
puts "GET ($at) ($donecmd)"
Pick get $at [list GOT $donecmd]
return
}
proc GOT {donecmd what at args} {
puts "\tGOT $donecmd $what ($at) $args"
if {[catch {
uplevel #0 [eval [linsert $args 0 linsert $donecmd end $what $at]]
}]} { puts $::errorInfo }
return
}
# ### ### ### ######### ######### #########
proc TRACK {win x y args} {
# args = viewport, pixels, see also xcanvas, SetPixelView.
global location
set location "@ $x, $y"
return
}
# ### ### ### ######### ######### #########
proc Pick {__ at donecmd} {
global picks image order maxw maxh
if {[llength $picks]} {
if {$order} {
foreach {r c} $at break
set i [expr {$c + ($r * $maxw)}]
set choice [lindex $picks $i]
} else {
set choice [lindex $picks end]
set picks [lreplace [K $picks [unset picks]] end end]
}
uplevel #0 [linsert $donecmd end set $at $choice]
} else {
uplevel #0 [linsert $donecmd end unset $at]
}
return
}
proc shuffle5a { list } {
set n 1
set slist {}
foreach item $list {
set index [expr {int(rand()*$n)}]
set slist [linsert [K $slist [set slist {}]] $index $item]
incr n
}
return $slist
}
proc K { x y } { set x }
# ### ### ### ######### ######### #########
## Basic interface.
Init
GUI
|
