line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
## ---------------------------------------------------------------------------- |
2
|
|
|
|
|
|
|
# Image::Identicon. |
3
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
4
|
|
|
|
|
|
|
# Mastering programmed by YAMASHINA Hio |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# Copyright 2007 YAMASHINA Hio |
7
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
8
|
|
|
|
|
|
|
# $Id: /perl/Image-Identicon/lib/Image/Identicon.pm 344 2007-02-02T16:41:20.275333Z hio $ |
9
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
10
|
|
|
|
|
|
|
package Image::Identicon; |
11
|
|
|
|
|
|
|
|
12
|
2
|
|
|
2
|
|
60064
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
80
|
|
13
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
55
|
|
14
|
|
|
|
|
|
|
|
15
|
2
|
|
|
2
|
|
2235
|
use GD; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
BEGIN{ |
17
|
|
|
|
|
|
|
# GD::Polyline raise noisy redefine warning. |
18
|
|
|
|
|
|
|
local($^W) = 0; |
19
|
|
|
|
|
|
|
require GD::Polyline; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
use Digest::SHA qw(sha1); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
our $SCALE_LIMIT = 100; |
26
|
|
|
|
|
|
|
our $SIZE_LIMIT = 300; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
our $DEBUG = 0; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
1; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
33
|
|
|
|
|
|
|
# Image::Indenticon->new(salt=>$salt); |
34
|
|
|
|
|
|
|
# |
35
|
|
|
|
|
|
|
sub new |
36
|
|
|
|
|
|
|
{ |
37
|
|
|
|
|
|
|
my $pkg = shift; |
38
|
|
|
|
|
|
|
my $opts = @_ && ref($_[0]) ? shift : {@_}; |
39
|
|
|
|
|
|
|
my $this = {}; |
40
|
|
|
|
|
|
|
$this->{salt} = $opts->{salt}; |
41
|
|
|
|
|
|
|
$this->{render} = $opts->{render}; |
42
|
|
|
|
|
|
|
$this->{salt} or die "no salt"; |
43
|
|
|
|
|
|
|
bless $this, $pkg; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
47
|
|
|
|
|
|
|
# my $code = $obj->identicon_code(); |
48
|
|
|
|
|
|
|
# my $code = $obj->identicon_code($addr); |
49
|
|
|
|
|
|
|
# calc 32bit identicon code from ip address. |
50
|
|
|
|
|
|
|
# |
51
|
|
|
|
|
|
|
sub identicon_code |
52
|
|
|
|
|
|
|
{ |
53
|
|
|
|
|
|
|
my $this = shift; |
54
|
|
|
|
|
|
|
my $addr = shift || $ENV{REMOTE_ADDR} || '0.0.0.0'; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
$this->{salt} or die "isalt must be set prior to retrieving identicon code"; |
57
|
|
|
|
|
|
|
my @ip = $addr =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/; |
58
|
|
|
|
|
|
|
my $packed = pack("C*", @ip); |
59
|
|
|
|
|
|
|
join('.', unpack("C*",$packed)) eq $addr or die "invalid ip addr: $addr"; |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
my $ipint = unpack("N", $packed); |
62
|
|
|
|
|
|
|
my $code = unpack("N", sha1("$ipint+$this->{salt}")); |
63
|
|
|
|
|
|
|
$code; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
67
|
|
|
|
|
|
|
# $obj->decode($code); |
68
|
|
|
|
|
|
|
# |
69
|
|
|
|
|
|
|
sub decode |
70
|
|
|
|
|
|
|
{ |
71
|
|
|
|
|
|
|
my $this = shift; |
72
|
|
|
|
|
|
|
my $code = shift; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# decode the code into parts |
75
|
|
|
|
|
|
|
# |
76
|
|
|
|
|
|
|
# bit 0-1: center patch type |
77
|
|
|
|
|
|
|
# bit 2: center invert |
78
|
|
|
|
|
|
|
# bit 3-6: corner patch type |
79
|
|
|
|
|
|
|
# bit 7: corner invert |
80
|
|
|
|
|
|
|
# bit 8-9: corner turns |
81
|
|
|
|
|
|
|
# bit 10-13: side patch type |
82
|
|
|
|
|
|
|
# bit 14: side invert |
83
|
|
|
|
|
|
|
# bit 15: corner turns |
84
|
|
|
|
|
|
|
# bit 16-20: blue color component |
85
|
|
|
|
|
|
|
# bit 21-26: green color component |
86
|
|
|
|
|
|
|
# bit 27-31: red color component |
87
|
|
|
|
|
|
|
my $center_type = ($code & 0x3); |
88
|
|
|
|
|
|
|
my $center_invert = (($code >> 2) & 0x01) != 0; |
89
|
|
|
|
|
|
|
my $corner_type = (($code >> 3) & 0x0f); |
90
|
|
|
|
|
|
|
my $corner_invert = (($code >> 7) & 0x01) != 0; |
91
|
|
|
|
|
|
|
my $corner_turn = (($code >> 8) & 0x03); |
92
|
|
|
|
|
|
|
my $side_type = (($code >> 10) & 0x0f); |
93
|
|
|
|
|
|
|
my $side_invert = (($code >> 14) & 0x01) != 0; |
94
|
|
|
|
|
|
|
my $side_turn = (($code >> 15) & 0x03); |
95
|
|
|
|
|
|
|
my $blue = (($code >> 16) & 0x01f)<<3; |
96
|
|
|
|
|
|
|
my $green = (($code >> 21) & 0x01f)<<3; |
97
|
|
|
|
|
|
|
my $red = (($code >> 27) & 0x01f)<<3; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
if( $DEBUG ) |
100
|
|
|
|
|
|
|
{ |
101
|
|
|
|
|
|
|
print "[decode]\n"; |
102
|
|
|
|
|
|
|
print "- (center) = ($center_type, -, $center_invert)\n"; |
103
|
|
|
|
|
|
|
print "- (corner) = ($corner_type, $corner_turn, $corner_invert)\n"; |
104
|
|
|
|
|
|
|
print "- (side) = ($side_type, $side_turn, $side_invert)\n"; |
105
|
|
|
|
|
|
|
print "- (r,g,b) = ($red, $green, $blue)\n"; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
my $decode = { |
109
|
|
|
|
|
|
|
center_type => $center_type, |
110
|
|
|
|
|
|
|
center_invert => $center_invert, |
111
|
|
|
|
|
|
|
corner_type => $corner_type, |
112
|
|
|
|
|
|
|
corner_invert => $corner_invert, |
113
|
|
|
|
|
|
|
corner_turn => $corner_turn, |
114
|
|
|
|
|
|
|
side_type => $side_type, |
115
|
|
|
|
|
|
|
side_invert => $side_invert, |
116
|
|
|
|
|
|
|
side_turn => $side_turn, |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
red => $red, |
119
|
|
|
|
|
|
|
green => $green, |
120
|
|
|
|
|
|
|
blue => $blue, |
121
|
|
|
|
|
|
|
}; |
122
|
|
|
|
|
|
|
$decode; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
126
|
|
|
|
|
|
|
# my $result = $obj->identicon_code(\%opts); |
127
|
|
|
|
|
|
|
# render image. |
128
|
|
|
|
|
|
|
# returns GD::Image through $result->{image}. |
129
|
|
|
|
|
|
|
# |
130
|
|
|
|
|
|
|
sub render |
131
|
|
|
|
|
|
|
{ |
132
|
|
|
|
|
|
|
my $this = shift; |
133
|
|
|
|
|
|
|
my $opts; |
134
|
|
|
|
|
|
|
if( !@_ ) |
135
|
|
|
|
|
|
|
{ |
136
|
|
|
|
|
|
|
$opts = {}; |
137
|
|
|
|
|
|
|
}elsif( ref($_[0]) ) |
138
|
|
|
|
|
|
|
{ |
139
|
|
|
|
|
|
|
$opts = shift; |
140
|
|
|
|
|
|
|
}elsif( $_[0]=~/^[-a-z]/ ) |
141
|
|
|
|
|
|
|
{ |
142
|
|
|
|
|
|
|
$opts = {@_}; |
143
|
|
|
|
|
|
|
}else |
144
|
|
|
|
|
|
|
{ |
145
|
|
|
|
|
|
|
# deprecated interface: $obj->identicon_code($code); |
146
|
|
|
|
|
|
|
$opts->{code} = shift || $this->identicon_code; |
147
|
|
|
|
|
|
|
$opts->{scale} = shift || 10; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
my $code = $opts->{code}; |
150
|
|
|
|
|
|
|
my $scale = $opts->{scale}; |
151
|
|
|
|
|
|
|
my $size = $opts->{size}; |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
if( !$scale ) |
154
|
|
|
|
|
|
|
{ |
155
|
|
|
|
|
|
|
if( !$size ) |
156
|
|
|
|
|
|
|
{ |
157
|
|
|
|
|
|
|
$scale = 3; |
158
|
|
|
|
|
|
|
}else |
159
|
|
|
|
|
|
|
{ |
160
|
|
|
|
|
|
|
my $patch_size = 5; |
161
|
|
|
|
|
|
|
$scale = int($size*4/3/$patch_size); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
$scale >= $SCALE_LIMIT and $scale = $SCALE_LIMIT; |
165
|
|
|
|
|
|
|
$size && $size>=$SIZE_LIMIT and $size = $SIZE_LIMIT; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
if( $DEBUG ) |
168
|
|
|
|
|
|
|
{ |
169
|
|
|
|
|
|
|
$size ||= ''; |
170
|
|
|
|
|
|
|
print "[render.prepare]\n"; |
171
|
|
|
|
|
|
|
print "- size = $size\n"; |
172
|
|
|
|
|
|
|
print "- scale = $scale\n"; |
173
|
|
|
|
|
|
|
print "- code = $code\n"; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
my $decode = $this->decode($code); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# render. |
179
|
|
|
|
|
|
|
my $rpkg = $opts->{render} || $this->{render} || 'Image::Identicon::Render'; |
180
|
|
|
|
|
|
|
my $r = $rpkg->new({ |
181
|
|
|
|
|
|
|
%$decode, |
182
|
|
|
|
|
|
|
code => $code, |
183
|
|
|
|
|
|
|
scale => $scale, |
184
|
|
|
|
|
|
|
size => $size, |
185
|
|
|
|
|
|
|
}); |
186
|
|
|
|
|
|
|
$r->render(); |
187
|
|
|
|
|
|
|
$r->_resize(); |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
$r; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
193
|
|
|
|
|
|
|
# Renderer. |
194
|
|
|
|
|
|
|
# |
195
|
|
|
|
|
|
|
package Image::Identicon::Render; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# 5x5 matrix. |
198
|
|
|
|
|
|
|
# 00 01 02 03 04 |
199
|
|
|
|
|
|
|
# 05 06 07 08 09 |
200
|
|
|
|
|
|
|
# 10 11 12 13 14 |
201
|
|
|
|
|
|
|
# 15 16 17 18 19 |
202
|
|
|
|
|
|
|
# 20 21 22 23 24 |
203
|
|
|
|
|
|
|
our $PATCHES = [ |
204
|
|
|
|
|
|
|
[ 0, 4, 24, 20, 0, ], # 0 |
205
|
|
|
|
|
|
|
[ 0, 4, 20, 0, ], # 1 |
206
|
|
|
|
|
|
|
[ 2, 24, 20, 2, ], # 2 |
207
|
|
|
|
|
|
|
[ 0, 2, 20, 22, 0, ], # 3 |
208
|
|
|
|
|
|
|
[ 2, 14, 22, 10, 2, ], # 4 |
209
|
|
|
|
|
|
|
[ 0, 14, 24, 22, 0, ], # 5 |
210
|
|
|
|
|
|
|
[ 2, 24, 22, 13, 11, 22, 20, 2, ], # 6 |
211
|
|
|
|
|
|
|
[ 0, 14, 22, 0, ], # 7 |
212
|
|
|
|
|
|
|
[ 6, 8, 18, 16, 6, ], # 8 |
213
|
|
|
|
|
|
|
[ 4, 20, 10, 12, 2, 4, ], # 9 |
214
|
|
|
|
|
|
|
[ 0, 2, 12, 10, 0, ], # 10 |
215
|
|
|
|
|
|
|
[ 10, 14, 22, 10, ], # 11 |
216
|
|
|
|
|
|
|
[ 20, 12, 24, 20, ], # 12 |
217
|
|
|
|
|
|
|
[ 10, 2, 12, 10, ], # 12 |
218
|
|
|
|
|
|
|
[ 0, 2, 10, 0, ], # 14 |
219
|
|
|
|
|
|
|
[ 0, 5, 11, 15, 20, 21, 17, 23, 24, 19, 13, 9, 4, 3, 7, 1, 0], # 15 |
220
|
|
|
|
|
|
|
]; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
our $PATCH_SYMMETRIC = 1; |
223
|
|
|
|
|
|
|
our $PATCH_INVERTED = 2; |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
our $PATCH_FLAGS = [ |
226
|
|
|
|
|
|
|
$PATCH_SYMMETRIC, 0, 0, 0, |
227
|
|
|
|
|
|
|
$PATCH_SYMMETRIC, 0, 0, 0, |
228
|
|
|
|
|
|
|
$PATCH_SYMMETRIC, 0, 0, 0, |
229
|
|
|
|
|
|
|
0, 0, 0, $PATCH_SYMMETRIC, |
230
|
|
|
|
|
|
|
]; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
our $CENTER_PATCHES = [ 0, 4, 8, 15, ]; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
our $PATCH_SIZE = 5; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
1; |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub _patch_size() { $PATCH_SIZE } |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
sub new |
241
|
|
|
|
|
|
|
{ |
242
|
|
|
|
|
|
|
my $pkg = shift; |
243
|
|
|
|
|
|
|
my $opts = shift; |
244
|
|
|
|
|
|
|
my $this = bless {%$opts}, $pkg; |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
$this->{center_type} = $CENTER_PATCHES->[$this->{center_type}&3]; |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
my $scale = $opts->{scale}; |
249
|
|
|
|
|
|
|
my $patch_size = $pkg->_patch_size; |
250
|
|
|
|
|
|
|
my $patch_width = ($patch_size-1) * $scale + 1; |
251
|
|
|
|
|
|
|
my $source_size = $patch_width * 3; |
252
|
|
|
|
|
|
|
my $image = new GD::Image($source_size, $source_size, 1); |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# color components are used at top of the range for color difference |
255
|
|
|
|
|
|
|
# use white background for now. |
256
|
|
|
|
|
|
|
# TODO: support transparency. |
257
|
|
|
|
|
|
|
my ($red, $green, $blue) = @$this{qw(red green blue)}; |
258
|
|
|
|
|
|
|
my $fore_color = $image->colorAllocate($red, $green, $blue); |
259
|
|
|
|
|
|
|
my $back_color = $image->colorAllocate(255,255,255); |
260
|
|
|
|
|
|
|
$image->transparent($back_color); |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
# outline shapes with a noticeable color (complementary will do) if |
263
|
|
|
|
|
|
|
# shape color and background color are too similar (measured by color |
264
|
|
|
|
|
|
|
# distance). |
265
|
|
|
|
|
|
|
my $stroke_color = undef; |
266
|
|
|
|
|
|
|
{ |
267
|
|
|
|
|
|
|
my $dr = $red-255; |
268
|
|
|
|
|
|
|
my $dg = $green-255; |
269
|
|
|
|
|
|
|
my $db = $blue-255; |
270
|
|
|
|
|
|
|
my $distance = sqrt($dr**2 + $dg**2 + $db**2); |
271
|
|
|
|
|
|
|
$DEBUG and print "distance $distance (< 32.0 ?)\n"; |
272
|
|
|
|
|
|
|
if( $distance < 32.0 ) |
273
|
|
|
|
|
|
|
{ |
274
|
|
|
|
|
|
|
$stroke_color = $image->colorAllocate($red^255, $green^255, $blue^255); |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
$this->{image} = $image; |
279
|
|
|
|
|
|
|
$this->{patch_size} = $patch_size; |
280
|
|
|
|
|
|
|
$this->{patch_width} = $patch_width; |
281
|
|
|
|
|
|
|
$this->{scale} = $scale; |
282
|
|
|
|
|
|
|
$this->{fore_color} = $fore_color; |
283
|
|
|
|
|
|
|
$this->{back_color} = $back_color; |
284
|
|
|
|
|
|
|
$this->{stroke_color} = $stroke_color; |
285
|
|
|
|
|
|
|
$this; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
sub render |
289
|
|
|
|
|
|
|
{ |
290
|
|
|
|
|
|
|
my $r = shift; |
291
|
|
|
|
|
|
|
my $center_type = $r->{center_type}; |
292
|
|
|
|
|
|
|
my $center_invert = $r->{center_invert}; |
293
|
|
|
|
|
|
|
my $corner_type = $r->{corner_type}; |
294
|
|
|
|
|
|
|
my $corner_invert = $r->{corner_invert}; |
295
|
|
|
|
|
|
|
my $corner_turn = $r->{corner_turn}; |
296
|
|
|
|
|
|
|
my $side_type = $r->{side_type}; |
297
|
|
|
|
|
|
|
my $side_invert = $r->{side_invert}; |
298
|
|
|
|
|
|
|
my $side_turn = $r->{side_turn}; |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# center patch |
301
|
|
|
|
|
|
|
$DEBUG and print "[center]\n"; |
302
|
|
|
|
|
|
|
$r->draw({ x=>1, y=>1, patch=>$center_type, turn=>0, invert=>$center_invert}); |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# side patchs, starting from top and moving clock-wise |
305
|
|
|
|
|
|
|
$DEBUG and print "[sides]\n"; |
306
|
|
|
|
|
|
|
$r->draw({ x=>1, y=>0, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert}); |
307
|
|
|
|
|
|
|
$r->draw({ x=>2, y=>1, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert}); |
308
|
|
|
|
|
|
|
$r->draw({ x=>1, y=>2, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert}); |
309
|
|
|
|
|
|
|
$r->draw({ x=>0, y=>1, patch=>$side_type, turn=>$side_turn++, invert=>$side_invert}); |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# corner patchs, starting from top left and moving clock-wise |
312
|
|
|
|
|
|
|
$DEBUG and print "[corneres]\n"; |
313
|
|
|
|
|
|
|
$r->draw({ x=>0, y=>0, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert}); |
314
|
|
|
|
|
|
|
$r->draw({ x=>2, y=>0, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert}); |
315
|
|
|
|
|
|
|
$r->draw({ x=>2, y=>2, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert}); |
316
|
|
|
|
|
|
|
$r->draw({ x=>0, y=>2, patch=>$corner_type, turn=>$corner_turn++, invert=>$corner_invert}); |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
return $r; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
sub draw |
322
|
|
|
|
|
|
|
{ |
323
|
|
|
|
|
|
|
my $r = shift; |
324
|
|
|
|
|
|
|
my $opts = ref($_[0])?shift:{@_}; |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
my $image = $r->{image}; |
327
|
|
|
|
|
|
|
my $scale = $r->{scale}; |
328
|
|
|
|
|
|
|
my $fore = $r->{fore_color}; |
329
|
|
|
|
|
|
|
my $back = $r->{back_color}; |
330
|
|
|
|
|
|
|
my $stroke = $r->{stroke_color}; |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
my $patch_size = $r->{patch_size} || $PATCH_SIZE; |
333
|
|
|
|
|
|
|
my $width = $r->{patch_width} || ($patch_size-1) * $scale + 1; |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
my $x = $opts->{x}; |
336
|
|
|
|
|
|
|
my $y = $opts->{y}; |
337
|
|
|
|
|
|
|
my $patch = $opts->{patch}; |
338
|
|
|
|
|
|
|
my $turn = $opts->{turn}; |
339
|
|
|
|
|
|
|
my $invert = $opts->{invert}; |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
$patch>=0 or die "\$patch >= 0 failed, got $patch"; |
342
|
|
|
|
|
|
|
$turn >=0 or die "\$turn >= 0 failed, got $turn"; |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
$x *= $width; |
345
|
|
|
|
|
|
|
$y *= $width; |
346
|
|
|
|
|
|
|
$patch %= @$PATCHES; |
347
|
|
|
|
|
|
|
$turn %= 4; |
348
|
|
|
|
|
|
|
if( ($PATCH_FLAGS->[$patch] & $PATCH_INVERTED) != 0 ) |
349
|
|
|
|
|
|
|
{ |
350
|
|
|
|
|
|
|
$invert = !$invert; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
$invert ||= 0; |
353
|
|
|
|
|
|
|
$invert and ($fore, $back) = ($back, $fore); |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
$DEBUG and print "(x,y) = ($x, $y)\n"; |
356
|
|
|
|
|
|
|
$DEBUG and print "(patch, turn, invert) = ($patch, $turn, $invert)\n"; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# paint background |
359
|
|
|
|
|
|
|
$image->filledRectangle($x, $y, $x+$width, $y+$width, $back); |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
# polything. |
362
|
|
|
|
|
|
|
$DEBUG and print "- poly\n"; |
363
|
|
|
|
|
|
|
my $pl = GD::Polyline->new(); |
364
|
|
|
|
|
|
|
foreach my $pt (@{$PATCHES->[$patch]}) |
365
|
|
|
|
|
|
|
{ |
366
|
|
|
|
|
|
|
my $dx = $pt % $patch_size; |
367
|
|
|
|
|
|
|
my $dy = int( $pt / $patch_size ); |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
my $px = int( $dx / ($patch_size-1) * $width ); |
370
|
|
|
|
|
|
|
my $py = int( $dy / ($patch_size-1) * $width ); |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
$turn==1 and ($px, $py) = ($width-$py, $px); |
373
|
|
|
|
|
|
|
$turn==2 and ($px, $py) = ($width-$px, $width-$py); |
374
|
|
|
|
|
|
|
$turn==3 and ($px, $py) = ($py, $width-$px); |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
$pl->addPt($x+$px, $y+$py); |
377
|
|
|
|
|
|
|
$DEBUG and print "- ($px, $py) ($dx, $dy, $pt)\n"; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
# render rotated patch using fore color (back color if inverted) |
381
|
|
|
|
|
|
|
$image->filledPolygon($pl, $fore); |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
# if stroke color was specified, apply stroke |
384
|
|
|
|
|
|
|
# stroke color should be specified if fore color is too close to the |
385
|
|
|
|
|
|
|
# back color. |
386
|
|
|
|
|
|
|
if( $stroke ) |
387
|
|
|
|
|
|
|
{ |
388
|
|
|
|
|
|
|
$image->polyline($pl, $stroke); |
389
|
|
|
|
|
|
|
$DEBUG and print "- stroke\n"; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
$r; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
sub _resize |
396
|
|
|
|
|
|
|
{ |
397
|
|
|
|
|
|
|
my $r = shift; |
398
|
|
|
|
|
|
|
my $image = $r->{image}; |
399
|
|
|
|
|
|
|
my $size = $r->{size}; |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
if( $size && $image->width!=$size ) |
402
|
|
|
|
|
|
|
{ |
403
|
|
|
|
|
|
|
my $orig = $image; |
404
|
|
|
|
|
|
|
my $image = GD::Image->new($size, $size, 1); |
405
|
|
|
|
|
|
|
$image->copyResampled($orig, 0, 0, 0, 0, $size, $size, $orig->width, $orig->height); |
406
|
|
|
|
|
|
|
$image->transparent($r->{back_color}); |
407
|
|
|
|
|
|
|
if( $DEBUG ) |
408
|
|
|
|
|
|
|
{ |
409
|
|
|
|
|
|
|
my $ox = $orig->width; |
410
|
|
|
|
|
|
|
my $r = sprintf('%.1f', $ox/$size); |
411
|
|
|
|
|
|
|
print "resize: ($ox, $ox) => ($size, $size) [1/$r]\n"; |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
$r->{image} = $image; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
$r; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
420
|
|
|
|
|
|
|
# End of Module. |
421
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
422
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
423
|
|
|
|
|
|
|
# End of File. |
424
|
|
|
|
|
|
|
# ----------------------------------------------------------------------------- |
425
|
|
|
|
|
|
|
__END__ |