| 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__ |