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
|
# canvas.tk: canvas creation TCL/Tk routines
#
# This file is part of the tkmorph package.
#
# Written and Copyright (C) 1996 by Michael J. Gourlay
#
# Provided as is. No warrenties, express or implied.
set previous_warp -1.00
proc scaleMeshWarp { warp } {
# Callback for warp slider
global previous_warp
# Need to test to see if scale actually changes because Tk reports
# scale change events erroneously.
if { $previous_warp != $warp } {
set previous_warp $warp
verbose "scaleMeshWarp: warp= $warp"
meshTweenInterpolate
meshDrawAll
}
}
set previous_scale -1.00
proc tweenImageDissolve { scale } {
# Callback for tween image dissolve scale slider
#
# A key to understanding this routine is that the slider is mapped
# to the global array variable element morph(dissolve).
# That means that the incoming value of "scale" is the same
# as morph(dissolve) when this routine is called as the callback of
# the dissolve slider. However, this routine is also called at other
# times when a dissolve is done for other reasons. In that case, the
# argument value of scale is not the same as morph(dissolve).
#
# The reason for all of this is that Tk sliders have the disgusting
# behavior (probably a bug) that their callback is called even when the
# slider value does not change. This also happens sometimes when the
# mouse goes into the slider window, even if a mouse button is not
# pressed. This causes a lot of callbacks that do nothing real, but
# they can waste a lot of processor time if you do not check for real
# slider motion.
global previous_scale
global morph
# Need to test to see if scale actually changes because Tk reports
# scale change events erroneously.
if { $previous_scale != $scale } {
set previous_scale $morph(dissolve)
verbose "tweenImageDissolve: scale= $scale"
# Free the old tween image
rgbaImage_twn_orig free
# Dissolve to get the new tween image
rgbaImage_twn_orig dissolve [rgbaImage_src_warp cget -this] \
[rgbaImage_dst_warp cget -this] $morph(dissolve)
# Transfer rgbaImage to photoImage for display
rgbaImage_twn_orig toPhoto $morph(image,twn,display)
}
}
proc scrollableCanvasCreate { parent } {
# Create a canvas with two scrollbars
canvas $parent.canvas \
-width 300 -height 200 \
-scrollregion { 0 0 1000 2000 } \
-xscrollcommand [list $parent.xscroll set] \
-yscrollcommand [list $parent.yscroll set]
# Set up scrollbars for canvas
scrollbar $parent.xscroll -orient horizontal \
-command [list $parent.canvas xview]
scrollbar $parent.yscroll -orient vertical \
-command [list $parent.canvas yview]
# Manage the scrollbars
pack $parent.xscroll -side bottom -fill x
pack $parent.yscroll -side right -fill y
pack $parent.canvas -side right -fill both -expand true
return $parent.canvas
}
proc canvasesCreate { parent } {
# canvasesCreate: Create the array of image canvases
# Also creates sliders for dissolve and tween mesh
#
# Read access to some members of global array variable morph
# so they need to be set before calling this routine.
global morph
# Create a frame for each canvas.
#
# Each frame has a different color as a mnemonic for the contents
set frame_src [frame $parent.frame_canvas_src -bg $morph(src,color) \
-relief ridge -bd 5]
set frame_dst [frame $parent.frame_canvas_dst -bg $morph(dst,color) \
-relief ridge -bd 5]
set frame_tween [frame $parent.frame_canvas_twn -bg $morph(twn,color) \
-relief ridge -bd 5]
# ---- Create canvases with photoImages ----
# Source image canvas:
set morph(canvas,src) [scrollableCanvasCreate $frame_src]
# Place the "display" PhotoImage into the canvas
# at canvas location 0,0
# -anchor nw: refer to upper-left corner of the image (default is center)
# -tag image: give this image the tag "image" for later manipulation
set image_src [$morph(canvas,src) create image 0 0 \
-image $morph(image,src,display) -anchor nw -tag image]
# Destination image canvas:
set morph(canvas,dst) [scrollableCanvasCreate $frame_dst]
set image_dst [$morph(canvas,dst) create image 0 0 \
-image $morph(image,dst,display) -anchor nw -tag image]
# Tween image canvas:
set morph(canvas,twn) [scrollableCanvasCreate $frame_tween]
set image_twn [$morph(canvas,twn) create image 0 0 \
-image $morph(image,twn,display) -anchor nw -tag image]
# ---- Create sliders and labels for sliders ----
# Create frame for slider and label
set frame_sd [frame $parent.frame_slider_dissolve -relief ridge -bd 5]
# Create label for dissolve slider
set label_sd [label $frame_sd.label_slider_dissolve \
-text "D\ni\ns\ns\no\nl\nv\ne"]
# Pack the label for dissolve into its frame
pack $label_sd -side top
# Create dissolve slider
set slider_dissolve [scale $frame_sd.slider_dissolve -from 0 -to 1 \
-length 100 \
-variable morph(dissolve) \
-command tweenImageDissolve \
-orient vertical \
-showvalue false \
-troughcolor blue \
-relief ridge -bd 3 \
-resolution 0.01
]
# Pack the slider for dissolve into its frame
pack $slider_dissolve -side top -fill y -expand true
# Create frame for slider and label
set frame_sw [frame $parent.frame_slider_warp -relief ridge -bd 5]
# Create label for dissolve slider
set label_sw [label $frame_sw.label_slider_warp -text "\n\nW\na\nr\np\n\n"]
# Pack the label for warp into its frame
pack $label_sw -side top
# Create warp slider
set slider_warp [scale $frame_sw.slider_warp -from 0 -to 1 \
-length 100 \
-variable morph(warp) \
-command scaleMeshWarp \
-orient vertical \
-showvalue false \
-relief ridge -bd 3 \
-resolution 0.01
]
# Pack the slider for warp into its frame
pack $slider_warp -side top -fill y -expand true
## Place the upper left corner of the image 5 pixels away from the
## canvas corner
#$morph(canvas,src) coords image 5 5
#$morph(canvas,dst) coords image 5 5
# Manage the frames
pack $frame_tween -side right
pack $frame_sd -side right -fill y
pack $frame_sw -side right -fill y
pack $frame_src -side left -side top
pack $frame_dst -side left -side bottom
}
|
