line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyright 2010, 2011, 2012, 2013, 2017 Kevin Ryde |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# This file is part of Image-Base-X11-Protocol. |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# Image-Base-X11-Protocol is free software; you can redistribute it and/or |
6
|
|
|
|
|
|
|
# modify it under the terms of the GNU General Public License as published |
7
|
|
|
|
|
|
|
# by the Free Software Foundation; either version 3, or (at your option) any |
8
|
|
|
|
|
|
|
# later version. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# Image-Base-X11-Protocol is distributed in the hope that it will be useful, |
11
|
|
|
|
|
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
12
|
|
|
|
|
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General |
13
|
|
|
|
|
|
|
# Public License for more details. |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# You should have received a copy of the GNU General Public License along |
16
|
|
|
|
|
|
|
# with Image-Base-X11-Protocol. If not, see . |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# /usr/share/doc/x11proto-core-dev/x11protocol.txt.gz |
20
|
|
|
|
|
|
|
# |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
package Image::Base::X11::Protocol::Drawable; |
23
|
4
|
|
|
4
|
|
1914
|
use 5.004; |
|
4
|
|
|
|
|
21
|
|
24
|
4
|
|
|
4
|
|
27
|
use strict; |
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
98
|
|
25
|
4
|
|
|
4
|
|
32
|
use Carp; |
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
278
|
|
26
|
4
|
|
|
4
|
|
1891
|
use POSIX 'floor'; |
|
4
|
|
|
|
|
24220
|
|
|
4
|
|
|
|
|
27
|
|
27
|
4
|
|
|
4
|
|
6643
|
use X11::Protocol 0.56; # version 0.56 for robust_req() fix |
|
4
|
|
|
|
|
47249
|
|
|
4
|
|
|
|
|
261
|
|
28
|
4
|
|
|
4
|
|
2247
|
use X11::Protocol::Other 3; # v.3 for hexstr_to_rgb() |
|
4
|
|
|
|
|
3626
|
|
|
4
|
|
|
|
|
170
|
|
29
|
4
|
|
|
4
|
|
28
|
use vars '@ISA', '$VERSION'; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
166
|
|
30
|
|
|
|
|
|
|
|
31
|
4
|
|
|
4
|
|
1844
|
use Image::Base; |
|
4
|
|
|
|
|
5736
|
|
|
4
|
|
|
|
|
9119
|
|
32
|
|
|
|
|
|
|
@ISA = ('Image::Base'); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
$VERSION = 15; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# uncomment this to run the ### lines |
37
|
|
|
|
|
|
|
# use Smart::Comments '###'; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub new { |
40
|
0
|
|
|
0
|
1
|
0
|
my $class = shift; |
41
|
0
|
0
|
|
|
|
0
|
if (ref $class) { |
42
|
0
|
|
|
|
|
0
|
croak "Cannot clone base drawable"; |
43
|
|
|
|
|
|
|
} |
44
|
0
|
|
|
|
|
0
|
return bless { |
45
|
|
|
|
|
|
|
# these not documented as yet |
46
|
|
|
|
|
|
|
-colour_to_pixel => { }, |
47
|
|
|
|
|
|
|
-gc_colour => '', |
48
|
|
|
|
|
|
|
-gc_pixel => -1, |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
@_ }, $class; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# This not working yet. Good to CopyArea when screen,depth,colormap permit, |
54
|
|
|
|
|
|
|
# is it worth the trouble though? |
55
|
|
|
|
|
|
|
# |
56
|
|
|
|
|
|
|
# =item C<$new_image = $image-Enew_from_image ($class, key=Evalue,...)> |
57
|
|
|
|
|
|
|
# |
58
|
|
|
|
|
|
|
# Create and return a new image of type C<$class>. |
59
|
|
|
|
|
|
|
# |
60
|
|
|
|
|
|
|
# Target class C is recognised and done by |
61
|
|
|
|
|
|
|
# CopyArea of the C<$image> drawable into the new pixmap. Other classes are |
62
|
|
|
|
|
|
|
# left to the plain C C. |
63
|
|
|
|
|
|
|
# |
64
|
|
|
|
|
|
|
# sub new_from_image { |
65
|
|
|
|
|
|
|
# my $self = shift; |
66
|
|
|
|
|
|
|
# my $new_class = shift; |
67
|
|
|
|
|
|
|
# |
68
|
|
|
|
|
|
|
# if (! ref $new_class |
69
|
|
|
|
|
|
|
# && $new_class->isa('Image::Base::X11::Protocol::Pixmap')) { |
70
|
|
|
|
|
|
|
# my %param = @_; |
71
|
|
|
|
|
|
|
# my $X = $self->{'-X'}; |
72
|
|
|
|
|
|
|
# if ($param{'-X'} == $X) { |
73
|
|
|
|
|
|
|
# my ($depth, $width, $height, $colormap) |
74
|
|
|
|
|
|
|
# = $self->get('-screen','-depth','-width','-height'); |
75
|
|
|
|
|
|
|
# my ($new_screen, $new_depth) |
76
|
|
|
|
|
|
|
# = $new_class->_new_params_screen_and_depth(\%params); |
77
|
|
|
|
|
|
|
# if ($new_screen == $screen |
78
|
|
|
|
|
|
|
# && $new_depth == $depth |
79
|
|
|
|
|
|
|
# && $new_colormap == $colormap) { |
80
|
|
|
|
|
|
|
# |
81
|
|
|
|
|
|
|
# my $new_image = $new_class->new (%param); |
82
|
|
|
|
|
|
|
# |
83
|
|
|
|
|
|
|
# ### copy to new Pixmap |
84
|
|
|
|
|
|
|
# my ($width, $height) = $self->get('-width','-height'); |
85
|
|
|
|
|
|
|
# my ($new_width, $new_height) = $new_image->get('-width','-height'); |
86
|
|
|
|
|
|
|
# $X->CopyArea ($self->{'-drawable'}, # src |
87
|
|
|
|
|
|
|
# $new_image->{'-drawable'}, # dst |
88
|
|
|
|
|
|
|
# _gc_created($self), |
89
|
|
|
|
|
|
|
# 0,0, # src x,y |
90
|
|
|
|
|
|
|
# min ($width,$new_width), min ($height,$new_height) |
91
|
|
|
|
|
|
|
# 0,0); # dst x,y |
92
|
|
|
|
|
|
|
# return $new_image; |
93
|
|
|
|
|
|
|
# } |
94
|
|
|
|
|
|
|
# } |
95
|
|
|
|
|
|
|
# } |
96
|
|
|
|
|
|
|
# return $self->SUPER::new_from_image ($new_class, @_); |
97
|
|
|
|
|
|
|
# } |
98
|
|
|
|
|
|
|
# sub _gc_created { |
99
|
|
|
|
|
|
|
# my ($self) = @_; |
100
|
|
|
|
|
|
|
# return ($self->{'-gc_created'} ||= do { |
101
|
|
|
|
|
|
|
# my $gc = $self->{'-X'}->new_rsrc; |
102
|
|
|
|
|
|
|
# ### CreateGC: $gc |
103
|
|
|
|
|
|
|
# $self->{'-X'}->CreateGC ($gc, $self->{'-drawable'}); |
104
|
|
|
|
|
|
|
# $gc |
105
|
|
|
|
|
|
|
# }); |
106
|
|
|
|
|
|
|
# } |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub DESTROY { |
109
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
110
|
|
|
|
|
|
|
### X11-Protocol-Drawable DESTROY |
111
|
0
|
|
|
|
|
0
|
_free_gc_created ($self); |
112
|
0
|
|
|
|
|
0
|
shift->SUPER::DESTROY (@_); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
sub _free_gc_created { |
115
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
116
|
0
|
0
|
|
|
|
0
|
if (my $gc = delete $self->{'-gc_created'}) { |
117
|
|
|
|
|
|
|
### FreeGC: $gc |
118
|
0
|
|
|
|
|
0
|
$self->{'-X'}->FreeGC ($gc); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub get { |
123
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
124
|
0
|
|
|
|
|
0
|
local $self->{'_during_get'} = {}; |
125
|
0
|
|
|
|
|
0
|
return shift->SUPER::get(@_); |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
my %get_geometry = (-depth => sub{$_[1]->{'root_depth'}}, |
128
|
|
|
|
|
|
|
-root => sub{$_[1]->{'root'}}, |
129
|
|
|
|
|
|
|
-x => sub{0}, |
130
|
|
|
|
|
|
|
-y => sub{0}, |
131
|
|
|
|
|
|
|
-width => sub{$_[1]->{'width_in_pixels'}}, |
132
|
|
|
|
|
|
|
-height => sub{$_[1]->{'height_in_pixels'}}, |
133
|
|
|
|
|
|
|
-border_width => sub{0}, |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# and with extra crunching |
136
|
|
|
|
|
|
|
-screen => sub{$_[0]}); |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub _get { |
139
|
0
|
|
|
0
|
|
0
|
my ($self, $key) = @_; |
140
|
|
|
|
|
|
|
### X11-Protocol-Drawable _get(): $key |
141
|
|
|
|
|
|
|
|
142
|
0
|
0
|
0
|
|
|
0
|
if (! exists $self->{$key} |
143
|
|
|
|
|
|
|
&& defined (my $rsubr = $get_geometry{$key})) { |
144
|
0
|
|
|
|
|
0
|
my $X = $self->{'-X'}; |
145
|
0
|
|
|
|
|
0
|
my $drawable = $self->{'-drawable'}; |
146
|
|
|
|
|
|
|
|
147
|
0
|
0
|
|
|
|
0
|
if (defined (my $screen = X11::Protocol::Other::root_to_screen ($X, $drawable))) { |
148
|
|
|
|
|
|
|
# $drawable is a root window, grab info out of $X |
149
|
0
|
|
|
|
|
0
|
&$rsubr ($screen, $X->{'screens'}->[$screen]); |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
0
|
|
|
|
|
0
|
my %geom = $X->GetGeometry ($self->{'-drawable'}); |
153
|
0
|
|
|
|
|
0
|
foreach my $gkey (keys %get_geometry) { |
154
|
0
|
0
|
|
|
|
0
|
if (! defined $self->{$gkey}) { |
155
|
0
|
|
|
|
|
0
|
$self->{$gkey} = $geom{substr($gkey,1)}; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
} |
158
|
0
|
0
|
|
|
|
0
|
if (! defined $self->{'-screen'}) { |
159
|
0
|
|
|
|
|
0
|
$self->{'-screen'} = X11::Protocol::Other::root_to_screen ($X, $geom{'root'}); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
0
|
|
|
|
|
0
|
return $self->SUPER::_get($key); |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
sub set { |
166
|
0
|
|
|
0
|
1
|
0
|
my ($self, %params) = @_; |
167
|
|
|
|
|
|
|
|
168
|
0
|
0
|
|
|
|
0
|
if (exists $params{'-pixmap'}) { |
169
|
0
|
|
|
|
|
0
|
$params{'-drawable'} = delete $params{'-pixmap'}; |
170
|
|
|
|
|
|
|
} |
171
|
0
|
0
|
|
|
|
0
|
if (exists $params{'-window'}) { |
172
|
0
|
|
|
|
|
0
|
$params{'-drawable'} = delete $params{'-window'}; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
0
|
0
|
|
|
|
0
|
if (exists $params{'-drawable'}) { |
176
|
0
|
|
|
|
|
0
|
_free_gc_created ($self); |
177
|
|
|
|
|
|
|
# purge these cached values, %params can supply new ones if desired |
178
|
0
|
|
|
|
|
0
|
delete @{$self}{keys %get_geometry}; # hash slice |
|
0
|
|
|
|
|
0
|
|
179
|
|
|
|
|
|
|
} |
180
|
0
|
0
|
|
|
|
0
|
if (exists $params{'-colormap'}) { |
181
|
0
|
|
|
|
|
0
|
%{$self->{'-colour_to_pixel'}} = (); # clear |
|
0
|
|
|
|
|
0
|
|
182
|
|
|
|
|
|
|
} |
183
|
0
|
0
|
|
|
|
0
|
if (exists $params{'-gc'}) { |
184
|
|
|
|
|
|
|
# no longer know what colour is in the gc, or not unless included in |
185
|
|
|
|
|
|
|
# %params |
186
|
0
|
|
|
|
|
0
|
$self->{'-gc_colour'} = ''; |
187
|
0
|
|
|
|
|
0
|
$self->{'-gc_pixel'} = -1; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
0
|
|
|
|
|
0
|
%$self = (%$self, %params); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
194
|
|
|
|
|
|
|
# drawing |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub xy { |
197
|
0
|
|
|
0
|
1
|
0
|
my ($self, $x, $y, $colour) = @_; |
198
|
|
|
|
|
|
|
### xy |
199
|
|
|
|
|
|
|
### $x |
200
|
|
|
|
|
|
|
### $y |
201
|
|
|
|
|
|
|
### $colour |
202
|
|
|
|
|
|
|
|
203
|
0
|
0
|
0
|
|
|
0
|
if ($x < 0 || $y < 0 || $x > 0x7FFF || $y > 0x7FFF) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
204
|
|
|
|
|
|
|
### outside max drawable, don't overflow INT16 ... |
205
|
0
|
|
|
|
|
0
|
return undef; # fetch or store |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
0
|
|
|
|
|
0
|
my $X = $self->{'-X'}; |
209
|
0
|
|
|
|
|
0
|
my $drawable = $self->{'-drawable'}; |
210
|
0
|
0
|
|
|
|
0
|
if (@_ == 4) { |
211
|
|
|
|
|
|
|
# store colour |
212
|
0
|
|
|
|
|
0
|
$X->PolyPoint ($drawable, _gc_colour($self,$colour), 'Origin', $x,$y); |
213
|
0
|
|
|
|
|
0
|
return; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
# fetch colour |
217
|
0
|
|
|
|
|
0
|
my @reply = $X->robust_req ('GetImage', $drawable, |
218
|
|
|
|
|
|
|
$x, $y, 1, 1, 0xFFFFFFFF, 'ZPixmap'); |
219
|
0
|
0
|
|
|
|
0
|
if (! ref $reply[0]) { |
220
|
0
|
0
|
|
|
|
0
|
if ($reply[0] eq 'Match') { |
221
|
|
|
|
|
|
|
### Match error reading offscreen |
222
|
0
|
|
|
|
|
0
|
return ''; |
223
|
|
|
|
|
|
|
} |
224
|
0
|
|
|
|
|
0
|
croak "Error reading pixel: ",join(' ',@reply); |
225
|
|
|
|
|
|
|
} |
226
|
0
|
|
|
|
|
0
|
my ($depth, $visual, $bytes) = @{$reply[0]}; |
|
0
|
|
|
|
|
0
|
|
227
|
0
|
0
|
|
|
|
0
|
if (! defined $self->{'-depth'}) { |
228
|
0
|
|
|
|
|
0
|
$self->{'-depth'} = $depth; |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
### $depth |
231
|
|
|
|
|
|
|
### $visual |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# X11::Protocol 0.56 shows named 'LeastSiginificant' in the pod, but the |
234
|
|
|
|
|
|
|
# code gives raw number '0'. Let num() crunch either. |
235
|
0
|
0
|
|
|
|
0
|
if ($X->num('Significance',$X->{'image_byte_order'}) == 0) { |
236
|
|
|
|
|
|
|
#### reverse for LSB image format |
237
|
0
|
|
|
|
|
0
|
$bytes = reverse $bytes; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
### $bytes |
240
|
0
|
|
|
|
|
0
|
my $pixel = unpack ('N', $bytes); |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# not sure what the protocol says about extra bits or bytes in the reply |
243
|
|
|
|
|
|
|
# data, have seen a freebsd server giving garbage, so mask the extras |
244
|
0
|
|
|
|
|
0
|
$pixel &= (1 << $depth) - 1; |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
### pixel: sprintf '%X', $pixel |
247
|
|
|
|
|
|
|
### pixel_to_colour: $self->pixel_to_colour($pixel) |
248
|
0
|
0
|
|
|
|
0
|
if (defined ($colour = $self->pixel_to_colour($pixel))) { |
249
|
0
|
|
|
|
|
0
|
return $colour; |
250
|
|
|
|
|
|
|
} |
251
|
0
|
0
|
|
|
|
0
|
if (my $colormap = $self->{'-colormap'}) { |
252
|
|
|
|
|
|
|
#### query: $X->QueryColors ($self->get('-colormap'), $pixel) |
253
|
0
|
|
|
|
|
0
|
my ($rgb) = $X->QueryColors ($self->get('-colormap'), $pixel); |
254
|
|
|
|
|
|
|
#### $rgb |
255
|
0
|
|
|
|
|
0
|
return sprintf('#%04X%04X%04X', @$rgb); |
256
|
|
|
|
|
|
|
} |
257
|
0
|
|
|
|
|
0
|
return $pixel; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
sub Image_Base_Other_xy_points { |
260
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
261
|
0
|
|
|
|
|
0
|
my $colour = shift; |
262
|
0
|
|
|
|
|
0
|
my $gc = _gc_colour($self,$colour); |
263
|
0
|
|
|
|
|
0
|
my $X = $self->{'-X'}; |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# PolyPoint is 3xCARD32 for drawable,gc,mode then room for maxlen-3 words |
266
|
|
|
|
|
|
|
# of X,Y values. X and Y are INT16 each, hence room for (maxlen-3)*2 |
267
|
|
|
|
|
|
|
# individual points. Is there any merit sending smaller chunks though? |
268
|
|
|
|
|
|
|
# 250kbytes is a typical server limit. |
269
|
|
|
|
|
|
|
# |
270
|
0
|
|
|
|
|
0
|
my $maxpoints = 2*($X->{'maximum_request_length'} - 3); |
271
|
|
|
|
|
|
|
### $maxpoints |
272
|
|
|
|
|
|
|
|
273
|
0
|
|
|
|
|
0
|
my @points; |
274
|
0
|
|
|
|
|
0
|
while (@_) { |
275
|
0
|
0
|
|
|
|
0
|
if (@points >= $maxpoints) { |
276
|
0
|
|
|
|
|
0
|
$X->PolyPoint ($self->{'-drawable'}, $gc, 'Origin', @points); |
277
|
0
|
|
|
|
|
0
|
$#points = -1; # empty |
278
|
|
|
|
|
|
|
} |
279
|
0
|
|
|
|
|
0
|
my $x = shift; |
280
|
0
|
|
|
|
|
0
|
my $y = shift; |
281
|
0
|
0
|
0
|
|
|
0
|
if ($x >= 0 && $y >= 0 && $x <= 0x7FFF && $y <= 0x7FFF) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
282
|
|
|
|
|
|
|
# within max drawable ... |
283
|
0
|
|
|
|
|
0
|
push @points, $x,$y; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
} |
286
|
0
|
0
|
|
|
|
0
|
if (@points) { |
287
|
0
|
|
|
|
|
0
|
$X->PolyPoint ($self->{'-drawable'}, $gc, 'Origin', @points); |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
sub line { |
292
|
0
|
|
|
0
|
1
|
0
|
my ($self, $x1, $y1, $x2, $y2, $colour) = @_ ; |
293
|
|
|
|
|
|
|
|
294
|
0
|
0
|
|
|
|
0
|
($x1,$y1, $x2,$y2) = _line_clip ($x1,$y1, $x2,$y2) |
295
|
|
|
|
|
|
|
or return; # nothing left after clipping |
296
|
|
|
|
|
|
|
|
297
|
0
|
|
|
|
|
0
|
$self->{'-X'}->PolySegment ($self->{'-drawable'}, _gc_colour($self,$colour), |
298
|
|
|
|
|
|
|
$x1,$y1, $x2,$y2); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
sub rectangle { |
302
|
0
|
|
|
0
|
1
|
0
|
my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_; |
303
|
|
|
|
|
|
|
### X11-Protocol-Drawable rectangle |
304
|
|
|
|
|
|
|
|
305
|
0
|
0
|
0
|
|
|
0
|
unless ($x2 >= 0 && $y2 >= 0 && $x1 <= 0x7FFF && $y1 <= 0x7FFF) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
306
|
|
|
|
|
|
|
### entirely outside max possible drawable ... |
307
|
0
|
|
|
|
|
0
|
return; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# Don't underflow INT16 -0x8000 x,y in request. But retain negativeness so |
311
|
|
|
|
|
|
|
# as not to bring top and left sides of an unfilled rect into view. |
312
|
0
|
0
|
|
|
|
0
|
if ($x1 < -1) { $x1 = -1; } |
|
0
|
|
|
|
|
0
|
|
313
|
0
|
0
|
|
|
|
0
|
if ($y1 < -1) { $y1 = -1; } |
|
0
|
|
|
|
|
0
|
|
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# Don't overflow CARD16 width,height in request. Together with x1,y1 >= |
316
|
|
|
|
|
|
|
# -1 this makes w,h <= 0x8002. It doesn't bring the unfilled right and |
317
|
|
|
|
|
|
|
# bottom sides into view even if the drawable is 0 to 0x7FFF. |
318
|
0
|
0
|
|
|
|
0
|
if ($x2 > 0x8000) { $x2 = 0x8000; } |
|
0
|
|
|
|
|
0
|
|
319
|
0
|
0
|
|
|
|
0
|
if ($y2 > 0x8000) { $y2 = 0x8000; } |
|
0
|
|
|
|
|
0
|
|
320
|
|
|
|
|
|
|
|
321
|
0
|
0
|
0
|
|
|
0
|
if ($x1 == $x2 || $y1 == $y2) { |
322
|
|
|
|
|
|
|
# single pixel wide or high, must treat as filled since PolyRectangle() |
323
|
|
|
|
|
|
|
# draws nothing if passed width==0 or height==0 |
324
|
0
|
|
|
|
|
0
|
$fill = 1; |
325
|
|
|
|
|
|
|
} else { |
326
|
0
|
|
|
|
|
0
|
$fill = !!$fill; # 0 or 1 for arithmetic |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
### coords: [ $x1, $y1, $x2-$x1, $y2-$y1 ] |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
$self->{'-X'}->request ($fill ? 'PolyFillRectangle' : 'PolyRectangle', |
331
|
0
|
0
|
|
|
|
0
|
$self->{'-drawable'}, |
332
|
|
|
|
|
|
|
_gc_colour($self,$colour), |
333
|
|
|
|
|
|
|
[ $x1, $y1, $x2-$x1+$fill, $y2-$y1+$fill ]); |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
sub Image_Base_Other_rectangles { |
337
|
|
|
|
|
|
|
### X11-Protocol-Drawable rectangles() |
338
|
|
|
|
|
|
|
### count: scalar(@_) |
339
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
340
|
0
|
|
|
|
|
0
|
my $colour = shift; |
341
|
0
|
|
|
|
|
0
|
my $fill = !! shift; # 0 or 1 |
342
|
|
|
|
|
|
|
|
343
|
0
|
0
|
|
|
|
0
|
my $method = ($fill ? 'PolyFillRectangle' : 'PolyRectangle'); |
344
|
|
|
|
|
|
|
### $method |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
### coords count: scalar(@_) |
347
|
|
|
|
|
|
|
### coords: @_ |
348
|
|
|
|
|
|
|
|
349
|
0
|
|
|
|
|
0
|
my @rects; |
350
|
|
|
|
|
|
|
my @filled; |
351
|
0
|
|
|
|
|
0
|
while (my ($x1,$y1, $x2,$y2) = splice @_,0,4) { |
352
|
|
|
|
|
|
|
### quad: ($x1,$y1, $x2,$y2) |
353
|
|
|
|
|
|
|
|
354
|
0
|
0
|
0
|
|
|
0
|
unless ($x2 >= 0 && $y2 >= 0 && $x1 <= 0x7FFF && $y1 <= 0x7FFF) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
355
|
|
|
|
|
|
|
### entirely outside max possible drawable ... |
356
|
0
|
|
|
|
|
0
|
next; |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
# don't underflow INT16 -0x8000 x,y in request |
359
|
|
|
|
|
|
|
# but retain negativeness so as not to bring unfilled sides into view |
360
|
0
|
0
|
|
|
|
0
|
if ($x1 < -1) { $x1 = -1; } |
|
0
|
|
|
|
|
0
|
|
361
|
0
|
0
|
|
|
|
0
|
if ($y1 < -1) { $y1 = -1; } |
|
0
|
|
|
|
|
0
|
|
362
|
|
|
|
|
|
|
# don't overflow CARD16 width,height in request |
363
|
0
|
0
|
|
|
|
0
|
if ($x2 > 0x8000) { $x2 = 0x8000; } |
|
0
|
|
|
|
|
0
|
|
364
|
0
|
0
|
|
|
|
0
|
if ($y2 > 0x8000) { $y2 = 0x8000; } |
|
0
|
|
|
|
|
0
|
|
365
|
|
|
|
|
|
|
|
366
|
0
|
0
|
0
|
|
|
0
|
if (! $fill && ($x1 == $x2 || $y1 == $y2)) { |
|
|
|
0
|
|
|
|
|
367
|
|
|
|
|
|
|
# single pixel wide or high |
368
|
0
|
|
|
|
|
0
|
push @filled, [ $x1, $y1, $x2-$x1+1, $y2-$y1+1 ]; |
369
|
|
|
|
|
|
|
} else { |
370
|
0
|
|
|
|
|
0
|
push @rects, [ $x1, $y1, $x2-$x1+$fill, $y2-$y1+$fill ]; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
### @rects |
374
|
|
|
|
|
|
|
|
375
|
0
|
|
|
|
|
0
|
my $X = $self->{'-X'}; |
376
|
0
|
|
|
|
|
0
|
my $gc = _gc_colour($self,$colour); |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
# PolyRectangle is 3xCARD32 header,drawable,gc then room for maxlen-3 |
379
|
|
|
|
|
|
|
# words of X,Y,WIDTH,HEIGHT values. X,Y are INT16 and WIDTH,HEIGHT are |
380
|
|
|
|
|
|
|
# CARD16 each, hence room for floor((maxlen-3)/2) rectangles. Is there |
381
|
|
|
|
|
|
|
# any value sending somewhat smaller chunks though? 250kbytes is a |
382
|
|
|
|
|
|
|
# typical server limit. Xlib ZRCTSPERBATCH is just 256 thin line rects, |
383
|
|
|
|
|
|
|
# or WRCTSPERBATCH 10 wides. |
384
|
|
|
|
|
|
|
# |
385
|
0
|
|
|
|
|
0
|
my $maxrects = int (($X->{'maximum_request_length'} - 3) / 2); |
386
|
|
|
|
|
|
|
### $maxrects |
387
|
|
|
|
|
|
|
|
388
|
0
|
|
|
|
|
0
|
foreach my $aref (\@rects, \@filled) { |
389
|
0
|
0
|
|
|
|
0
|
if (@$aref) { |
390
|
0
|
|
|
|
|
0
|
my $drawable = $self->{'-drawable'}; |
391
|
0
|
|
|
|
|
0
|
while (@$aref > $maxrects) { |
392
|
|
|
|
|
|
|
### splice down from: scalar(@$aref) |
393
|
0
|
|
|
|
|
0
|
$X->$method ($drawable, $gc, splice @$aref, 0,$maxrects); |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
### final: $method, @$aref |
396
|
0
|
|
|
|
|
0
|
$X->$method ($drawable, $gc, @$aref); |
397
|
|
|
|
|
|
|
} |
398
|
0
|
|
|
|
|
0
|
$method = 'PolyFillRectangle'; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# The Arc requests take the bounding region at |
403
|
|
|
|
|
|
|
# left x, y+(h/2) |
404
|
|
|
|
|
|
|
# right x+w, y+(h/2) |
405
|
|
|
|
|
|
|
# top x+(w/2), y |
406
|
|
|
|
|
|
|
# bottom x+(w/2), y+h |
407
|
|
|
|
|
|
|
# with w=x2-x1, h=y2-y1. |
408
|
|
|
|
|
|
|
# |
409
|
|
|
|
|
|
|
# For PolyArc a 1-wide line makes each of those pixels drawn, but a |
410
|
|
|
|
|
|
|
# PolyFillArc is only the inside, not the extra 0.5 around the outside, |
411
|
|
|
|
|
|
|
# which means the bottom and right endmost pixels not drawn, and others a |
412
|
|
|
|
|
|
|
# bit smaller than PolyArc. |
413
|
|
|
|
|
|
|
# |
414
|
|
|
|
|
|
|
# For now try a PolyArc on top of the PolyFillArc to get the extra 0.5 |
415
|
|
|
|
|
|
|
# around the outside. Can it be done better? Prima has this, as long as |
416
|
|
|
|
|
|
|
# the drawing mode isn't xor etc where duplicated pixels are bad. |
417
|
|
|
|
|
|
|
# |
418
|
|
|
|
|
|
|
# One possibility would be to set line width lw=min(w/2,h/2) rounded up to |
419
|
|
|
|
|
|
|
# next odd integer, and shrink the bounding box by (lw-1)/2, so a PolyLine |
420
|
|
|
|
|
|
|
# centred there goes out to the very edges of the x1,y1,x2,y2 box, not just |
421
|
|
|
|
|
|
|
# the centres of those pixels, and being w/2 or h/2 will extend in to cover |
422
|
|
|
|
|
|
|
# the centre. The disadvantage would be changing the line width for each |
423
|
|
|
|
|
|
|
# draw, or keep another gc, and that might take away the option for the user |
424
|
|
|
|
|
|
|
# to set in a '-gc' option to choose between zero-width fast lines and |
425
|
|
|
|
|
|
|
# 1-width exact lines. An advantage though would be a single draw operation |
426
|
|
|
|
|
|
|
# meaning an "xor" mode in the gc would cover the right pixels. There's |
427
|
|
|
|
|
|
|
# something in the PolyArc spec about the bounding box being implementation |
428
|
|
|
|
|
|
|
# dependent if width!=height, so maybe this wouldn't work always. |
429
|
|
|
|
|
|
|
# |
430
|
|
|
|
|
|
|
# The same bounding box centred on the pixels happens in rectangle(), but |
431
|
|
|
|
|
|
|
# can be handled there by +1 on the width and height. A +1 doesn't make a |
432
|
|
|
|
|
|
|
# filled ellipse come out the same as an outlined ellipse though. |
433
|
|
|
|
|
|
|
# |
434
|
|
|
|
|
|
|
# same in Window.pm for shape stuff |
435
|
|
|
|
|
|
|
sub ellipse { |
436
|
0
|
|
|
0
|
1
|
0
|
my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_; |
437
|
|
|
|
|
|
|
### Drawable ellipse(): $x1, $y1, $x2, $y2, $colour |
438
|
|
|
|
|
|
|
|
439
|
0
|
|
|
|
|
0
|
my $w = $x2 - $x1; |
440
|
0
|
|
|
|
|
0
|
my $h = $y2 - $y1; |
441
|
0
|
0
|
0
|
|
|
0
|
if ($w <= 1 || $h <= 1) { |
442
|
|
|
|
|
|
|
# 1 or 2 pixels wide or high |
443
|
0
|
|
|
|
|
0
|
shift->rectangle(@_); |
444
|
0
|
|
|
|
|
0
|
return; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
0
|
0
|
0
|
|
|
0
|
unless ($x2 >= 0 && $y2 >= 0 && $x1 <= 0x7FFF && $y1 <= 0x7FFF) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
448
|
|
|
|
|
|
|
### entirely outside max possible drawable ... |
449
|
0
|
|
|
|
|
0
|
return; |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
0
|
0
|
0
|
|
|
0
|
if ($x1 < -0x8000 || $x2 > 0x7FFF || $y1 < -0x8000 || $y2 > 0x7FFF) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
453
|
|
|
|
|
|
|
### coordinates would overflow, use superclass ... |
454
|
0
|
|
|
|
|
0
|
shift->SUPER::ellipse(@_); |
455
|
0
|
|
|
|
|
0
|
return; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
### PolyArc: $x1, $y1, $x2-$x1+1, $y2-$y1+1, 0, 360*64 |
459
|
0
|
|
|
|
|
0
|
my @args = ($self->{'-drawable'}, _gc_colour($self,$colour), |
460
|
|
|
|
|
|
|
[ $x1, $y1, $w, $h, 0, 360*64 ]); |
461
|
0
|
|
|
|
|
0
|
my $X = $self->{'-X'}; |
462
|
0
|
0
|
|
|
|
0
|
if ($fill) { |
463
|
0
|
|
|
|
|
0
|
$X->PolyFillArc (@args); |
464
|
|
|
|
|
|
|
} |
465
|
0
|
|
|
|
|
0
|
$X->PolyArc (@args); |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
sub diamond { |
469
|
0
|
|
|
0
|
1
|
0
|
my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_; |
470
|
|
|
|
|
|
|
### Drawable diamond(): $x1, $y1, $x2, $y2, $colour |
471
|
|
|
|
|
|
|
|
472
|
0
|
0
|
0
|
|
|
0
|
if ($x1==$x2 && $y1==$y2) { |
473
|
|
|
|
|
|
|
# 1x1 polygon draws nothing, do it as a point instead |
474
|
0
|
|
|
|
|
0
|
$self->xy($x1,$y1, $colour); |
475
|
0
|
|
|
|
|
0
|
return; |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
_diamond_drawable ($self->{'-X'}, |
479
|
0
|
|
|
|
|
0
|
$self->{'-drawable'}, |
480
|
|
|
|
|
|
|
_gc_colour($self,$colour), |
481
|
|
|
|
|
|
|
$x1,$y1, $x2,$y2, $fill); |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# shared by Image::Base::X11::Protocol::Window::diamond() |
485
|
|
|
|
|
|
|
sub _diamond_drawable { |
486
|
0
|
|
|
0
|
|
0
|
my ($X, $drawable, $gc, $x1, $y1, $x2, $y2, $fill) = @_; |
487
|
|
|
|
|
|
|
### _diamond_drawable() ... |
488
|
|
|
|
|
|
|
|
489
|
0
|
|
|
|
|
0
|
my $xh = int( ($x2 - $x1)/2 ); |
490
|
0
|
|
|
|
|
0
|
my $yh = int( ($y2 - $y1)/2 ); |
491
|
0
|
|
|
|
|
0
|
my $xmid_floor = $x1 + $xh; |
492
|
0
|
|
|
|
|
0
|
my $xmid_ceil = $x2 - $xh; |
493
|
0
|
|
|
|
|
0
|
my $ymid_floor = $y1 + $yh; |
494
|
0
|
|
|
|
|
0
|
my $ymid_ceil = $y2 - $yh; |
495
|
|
|
|
|
|
|
|
496
|
0
|
0
|
|
|
|
0
|
if ($fill) { |
497
|
|
|
|
|
|
|
# 1-0 |
498
|
|
|
|
|
|
|
# / |
499
|
|
|
|
|
|
|
# 2 7 |
500
|
|
|
|
|
|
|
# 3 6 |
501
|
|
|
|
|
|
|
# \ / |
502
|
|
|
|
|
|
|
# 4-5 |
503
|
0
|
0
|
|
|
|
0
|
my @xy =(# top |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
504
|
|
|
|
|
|
|
($xmid_floor == $xmid_ceil ? () : ($xmid_ceil, $y1)), |
505
|
|
|
|
|
|
|
$xmid_floor, $y1, |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
# left |
508
|
|
|
|
|
|
|
$x1, $ymid_floor, |
509
|
|
|
|
|
|
|
($ymid_floor == $ymid_ceil ? () : ($x1, $ymid_ceil)), |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# bottom |
512
|
|
|
|
|
|
|
$xmid_floor, $y2, |
513
|
|
|
|
|
|
|
($xmid_floor == $xmid_ceil ? () : ($xmid_ceil, $y2)), |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
# right |
516
|
|
|
|
|
|
|
($ymid_floor == $ymid_ceil ? () : ($x2, $ymid_ceil)), |
517
|
|
|
|
|
|
|
$x2, $ymid_floor, |
518
|
|
|
|
|
|
|
); |
519
|
0
|
|
|
|
|
0
|
_convex_poly_clip(\@xy); |
520
|
|
|
|
|
|
|
### clipped: @xy |
521
|
0
|
0
|
|
|
|
0
|
if (@xy) { |
522
|
0
|
|
|
|
|
0
|
push @xy, $xy[0],$xy[1]; # back to start |
523
|
0
|
|
|
|
|
0
|
$X->FillPoly ($drawable, $gc, 'Convex', 'Origin', @xy); |
524
|
0
|
|
|
|
|
0
|
$X->PolyLine ($drawable, $gc, 'Origin', @xy); |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
} else { |
528
|
|
|
|
|
|
|
# unfilled |
529
|
0
|
|
|
|
|
0
|
$X->PolySegment ($drawable, $gc, |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
# NW A . |
532
|
|
|
|
|
|
|
# / \ |
533
|
|
|
|
|
|
|
# B . |
534
|
|
|
|
|
|
|
_line_clip ($xmid_floor, $y1, $x1, $ymid_floor), |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
# SW B . |
537
|
|
|
|
|
|
|
# \ / |
538
|
|
|
|
|
|
|
# A . |
539
|
|
|
|
|
|
|
_line_clip ($xmid_floor, $y2, $x1, $ymid_ceil), |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
# SE . B |
542
|
|
|
|
|
|
|
# \ / |
543
|
|
|
|
|
|
|
# . A |
544
|
|
|
|
|
|
|
_line_clip ($xmid_ceil, $y2, $x2, $ymid_ceil), |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
# NE . A |
547
|
|
|
|
|
|
|
# / \ |
548
|
|
|
|
|
|
|
# . B |
549
|
|
|
|
|
|
|
_line_clip ($xmid_ceil, $y1, $x2, $ymid_floor)); |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
# not yet a documented feature ... |
556
|
|
|
|
|
|
|
sub pixel_to_colour { |
557
|
0
|
|
|
0
|
0
|
0
|
my ($self,$pixel) = @_; |
558
|
0
|
|
0
|
|
|
0
|
my $hash = ($self->{'-pixel_to_colour'} ||= do { |
559
|
|
|
|
|
|
|
### colour_to_pixel hash: $self->{'-colour_to_pixel'} |
560
|
0
|
|
|
|
|
0
|
({ reverse %{$self->{'-colour_to_pixel'}} }) # force anon hash |
|
0
|
|
|
|
|
0
|
|
561
|
|
|
|
|
|
|
}); |
562
|
0
|
|
|
|
|
0
|
return $hash->{$pixel}; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# return a gc XID which is set to draw in $colour |
566
|
|
|
|
|
|
|
sub _gc_colour { |
567
|
0
|
|
|
0
|
|
0
|
my ($self, $colour) = @_; |
568
|
0
|
0
|
|
|
|
0
|
if ($colour eq 'None') { |
569
|
0
|
|
|
|
|
0
|
$colour = 'black'; |
570
|
|
|
|
|
|
|
} |
571
|
0
|
|
0
|
|
|
0
|
my $gc = $self->{'-gc'} || $self->{'-gc_created'}; |
572
|
0
|
0
|
|
|
|
0
|
if ($colour ne $self->{'-gc_colour'}) { |
573
|
|
|
|
|
|
|
### X11-Protocol-Drawable -gc_colour() change: $colour |
574
|
0
|
|
|
|
|
0
|
my $pixel = $self->colour_to_pixel ($colour); |
575
|
0
|
|
|
|
|
0
|
$self->{'-gc_colour'} = $colour; |
576
|
|
|
|
|
|
|
|
577
|
0
|
0
|
|
|
|
0
|
if ($pixel != $self->{'-gc_pixel'}) { |
578
|
0
|
|
|
|
|
0
|
$self->{'-gc_pixel'} = $pixel; |
579
|
0
|
|
|
|
|
0
|
my $X = $self->{'-X'}; |
580
|
0
|
0
|
|
|
|
0
|
if ($gc) { |
581
|
|
|
|
|
|
|
### ChangeGC to pixel: $pixel |
582
|
0
|
|
|
|
|
0
|
$X->ChangeGC ($gc, foreground => $pixel); |
583
|
|
|
|
|
|
|
} else { |
584
|
0
|
|
|
|
|
0
|
$gc = $self->{'-gc_created'} = $X->new_rsrc; |
585
|
|
|
|
|
|
|
### CreateGC with pixel ... |
586
|
|
|
|
|
|
|
### $gc |
587
|
|
|
|
|
|
|
### $pixel |
588
|
0
|
|
|
|
|
0
|
$X->CreateGC ($gc, $self->{'-drawable'}, foreground => $pixel); |
589
|
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
} |
592
|
0
|
|
|
|
|
0
|
return $gc; |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
# return an allocated pixel number |
596
|
|
|
|
|
|
|
# not yet a documented feature ... |
597
|
|
|
|
|
|
|
sub colour_to_pixel { |
598
|
0
|
|
|
0
|
0
|
0
|
my ($self, $colour) = @_; |
599
|
|
|
|
|
|
|
### X11-Protocol-Drawable _colour_to_pixel(): $colour |
600
|
0
|
0
|
|
|
|
0
|
if ($colour =~ /^^\d+$/) { |
601
|
0
|
|
|
|
|
0
|
return $colour; # numeric pixel value |
602
|
|
|
|
|
|
|
} |
603
|
0
|
0
|
|
|
|
0
|
if ($colour eq 'set') { |
604
|
|
|
|
|
|
|
# ENHANCE-ME: maybe all bits set if depth > 1 |
605
|
0
|
|
|
|
|
0
|
return 1; |
606
|
|
|
|
|
|
|
} |
607
|
0
|
0
|
|
|
|
0
|
if ($colour eq 'clear') { |
608
|
0
|
|
|
|
|
0
|
return 0; |
609
|
|
|
|
|
|
|
} |
610
|
0
|
0
|
|
|
|
0
|
if (defined (my $pixel = $self->{'-colour_to_pixel'}->{$colour})) { |
611
|
0
|
|
|
|
|
0
|
return $pixel; |
612
|
|
|
|
|
|
|
} |
613
|
0
|
|
|
|
|
0
|
$self->add_colours ($colour); |
614
|
0
|
|
|
|
|
0
|
return $self->{'-colour_to_pixel'}->{$colour}; |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
my %colour_to_screen_field |
618
|
|
|
|
|
|
|
= ('black' => 'black_pixel', |
619
|
|
|
|
|
|
|
'#000000' => 'black_pixel', |
620
|
|
|
|
|
|
|
'#000000000000' => 'black_pixel', |
621
|
|
|
|
|
|
|
'white' => 'white_pixel', |
622
|
|
|
|
|
|
|
'#FFFFFF' => 'white_pixel', |
623
|
|
|
|
|
|
|
'#FFFFFFFFFFFF' => 'white_pixel', |
624
|
|
|
|
|
|
|
'#ffffff' => 'white_pixel', |
625
|
|
|
|
|
|
|
'#ffffffffffff' => 'white_pixel', |
626
|
|
|
|
|
|
|
); |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
sub add_colours { |
629
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
630
|
|
|
|
|
|
|
### add_colours: @_ |
631
|
0
|
|
|
|
|
0
|
my $X = $self->{'-X'}; |
632
|
0
|
|
0
|
|
|
0
|
my $colormap = $self->get('-colormap') |
633
|
|
|
|
|
|
|
|| croak 'No -colormap to add colours to'; |
634
|
0
|
|
|
|
|
0
|
my $colour_to_pixel = $self->{'-colour_to_pixel'}; |
635
|
0
|
|
|
|
|
0
|
my $pixel_to_colour = $self->{'-pixel_to_colour'}; |
636
|
|
|
|
|
|
|
|
637
|
0
|
|
|
|
|
0
|
my @queued; |
638
|
|
|
|
|
|
|
my @failed_colours; |
639
|
|
|
|
|
|
|
|
640
|
0
|
|
|
|
|
0
|
my $old_error_handler = $X->{'error_handler'}; |
641
|
|
|
|
|
|
|
my $wait_queue = sub { |
642
|
0
|
|
|
0
|
|
0
|
my $elem = shift @queued; |
643
|
0
|
|
|
|
|
0
|
my $seq = $elem->{'seq'}; |
644
|
0
|
|
|
|
|
0
|
my $colour = $elem->{'colour'}; |
645
|
|
|
|
|
|
|
|
646
|
0
|
|
|
|
|
0
|
my $err; |
647
|
|
|
|
|
|
|
local $X->{'error_handler'} = sub { |
648
|
0
|
|
|
|
|
0
|
my ($X, $data) = @_; |
649
|
0
|
|
|
|
|
0
|
my ($type, $err_seq) = unpack("xCSLSCxxxxxxxxxxxxxxxxxxxxx", $data); |
650
|
0
|
0
|
|
|
|
0
|
if ($err_seq != $seq) { |
651
|
0
|
|
|
|
|
0
|
goto &$old_error_handler; |
652
|
|
|
|
|
|
|
} |
653
|
0
|
|
|
|
|
0
|
$err = 1; |
654
|
0
|
|
|
|
|
0
|
}; |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
### handle: $seq |
657
|
0
|
|
|
|
|
0
|
$X->handle_input_for ($seq); |
658
|
0
|
|
|
|
|
0
|
$X->delete_reply ($seq); |
659
|
0
|
0
|
|
|
|
0
|
if ($err) { |
660
|
0
|
|
|
|
|
0
|
push @failed_colours, $colour; |
661
|
0
|
|
|
|
|
0
|
return; |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
### reply: $X->unpack_reply($elem->{'request_type'}, $elem->{'reply'}) |
665
|
|
|
|
|
|
|
|
666
|
0
|
|
|
|
|
0
|
my ($pixel) = $X->unpack_reply ($elem->{'request_type'}, $elem->{'reply'}); |
667
|
0
|
|
|
|
|
0
|
$colour_to_pixel->{$colour} = $pixel; |
668
|
0
|
0
|
|
|
|
0
|
if ($pixel_to_colour) { |
669
|
0
|
|
|
|
|
0
|
$pixel_to_colour->{$pixel} = $colour; |
670
|
|
|
|
|
|
|
} |
671
|
0
|
|
|
|
|
0
|
}; |
672
|
|
|
|
|
|
|
|
673
|
0
|
|
|
|
|
0
|
while (@_) { |
674
|
0
|
|
|
|
|
0
|
my $colour = shift; |
675
|
0
|
0
|
|
|
|
0
|
next if defined $colour_to_pixel->{$colour}; # already known |
676
|
0
|
|
|
|
|
0
|
delete $self->{'-pixel_to_colour'}; |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
# black_pixel or white_pixel of a default colormap |
679
|
0
|
0
|
|
|
|
0
|
if (my $field = $colour_to_screen_field{$colour}) { # "black" or "white" |
680
|
0
|
0
|
|
|
|
0
|
if (my $screen_info = X11::Protocol::Other::default_colormap_to_screen_info($X,$colormap)) { |
681
|
0
|
|
|
|
|
0
|
my $pixel = $colour_to_pixel->{$colour} = $screen_info->{$field}; |
682
|
0
|
0
|
|
|
|
0
|
if ($pixel_to_colour) { |
683
|
0
|
|
|
|
|
0
|
$pixel_to_colour->{$pixel} = $colour; |
684
|
|
|
|
|
|
|
} |
685
|
0
|
|
|
|
|
0
|
next; |
686
|
|
|
|
|
|
|
} |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
|
689
|
0
|
|
|
|
|
0
|
my $elem = { colour => $colour }; |
690
|
0
|
|
|
|
|
0
|
my @req; |
691
|
|
|
|
|
|
|
# Crib: [:xdigit:] new in 5.6, so only 0-9A-F, and in any case as of |
692
|
|
|
|
|
|
|
# perl 5.12.4 [:xdigit:] matches some wide chars but hex() doesn't |
693
|
|
|
|
|
|
|
# accept them |
694
|
0
|
0
|
|
|
|
0
|
if (my @rgb = X11::Protocol::Other::hexstr_to_rgb($colour)) { |
695
|
0
|
|
|
|
|
0
|
@req = ('AllocColor', $colormap, map {hex} @rgb); |
|
0
|
|
|
|
|
0
|
|
696
|
|
|
|
|
|
|
} else { |
697
|
0
|
|
|
|
|
0
|
@req = ('AllocNamedColor', $colormap, $colour); |
698
|
|
|
|
|
|
|
} |
699
|
0
|
|
|
|
|
0
|
$elem->{'request_type'} = $req[0]; |
700
|
0
|
|
|
|
|
0
|
my $seq = $elem->{'seq'} = $X->send(@req); |
701
|
0
|
|
|
|
|
0
|
$X->add_reply ($seq, \$elem->{'reply'}); |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
### $elem |
704
|
0
|
|
|
|
|
0
|
push @queued, $elem; |
705
|
0
|
0
|
|
|
|
0
|
if (@queued > 256) { |
706
|
0
|
|
|
|
|
0
|
&$wait_queue(); |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
} |
709
|
0
|
|
|
|
|
0
|
while (@queued) { |
710
|
0
|
|
|
|
|
0
|
&$wait_queue(); |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
0
|
0
|
|
|
|
0
|
if (@failed_colours) { |
714
|
0
|
|
|
|
|
0
|
die "Unknown colour(s): ",join(', ', @failed_colours); |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
719
|
|
|
|
|
|
|
# clipping to signed 16-bit parameters |
720
|
|
|
|
|
|
|
|
721
|
4
|
|
|
4
|
|
34
|
use constant _LO => -0x8000; # -32768 |
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
307
|
|
722
|
4
|
|
|
4
|
|
33
|
use constant _HI => 0x7FFF; # +32767 |
|
4
|
|
|
|
|
21
|
|
|
4
|
|
|
|
|
2217
|
|
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
# $x1,$y1, $x2,$y2 are the endpoints of a line. |
725
|
|
|
|
|
|
|
# Return new endpoints which are clipped to within -0x8000 to +0x7FFF which is |
726
|
|
|
|
|
|
|
# signed 16-bits for X protocol. |
727
|
|
|
|
|
|
|
# If given line is entirely outside the signed 16-bit rectangle then return |
728
|
|
|
|
|
|
|
# an empty list. |
729
|
|
|
|
|
|
|
# |
730
|
|
|
|
|
|
|
sub _line_clip { |
731
|
0
|
|
|
0
|
|
0
|
my ($x1,$y1, $x2,$y2) = @_; |
732
|
|
|
|
|
|
|
### _line_clip_16bit(): "$x1,$y1, $x2,$y2" |
733
|
|
|
|
|
|
|
|
734
|
0
|
0
|
|
|
|
0
|
unless (_line_any_positive($x1,$y1, $x2,$y2)) { |
735
|
|
|
|
|
|
|
### nothing positive ... |
736
|
0
|
|
|
|
|
0
|
return; |
737
|
|
|
|
|
|
|
} |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
my ($x1new,$y1new) = _line_end_clip($x1,$y1, $x2,$y2) |
740
|
0
|
0
|
|
|
|
0
|
or do { |
741
|
|
|
|
|
|
|
### x1,y1 end nothing in range ... |
742
|
0
|
|
|
|
|
0
|
return; |
743
|
|
|
|
|
|
|
}; |
744
|
0
|
0
|
|
|
|
0
|
($x2,$y2) = _line_end_clip($x2,$y2, $x1,$y1) |
745
|
|
|
|
|
|
|
or return; |
746
|
0
|
|
|
|
|
0
|
return ($x1new,$y1new, $x2,$y2); |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
# $x1,$y1, $x2,$y2 are the endpoints of a line. |
750
|
|
|
|
|
|
|
# Return new values for the $x2,$y2 end which clips it to within |
751
|
|
|
|
|
|
|
# LO <= x2 <= HI |
752
|
|
|
|
|
|
|
# LO <= y2 <= HI |
753
|
|
|
|
|
|
|
# |
754
|
|
|
|
|
|
|
# If the line is entirely outside LO to HI then return an empty list. |
755
|
|
|
|
|
|
|
# If x2,y2 is already within LO to HI then return them unchanged. |
756
|
|
|
|
|
|
|
# |
757
|
|
|
|
|
|
|
# x1,y1 |
758
|
|
|
|
|
|
|
# / |
759
|
|
|
|
|
|
|
# +-------- if x2 outside |
760
|
|
|
|
|
|
|
# | / then |
761
|
|
|
|
|
|
|
# |/ move it to x2new=LO |
762
|
|
|
|
|
|
|
# x2new,y2new * and y2new=corresponding pos on line |
763
|
|
|
|
|
|
|
# /| |
764
|
|
|
|
|
|
|
# / | |
765
|
|
|
|
|
|
|
# x2,y2 +-------- |
766
|
|
|
|
|
|
|
# LO |
767
|
|
|
|
|
|
|
# |
768
|
|
|
|
|
|
|
# +--------- |
769
|
|
|
|
|
|
|
# | if y2 outside, |
770
|
|
|
|
|
|
|
# | x1,y1 including moved y2new outside |
771
|
|
|
|
|
|
|
# | / then |
772
|
|
|
|
|
|
|
# +--*----- move it to y2new=LO |
773
|
|
|
|
|
|
|
# /x2new, and x2new=corresponding pos on line |
774
|
|
|
|
|
|
|
# / y2new |
775
|
|
|
|
|
|
|
# first y2new * |
776
|
|
|
|
|
|
|
# / |
777
|
|
|
|
|
|
|
# / |
778
|
|
|
|
|
|
|
# x2,y2 |
779
|
|
|
|
|
|
|
# |
780
|
|
|
|
|
|
|
sub _line_end_clip { |
781
|
11
|
|
|
11
|
|
522
|
my ($x1,$y1, $x2,$y2) = @_; |
782
|
|
|
|
|
|
|
### _line_end_clip(): "$x1,$y1, $x2,$y2" |
783
|
|
|
|
|
|
|
|
784
|
11
|
|
|
|
|
19
|
my ($x2new, $y2new); |
785
|
11
|
100
|
100
|
|
|
44
|
if ($x2 < _LO || $x2 > _HI) { |
786
|
|
|
|
|
|
|
# x2 is outside LO to HI, clip to x2=LOorHI and y2 set to corresponding |
787
|
7
|
100
|
|
|
|
34
|
my $xlen = $x2 - $x1 |
788
|
|
|
|
|
|
|
or return; # xlen==0 means x1==x2 so entirely outside LO to HI |
789
|
5
|
100
|
|
|
|
11
|
$x2new = ($x2 < _LO ? _LO : _HI); |
790
|
5
|
|
|
|
|
20
|
$y2new = floor(($y2*($x2new-$x1) + $y1*($x2-$x2new)) / $xlen + 0.5); |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
### x clip: "to $x2new,$y2new frac ".($y2*($x2new-$x1) + $y1*($x2-$x2new))." / $xlen" |
793
|
|
|
|
|
|
|
} else { |
794
|
4
|
|
|
|
|
6
|
$x2new = $x2; |
795
|
4
|
|
|
|
|
8
|
$y2new = $y2; |
796
|
|
|
|
|
|
|
} |
797
|
|
|
|
|
|
|
|
798
|
9
|
100
|
100
|
|
|
34
|
if ($y2new < _LO || $y2new > _HI) { |
799
|
4
|
100
|
|
|
|
12
|
my $ylen = $y2 - $y1 |
800
|
|
|
|
|
|
|
or return; # ylen==0 means y1==y2 so entirely outside LO to HI |
801
|
2
|
100
|
|
|
|
6
|
$y2new = ($y2 < _LO ? _LO : _HI); |
802
|
2
|
|
|
|
|
9
|
$x2new = floor(($x2*($y2new-$y1) + $x1*($y2-$y2new)) / $ylen + 0.5); |
803
|
|
|
|
|
|
|
### y clip: "to $x2new,$y2new left ".($y2new-$y1)." right ".($y2-$y2new) |
804
|
2
|
50
|
33
|
|
|
10
|
if ($x2new < _LO || $x2new > _HI) { |
805
|
|
|
|
|
|
|
### x2new outside ... |
806
|
0
|
|
|
|
|
0
|
return; |
807
|
|
|
|
|
|
|
} |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
|
810
|
7
|
|
|
|
|
20
|
return ($x2new,$y2new); |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
# x2,y2 |
814
|
|
|
|
|
|
|
# / |
815
|
|
|
|
|
|
|
# /\ |
816
|
|
|
|
|
|
|
# / \ |
817
|
|
|
|
|
|
|
# / +--------- |
818
|
|
|
|
|
|
|
# x1,y1 | |
819
|
|
|
|
|
|
|
# | |
820
|
|
|
|
|
|
|
# |
821
|
|
|
|
|
|
|
# perp X= -1-pos, Y=-1 -pos*(x2-x1)/(y2-y1) |
822
|
|
|
|
|
|
|
# -pos = X+1 |
823
|
|
|
|
|
|
|
# Y = (X+1)*(x2-x1)/(y2-y1) - 1 |
824
|
|
|
|
|
|
|
# |
825
|
|
|
|
|
|
|
# intersect |
826
|
|
|
|
|
|
|
# (X+1)*(x2-x1)/(y2-y1) - 1 = (X-x1)/(x2-x1)*(y2-y1) + y1 |
827
|
|
|
|
|
|
|
# (X+1)*(x2-x1)/(y2-y1) = (X-x1)/(x2-x1)*(y2-y1) + (y1+1) |
828
|
|
|
|
|
|
|
# (X+1)*(x2-x1) = (X-x1)/(x2-x1)*(y2-y1)*(y2-y1) + (y1+1)*(y2-y1) |
829
|
|
|
|
|
|
|
# (X+1)*(x2-x1)*(x2-x1) = (X-x1)*(y2-y1)*(y2-y1) + (y1+1)*(y2-y1)*(x2-x1) |
830
|
|
|
|
|
|
|
# X*(x2-x1)^2 + (x2-x1)^2 = X*(y2-y1)^2 - x1*(y2-y1)^2 + (y1+1)*(y2-y1)*(x2-x1) |
831
|
|
|
|
|
|
|
# X*(x2-x1)^2 - X*(y2-y1)^2 = -(x2-x1)^2 - x1*(y2-y1)^2 + (y1+1)*(y2-y1)*(x2-x1) |
832
|
|
|
|
|
|
|
# |
833
|
|
|
|
|
|
|
# line X=x1+pos, Y=y1 + pos*(y2-y1)/(x2-x1) |
834
|
|
|
|
|
|
|
# Y=y1 + (X-x1)/(x2-x1)*(y2-y1) |
835
|
|
|
|
|
|
|
# eg. X=x1 Y=y1 + 0 |
836
|
|
|
|
|
|
|
# eg. X=x2 Y=y1 + 1*(y2-y1) = y2 |
837
|
|
|
|
|
|
|
# Y-y1 = (X-x1)/(x2-x1)*(y2-y1) |
838
|
|
|
|
|
|
|
# (Y-y1)*(x2-x1) = (X-x1)*(y2-y1) |
839
|
|
|
|
|
|
|
# |
840
|
|
|
|
|
|
|
# line at X=0 is |
841
|
|
|
|
|
|
|
# Y = (-x1)/(x2-x1)*(y2-y1) + y1 |
842
|
|
|
|
|
|
|
# for Y <= -1 |
843
|
|
|
|
|
|
|
# (-x1)/(x2-x1)*(y2-y1) + y1 <= -1 |
844
|
|
|
|
|
|
|
# (-x1)/(x2-x1)*(y2-y1) <= -1-y1 |
845
|
|
|
|
|
|
|
# (-x1)*(y2-y1) <= (-1-y1)*(x2-x1) would swap if x2
|
846
|
|
|
|
|
|
|
# x1*(y2-y1) >= (y1+1)*(x2-x1) |
847
|
|
|
|
|
|
|
# eg. x1=-1;y1=-1; x2=1;y2=1 Y = 0 -2>=0 |
848
|
|
|
|
|
|
|
# |
849
|
|
|
|
|
|
|
# eg. y1=y2=y 0 < (-1-y)*(x2-x1) |
850
|
|
|
|
|
|
|
# (x1+1)*(y2-y1) > (y1+1)*(x2-x1) |
851
|
|
|
|
|
|
|
# eg. x1=x2=5 -5*(y2-y1) > (y1+1)*0 no |
852
|
|
|
|
|
|
|
# |
853
|
|
|
|
|
|
|
# | 5,-10 |
854
|
|
|
|
|
|
|
# /| |
855
|
|
|
|
|
|
|
# -----/---------- |
856
|
|
|
|
|
|
|
# -10,5 | |
857
|
|
|
|
|
|
|
# eg. x1=-10;y1=5; x2=5;y2=-10; x1*(y2-y1); (y1+1)*(x2-x1) |
858
|
|
|
|
|
|
|
# is 150 < 90 |
859
|
|
|
|
|
|
|
# |
860
|
|
|
|
|
|
|
# | 10,-5 |
861
|
|
|
|
|
|
|
# -------/----- |
862
|
|
|
|
|
|
|
# |/ |
863
|
|
|
|
|
|
|
# /| |
864
|
|
|
|
|
|
|
# -5,10| |
865
|
|
|
|
|
|
|
# eg. x1=-5;y1=10; x2=10;y2=-5; x1*(y2-y1); (y1+1)*(x2-x1) |
866
|
|
|
|
|
|
|
# is 75 < 165 |
867
|
|
|
|
|
|
|
# |
868
|
|
|
|
|
|
|
# eg. x1=5;y1=-10; x2=5;y2=10; x1*(y2-y1); (y1+1)*(x2-x1) |
869
|
|
|
|
|
|
|
# is 100 < 0 |
870
|
|
|
|
|
|
|
# |
871
|
|
|
|
|
|
|
sub _line_any_positive { |
872
|
18
|
|
|
18
|
|
844
|
my ($x1,$y1, $x2,$y2) = @_; |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
# swap ends to x1 <= x2 |
875
|
18
|
100
|
|
|
|
53
|
($x1,$y1, $x2,$y2) = ($x2,$y2, $x1,$y1) if $x2 < $x1; |
876
|
|
|
|
|
|
|
### _line_any_positive() swapped to: "$x1, $y1, $x2, $y2" |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
return (# must have x2 positive, otherwise all X negative |
879
|
18
|
|
66
|
|
|
80
|
$x2 > -1 |
880
|
|
|
|
|
|
|
&& |
881
|
|
|
|
|
|
|
(# if y2 positive then x2,y2 end both positive so line positive |
882
|
|
|
|
|
|
|
$y2 > -1 |
883
|
|
|
|
|
|
|
|| |
884
|
|
|
|
|
|
|
(# else must have y1 positive, otherwise y1 and y2 both negative |
885
|
|
|
|
|
|
|
$y1 > -1 |
886
|
|
|
|
|
|
|
# now | x2,y2 | x2,y2 x2 pos, y2 neg |
887
|
|
|
|
|
|
|
# --------- --------- |
888
|
|
|
|
|
|
|
# x1,y1 | | x1,y1 x1 pos or neg, y1 pos |
889
|
|
|
|
|
|
|
# see if the X position corresponding to Y=0 is >= -1 |
890
|
|
|
|
|
|
|
&& |
891
|
|
|
|
|
|
|
$x1*($y2-$y1) < ($y1+1)*($x2-$x1)))); |
892
|
|
|
|
|
|
|
} |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
# (xnew-xp)/(x-xp) = (ylo-yp)/(y-yp) |
895
|
|
|
|
|
|
|
# xnew-xp = (ylo-yp)/(y-yp)*(x-xp) |
896
|
|
|
|
|
|
|
# xnew = (ylo-yp)/(y-yp)*(x-xp) + xp |
897
|
|
|
|
|
|
|
# = x*(ylo-yp)/(y-yp) - xp*(ylo-yp)/(y-yp) + xp |
898
|
|
|
|
|
|
|
# = x*(ylo-yp)/(y-yp) + xp*(1 - (ylo-yp)/(y-yp)) |
899
|
|
|
|
|
|
|
# = x*(ylo-yp)/(y-yp) + xp*(((y-yp) - (ylo-yp))/(y-yp) |
900
|
|
|
|
|
|
|
# = [ x*(ylo-yp) + xp*(y - yp - ylo + yp) ]/(y-yp) |
901
|
|
|
|
|
|
|
# = [ x*(ylo-yp) + xp*(y-ylo) ]/(y-yp) |
902
|
|
|
|
|
|
|
# |
903
|
|
|
|
|
|
|
# x,y |
904
|
|
|
|
|
|
|
# / \ |
905
|
|
|
|
|
|
|
# / \ |
906
|
|
|
|
|
|
|
# / \ |
907
|
|
|
|
|
|
|
# xnew,ynew=ylo ------------------ |
908
|
|
|
|
|
|
|
# / \ |
909
|
|
|
|
|
|
|
# / \ |
910
|
|
|
|
|
|
|
# xprev,yprev xnext,ynext |
911
|
|
|
|
|
|
|
# |
912
|
|
|
|
|
|
|
# x,y |
913
|
|
|
|
|
|
|
# / \ |
914
|
|
|
|
|
|
|
# / __* xnext,ynext |
915
|
|
|
|
|
|
|
# /__-- |
916
|
|
|
|
|
|
|
# xnew,ynew=ylo --*--------------- |
917
|
|
|
|
|
|
|
# / |
918
|
|
|
|
|
|
|
# / |
919
|
|
|
|
|
|
|
# xprev,yprev |
920
|
|
|
|
|
|
|
# |
921
|
|
|
|
|
|
|
# -8,-8 7,-7 |
922
|
|
|
|
|
|
|
# *---- ----* |
923
|
|
|
|
|
|
|
# | | | | |
924
|
|
|
|
|
|
|
# ----* *---- |
925
|
|
|
|
|
|
|
# 7,7 -8,8 |
926
|
|
|
|
|
|
|
# |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
# _convex_poly_clip() takes $aref is an arrayref of vertex coordinates |
929
|
|
|
|
|
|
|
# $aref = [ $x1,$y1, $x2,$y2, ..., $xn,$yn ]. |
930
|
|
|
|
|
|
|
# |
931
|
|
|
|
|
|
|
# The polygon is line segment $x1,$y1 to $x2,$y2, etc, and final |
932
|
|
|
|
|
|
|
# $xn,$yn back to $x1,$y1 start. |
933
|
|
|
|
|
|
|
# |
934
|
|
|
|
|
|
|
# Modify the array contents to clip the polygon to signed 16-bit. |
935
|
|
|
|
|
|
|
# This might either increase or decrease the total number of vertices. |
936
|
|
|
|
|
|
|
# If the polygon is entirely outside 16-bits then leave an empty array. |
937
|
|
|
|
|
|
|
# |
938
|
|
|
|
|
|
|
sub _convex_poly_clip { |
939
|
0
|
|
|
0
|
|
|
my ($aref) = @_; |
940
|
|
|
|
|
|
|
### _convex_poly_clip(): $aref |
941
|
|
|
|
|
|
|
|
942
|
0
|
|
|
|
|
|
foreach (1 .. 4) { # each side |
943
|
|
|
|
|
|
|
### side: $_ |
944
|
|
|
|
|
|
|
|
945
|
0
|
|
0
|
|
|
|
for (my $i = 0; $i < $#$aref && $#$aref >= 3; ) { |
946
|
|
|
|
|
|
|
### at: "i=$i of ".scalar(@$aref)." ".join(', ',@$aref) |
947
|
0
|
|
|
|
|
|
my $y = $aref->[$i+1]; |
948
|
0
|
0
|
|
|
|
|
if ($y <= _HI) { |
949
|
|
|
|
|
|
|
# This vertex is below the _HI limit, keep it unchanged. |
950
|
0
|
|
|
|
|
|
$i += 2; |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
} else { |
953
|
|
|
|
|
|
|
# This vertex is outside the _HI limit, replace it by zero, one or |
954
|
|
|
|
|
|
|
# two new clipped points. |
955
|
0
|
|
|
|
|
|
my ($x,$y) = splice @$aref, $i,2; |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
{ |
958
|
0
|
|
|
|
|
|
my $yprev = $aref->[$i-1]; # with possible wrap back to $xn,$yn |
959
|
0
|
0
|
|
|
|
|
if ($yprev <= _HI) { |
960
|
0
|
|
|
|
|
|
my $xprev = $aref->[$i-2]; |
961
|
0
|
|
|
|
|
|
my $xnew = int(($x*(_HI - $yprev) + $xprev*($y - _HI)) / ($y-$yprev) |
962
|
|
|
|
|
|
|
+ 0.5); |
963
|
0
|
|
|
|
|
|
splice @$aref, $i,0, $xnew,_HI; |
964
|
0
|
|
|
|
|
|
$i += 2; |
965
|
|
|
|
|
|
|
} else { |
966
|
|
|
|
|
|
|
# $yprev and $y both above _HI limit, so nothing for segment |
967
|
|
|
|
|
|
|
# $yprev to $y, just leave $yprev for the next vertex to |
968
|
|
|
|
|
|
|
# consider. (This case only occurs when $i==0 and so $yprev is |
969
|
|
|
|
|
|
|
# wrapped back to the last vertex $yn. Any later $i will have |
970
|
|
|
|
|
|
|
# $yprev already clipped to $yprev<=_HI.) |
971
|
|
|
|
|
|
|
} |
972
|
|
|
|
|
|
|
} |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
{ |
975
|
0
|
|
|
|
|
|
my $inext = $i % scalar(@$aref); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
976
|
0
|
|
|
|
|
|
my $ynext = $aref->[$inext+1]; |
977
|
0
|
0
|
|
|
|
|
if ($ynext <= _HI) { |
978
|
0
|
|
|
|
|
|
my $xnext = $aref->[$inext]; |
979
|
0
|
|
|
|
|
|
my $xnew = int(($x*(_HI - $ynext) + $xnext*($y - _HI)) / ($y-$ynext) |
980
|
|
|
|
|
|
|
+ 0.5); |
981
|
0
|
|
|
|
|
|
splice @$aref, $i,0, $xnew,_HI; |
982
|
0
|
|
|
|
|
|
$i += 2; |
983
|
|
|
|
|
|
|
} else { |
984
|
|
|
|
|
|
|
# $y and $ynext both above _HI limit, so nothing for segment $y |
985
|
|
|
|
|
|
|
# to $ynext |
986
|
|
|
|
|
|
|
} |
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
} |
989
|
|
|
|
|
|
|
} |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
# rotate 90 |
992
|
0
|
|
|
|
|
|
for (my $i = 0; $i < $#$aref; $i += 2) { |
993
|
0
|
|
|
|
|
|
($aref->[$i],$aref->[$i+1]) = ($aref->[$i+1], -1 - $aref->[$i]); |
994
|
|
|
|
|
|
|
} |
995
|
|
|
|
|
|
|
} |
996
|
0
|
0
|
|
|
|
|
if (@$aref == 2) { |
997
|
0
|
|
|
|
|
|
@$aref = (); |
998
|
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
} |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
1; |
1003
|
|
|
|
|
|
|
__END__ |