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
|
# image.tk: rgbaImage TCL routines
#
# This file is part of the tkmorph package.
#
# Written and Copyright (C) 1996-1997 by Michael J. Gourlay
#
# PROVIDED AS IS. NO WARRENTIES, EXPRESS OR IMPLIED.
proc rgbaImageWarpCopyUpdate {} {
# Update the "warp" copies of images
#
# Intended to be called after a new image is loaded.
rgbaImage_src_warp free
rgbaImage_src_warp dissolve \
[rgbaImage_src_orig cget -this] [rgbaImage_dst_orig cget -this] 0.0
rgbaImage_dst_warp free
rgbaImage_dst_warp dissolve \
[rgbaImage_src_orig cget -this] [rgbaImage_dst_orig cget -this] 1.0
rgbaImage_twn_orig free
rgbaImage_twn_orig dissolve \
[rgbaImage_src_warp cget -this] [rgbaImage_dst_warp cget -this] 0.0
}
proc rgbaImagesInitialize {} {
# Create RgbaImages and PhotoImages
#
# RgbaImages are the "workhorse" images.
# PhotoImages are just for displaying.
#
# After creating these images, we store their tags in the global
# array variable "morph" so that other routines can access them.
global morph
# "original" images are the unmodified RgbaImage's that are later warped
# and dissolved. The unmodified form is kept around because it's
# expected that multiple warps and dissolves will be done, so we want
# to keep an unmodified version around without having to load it back
# in from disk.
# Create "original" source image.
RgbaImageT rgbaImage_src_orig
# Create "original" destination image.
RgbaImageT rgbaImage_dst_orig
# Create "original" tween image for creating warped dissolved images
RgbaImageT rgbaImage_twn_orig
# "warped" images are the RgbaImage copy of the warped "src" and
# "dst" images. These are kept in separate places because a
# dissolve can happen independently from a warp, and dissolves are a
# lot faster than warps. That means that we only want to perform
# warps when exlicitly asked to. Separate warped images are stored
# for src and dst images so that we can do as many dissolves of these
# as we want without having to rewarp.
#
# Create "original" warp src and dst images
RgbaImageT rgbaImage_src_warp
RgbaImageT rgbaImage_dst_warp
# Create "test pattern" images just to have something to show on
# the screen until the user loads images from files.
#
# Note that this also sets the size of the image if none was
# specified before now.
rgbaImage_src_orig reset 1
rgbaImage_dst_orig reset 2
# These dissolves are essentially just to make copies
rgbaImageWarpCopyUpdate
# "display" images are PhotoImages used only to display images.
set morph(image,src,display) [image create photo]
set morph(image,dst,display) [image create photo]
set morph(image,twn,display) [image create photo]
}
proc rgbaImageRead { this other mesh_src mesh_dst } {
global morph
set rgba_image_file [dirbrowser3 .f -message "Read Image" -filemask *.tga ]
if [llength $rgba_image_file] {
$this read $rgba_image_file
# Make sure both RgbaImages have the same dimensions
if { [$other cget -ncols] != [$this cget -ncols]
|| [$other cget -nrows] != [$this cget -nrows] } {
puts "rgbaImageRead: DRASTIC: Reseting the other image to fit"
$other free
$other alloc [$this cget -ncols] [$this cget -nrows]
$other reset 4
}
# Make sure meshes match the size of the new image
mesh_src scale [$this cget -ncols] [$this cget -nrows]
mesh_dst scale [$this cget -ncols] [$this cget -nrows]
rgbaImageWarpCopyUpdate
fakeExpose
# Force a dissolve to update the "tween" image
tweenImageDissolve -1.0
}
}
proc rgbaImageSave { this } {
set output_file [dirbrowser3 .f -message "Save Image" -filemask *.tga ]
if [llength $output_file] {
$this write $output_file
}
}
|
