1package Prima::Drawable::Gradient;
2
3use strict;
4use warnings;
5
6sub new
7{
8	my ( $class, $canvas, %opt) = @_;
9	bless {
10		canvas  => $canvas,
11		palette => [ cl::White, cl::Black ],
12		%opt
13	}, $class;
14}
15
16sub clone
17{
18	my ( $self, %opt ) = @_;
19	return ref($self)->new( undef, %$self, %opt );
20}
21
22sub canvas  { shift->{canvas} }
23sub palette { shift->{palette} }
24
25sub polyline_to_points
26{
27	my ($self, $p) = @_;
28	my @map;
29	for ( my $i = 0; $i < @$p - 2; $i+=2) {
30		my ($x1,$y1,$x2,$y2) = @$p[$i..$i+3];
31		$x1 = 0 if $x1 < 0;
32		my $dx = $x2 - $x1;
33		if ( $dx > 0 ) {
34			my $dy = ($y2 - $y1) / $dx;
35			my $y = $y1;
36			for ( my $x = int($x1); $x <= int($x2); $x++) {
37				$map[$x] = $y;
38				$y += $dy;
39			}
40		} else {
41			$map[int($x1)] = $y1;
42		}
43	}
44	return \@map;
45}
46
47sub stripes
48{
49	my ( $self, $breadth) = @_;
50
51	my ($offsets, $points);
52
53	unless ($points = $self->{points}) {
54		my @spline = (0,0);
55		if ( my $s = $self->{spline} ) {
56			push @spline, map { $_ * $breadth } @$s;
57		}
58		if ( my $s = $self->{poly} ) {
59			push @spline, map { $_ * $breadth } @$s;
60		}
61		push @spline, $breadth, $breadth;
62		my $polyline = ( @spline > 4 && $self->{spline} ) ? Prima::Drawable-> render_spline( \@spline ) : \@spline;
63		$points = $self-> polyline_to_points($polyline);
64	}
65
66
67	unless ( $offsets = $self->{offsets}) {
68		my @o;
69		my $n = scalar(@{$self->{palette}}) - 1;
70		my $d = 0;
71		for ( my $i = 0; $i < $n; $i++) {
72			$d += 1/$n;
73			push @o, $d;
74		}
75		push @o, 1;
76		$offsets = \@o;
77	}
78
79	return $self-> calculate(
80		$self->{palette},
81		[ map { $_ * $breadth } @$offsets ],
82		sub { $points->[shift] }
83	);
84}
85
86sub colors
87{
88	my ( $self, $breadth) = @_;
89
90	my $stripes = $self->stripes($breadth);
91	my @colors;
92	for ( my $i = 0; $i < @$stripes; $i+=2 ) {
93		push @colors, $stripes->[$i] for 1 .. $stripes->[$i+1];
94	}
95	return @colors;
96}
97
98sub map_color
99{
100	my ( $self, $color ) = @_;
101	return $color unless $color & cl::SysFlag;
102	$color |=
103		$self->{widgetClass} //
104		(( $self->{canvas} && $self->{canvas}->isa('Prima::Widget')) ? $self->{canvas}->widgetClass : undef ) //
105		wc::Undef
106		unless $color & wc::Mask;
107	return $::application->map_color($color);
108}
109
110sub calculate_single
111{
112	my ( $self, $breadth, $start_color, $end_color, $function, $offset ) = @_;
113
114	return if $breadth <= 0;
115
116	$offset //= 0;
117	$start_color = $self-> map_color( $start_color);
118	$end_color   = $self-> map_color( $end_color);
119	my @start = cl::to_rgb($start_color);
120	my @end   = cl::to_rgb($end_color);
121	my @color = @start;
122	return $start_color, 1 if $breadth == 1;
123
124	my @delta = map { ( $end[$_] - $start[$_] ) / ($breadth - 1) } 0..2;
125
126	my $last_color = $start_color;
127	my $color      = $start_color;
128	my $width      = 0;
129	my @ret;
130	for ( my $i = 0; $i < $breadth; $i++) {
131		my @c;
132		my $j = $function ? $function->( $offset + $i ) - $offset : $i;
133		for ( 0..2 ) {
134			$color[$_] = $start[$_] + $j * $delta[$_] for 0..2;
135			$c[$_] = int($color[$_] + .5);
136			$c[$_] = 0xff if $c[$_] > 0xff;
137			$c[$_] = 0    if $c[$_] < 0;
138		}
139		$color = ( $c[0] << 16 ) | ( $c[1] << 8 ) | $c[2];
140		if ( $last_color != $color ) {
141			push @ret, $last_color, $width;
142			$last_color = $color;
143			$width = 0;
144		}
145
146		$width++;
147	}
148
149	return @ret, $color, $width;
150}
151
152sub calculate
153{
154	my ( $self, $palette, $offsets, $function ) = @_;
155	my @ret;
156	my $last_offset = 0;
157	$offsets = [ $offsets ] unless ref $offsets;
158	for ( my $i = 0; $i < @$offsets; $i++) {
159		my $breadth = $offsets->[$i] - $last_offset;
160		push @ret, $self-> calculate_single( $breadth, $palette->[$i], $palette->[$i+1], $function, $last_offset);
161		$last_offset = $offsets->[$i];
162	}
163	return \@ret;
164}
165
166sub bar
167{
168	my ( $self, $x1, $y1, $x2, $y2, $vertical ) = @_;
169
170	$_ = int($_) for $x1, $y1, $x2, $y2;
171
172	($x1,$x2)=($x2,$x1) if $x1 > $x2;
173	($y1,$y2)=($y2,$y1) if $y1 > $y2;
174
175	$vertical //= $self->{vertical};
176	my $stripes = $self-> stripes(
177		$vertical ?
178			$x2 - $x1 + 1 :
179			$y2 - $y1 + 1
180	);
181
182	my @bar        = ($x1,$y1,$x2,$y2);
183	my ($ptr1,$ptr2) = $vertical ? (0,2) : (1,3);
184	my $max          = $bar[$ptr2];
185	my $canvas       = $self->canvas;
186	for ( my $i = 0; $i < @$stripes; $i+=2) {
187		$bar[$ptr2] = $bar[$ptr1] + $stripes->[$i+1] - 1;
188		$canvas->color( $stripes->[$i]);
189		$canvas->bar( @bar );
190		$bar[$ptr1] = $bar[$ptr2] + 1;
191		last if $bar[$ptr1] > $max;
192	}
193	if ( $bar[$ptr1] <= $max ) {
194		$bar[$ptr2] = $max;
195		$canvas->bar(@bar);
196	}
197}
198
199sub ellipse
200{
201	my ( $self, $x, $y, $dx, $dy ) = @_;
202	return if $dx <= 0 || $dy <= 0;
203
204	$_ = int($_) for $x, $y, $dx, $dy;
205	my $diameter = ($dx > $dy) ? $dx : $dy;
206	my $mx = $dx / $diameter;
207	my $my = $dy / $diameter;
208	my $stripes = $self-> stripes( $diameter);
209	my $canvas  = $self->canvas;
210	for ( my $i = 0; $i < @$stripes; $i+=2) {
211		$canvas->color( $stripes->[$i]);
212		$canvas->fill_ellipse( $x, $y, $mx * $diameter, $my * $diameter );
213		$diameter -= $stripes->[$i+1];
214	}
215}
216
217sub sector
218{
219	my ( $self, $x, $y, $dx, $dy, $start, $end ) = @_;
220	my $angle = $end - $start;
221	$angle += 360 while $angle < 0;
222	$angle %= 720;
223	$angle -= 360 if $angle > 360;
224	my $min_angle = 1.0 / 64; # x11 limitation
225
226	my $max = ($dx < $dy) ? $dy : $dx;
227	my $df  = $max * 3.14 / 360;
228	my $arclen = int($df * $angle + .5);
229	my $stripes = $self-> stripes( $arclen );
230	my $accum = 0;
231	my $canvas = $self->canvas;
232	for ( my $i = 0; $i < @$stripes - 2; $i+=2) {
233		$canvas->color( $stripes->[$i]);
234		my $d = $stripes->[$i+1] / $df;
235		if ( $accum + $d < $min_angle ) {
236			$accum += $d;
237			next;
238		}
239		$d += $accum;
240		$accum = 0;
241		$canvas->fill_sector( $x, $y, $dx, $dy, $start, $start + $d + $min_angle);
242		$start += $d;
243	}
244	if ( @$stripes ) {
245		$canvas->color( $stripes->[-2]);
246		$canvas->fill_sector( $x, $y, $dx, $dy, $start, $end);
247	}
248}
249
2501;
251
252=pod
253
254=head1 NAME
255
256Prima::Drawable::Gradient - gradient fills for primitives
257
258=head1 DESCRIPTION
259
260Prima offers primitive gradient services to draw gradually changing colors.
261A gradient is requested by setting of at least two colors and optionally
262a set of quadratic spline points that, when, projected, generate the transition curve
263between the colors.
264
265The module augments the C<Prima::Drawable> drawing functionality by
266adding C<new_gradient> function.
267
268=head1 SYNOPSIS
269
270	$canvas-> new_gradient(
271		palette => [ cl::White, cl::Blue, cl::White ],
272	)-> sector(50,50,100,100,0,360);
273
274=for podview <img src="Prima/gradient.gif">
275
276=for html <p><img src="https://raw.githubusercontent.com/dk/Prima/master/pod/Prima/gradient.gif">
277
278=head1 API
279
280=head2 Methods
281
282=over
283
284=item new $CANVAS, %OPTIONS
285
286Here are %OPTIONS understood in the gradient request:
287
288=over
289
290=item clone %OPTIONS
291
292Creates a new gradient object with %OPTIONS replaced.
293
294=item widgetClass INTEGER
295
296Points to a widget class to resolve generic colors like C<cl::Back>,
297that may differ from widget class to widget class.
298
299=item palette @COLORS
300
301Each color is a C<cl::> value. The gradient is calculated as polyline where
302each its vertex corresponds to a certain blend between two neighbouring colors
303in the palette. F.ex. the simplest palette going from C<cl::White> to
304C<cl::Black> over a polyline C<0..1> (default), produces pure white color at
305the start and pure black color at the end, filling all available shades of gray
306in between, and changing monotonically.
307
308=item poly @VERTICES
309
310Set of 2-integer polyline vertexes where the first integer is a coordinate (x,
311y, or whatever required by the drawing primitive) between 0 and 1, and the
312second is the color blend value between 0 and 1.
313
314Default: ((0,0),(1,1))
315
316=item spline \@VERTICES, %OPTIONS
317
318Serving same purpose as C<poly> but vertexes are projected first to a B-spline
319curve using L<render_spline> and C<%OPTIONS>. The resulting polyline is treated
320as C<poly>.
321
322=item vertical BOOLEAN
323
324Only used in L<bar>, to set gradient direction.
325
326=back
327
328See also: L<bar>, L<stripes> .
329
330=item bar X1, Y1, X2, Y2, VERTICAL = 0
331
332Draws a filled rectangle within (X1,Y1) - (X2,Y2) extents
333
334Context used: fillPattern, rop, rop2
335
336=item colors BREADTH
337
338Returns a list of gradient colors for each step from 1 to BREADTH.
339
340=item ellipse X, Y, DIAM_X, DIAM_Y
341
342Draws a filled ellipse with center in (X,Y) and diameters (DIAM_X,DIAM_Y)
343
344Context used: fillPattern, rop, rop2
345
346=item sector X, Y, DIAM_X, DIAM_Y, START_ANGLE, END_ANGLE
347
348Draws a filled sector with center in (X,Y) and diameters (DIAM_X,DIAM_Y) from START_ANGLE to END_ANGLE
349
350Context used: fillPattern, rop, rop2
351
352=item stripes BREADTH
353
354Returns an array consisting of integer pairs, where the first one is
355a color value, and the second is the breadth of the color strip.
356L<bar> uses this information to draw a gradient fill, where
357each color strip is drawn with its own color. Can be used for implementing
358other gradient-aware primitives (see F<examples/f_fill.pl> )
359
360=back
361
362=head1 AUTHOR
363
364Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.
365
366=head1 SEE ALSO
367
368L<Prima::Drawable>, F<examples/f_fill.pl>, F<examples/gradient.pl>
369
370=cut
371