1package Prima::Drawable::Basic; # for metacpan
2package Prima::Drawable;
3
4use strict;
5use warnings;
6
7sub rect3d
8{
9	my ( $self, $x, $y, $x1, $y1, $width, $lColor, $rColor, $backColor) = @_;
10	my $c = $self-> color;
11	$_ = int($_) for $x1, $y1, $x, $y, $width;
12	if ( defined $backColor)
13	{
14		if ( ref($backColor)) {
15			$backColor->clone(canvas => $self)->bar($x + $width, $y + $width, $x1 - $width, $y1 - $width);
16		} elsif ( $backColor == cl::Back) {
17			$self-> clear( $x + $width, $y + $width, $x1 - $width, $y1 - $width);
18		} else {
19			$self-> color( $backColor);
20			$self-> bar( $x + $width, $y + $width, $x1 - $width, $y1 - $width);
21		}
22	}
23	$lColor = $rColor = cl::Black if $self-> get_bpp == 1;
24	$self-> color( $c), return if $width <= 0;
25	$self-> color( $lColor);
26	$width = ( $y1 - $y) / 2 if $width > ( $y1 - $y) / 2;
27	$width = ( $x1 - $x) / 2 if $width > ( $x1 - $x) / 2;
28	$self-> lineWidth( 0);
29	my $i;
30	for ( $i = 0; $i < $width; $i++) {
31		$self-> line( $x + $i, $y + $i, $x + $i, $y1 - $i);
32		$self-> line( $x + $i + 1, $y1 - $i, $x1 - $i, $y1 - $i);
33	}
34	$self-> color( $rColor);
35	for ( $i = 0; $i < $width; $i++) {
36		$self-> line( $x1 - $i, $y + $i, $x1 - $i, $y1 - $i);
37		$self-> line( $x + $i + 1, $y + $i, $x1 - $i, $y + $i);
38	}
39	$self-> color( $c);
40}
41
42sub rect_focus
43{
44	my ( $canvas, $x, $y, $x1, $y1, $width) = @_;
45	( $x, $x1) = ( $x1, $x) if $x > $x1;
46	( $y, $y1) = ( $y1, $y) if $y > $y1;
47
48	$width = 1 if !defined $width || $width < 1;
49	my ( $cl, $cl2, $aa, $alpha) = ( $canvas-> color, $canvas-> backColor, $canvas-> antialias, $canvas-> alpha);
50	my $fp = $canvas-> fillPattern;
51	$canvas-> set(
52		fillPattern => fp::SimpleDots,
53		color       => cl::White,
54		backColor   => cl::Black,
55		antialias   => 0,
56		alpha       => 255,
57	);
58
59	if ( $width * 2 >= $x1 - $x or $width * 2 >= $y1 - $y) {
60		$canvas-> bar( $x, $y, $x1, $y1);
61	} else {
62		$width -= 1;
63		$canvas-> bar( $x, $y, $x1, $y + $width);
64		$canvas-> bar( $x, $y1 - $width, $x1, $y1);
65		$canvas-> bar( $x, $y + $width + 1, $x + $width, $y1 - $width - 1);
66		$canvas-> bar( $x1 - $width, $y + $width + 1, $x1, $y1 - $width - 1);
67	}
68
69	$canvas-> set(
70		fillPattern => $fp,
71		backColor   => $cl2,
72		color       => $cl,
73	);
74}
75
76sub draw_text
77{
78	my ( $canvas, $string, $x, $y, $x2, $y2, $flags, $tabIndent) = @_;
79
80	$flags     = dt::Default unless defined $flags;
81	$tabIndent = 1 if !defined( $tabIndent) || $tabIndent < 0;
82
83	$x2 //= $x + 1;
84	$y2 //= $y + 1;
85
86	$x2 = int( $x2);
87	$x  = int( $x);
88	$y2 = int( $y2);
89	$y  = int( $y);
90
91	my ( $w, $h) = ( $x2 - $x + 1, $y2 - $y + 1);
92
93	return 0 if $w <= 0 || $h <= 0;
94
95	my $twFlags = tw::ReturnLines |
96		(( $flags & dt::DrawMnemonic  ) ? ( tw::CalcMnemonic | tw::CollapseTilde) : 0) |
97		(( $flags & dt::DrawSingleChar) ? 0 : tw::BreakSingle ) |
98		(( $flags & dt::NewLineBreak  ) ? tw::NewLineBreak : 0) |
99		(( $flags & dt::SpaceBreak    ) ? tw::SpaceBreak   : 0) |
100		(( $flags & dt::WordBreak     ) ? tw::WordBreak    : 0) |
101		(( $flags & dt::ExpandTabs    ) ? ( tw::ExpandTabs | tw::CalcTabs) : 0)
102	;
103
104	my @lines = @{$canvas-> text_wrap_shape( $string,
105		( $flags & dt::NoWordWrap) ? undef : $w,
106		options => $twFlags, tabs => $tabIndent
107	)};
108
109	my $tildes;
110	$tildes = pop @lines if $flags & dt::DrawMnemonic;
111
112	return 0 unless scalar @lines;
113
114	my @clipSave;
115	my $fh = $canvas-> font-> height +
116		(( $flags & dt::UseExternalLeading) ?
117			$canvas-> font-> externalLeading :
118			0
119		);
120	my ( $linesToDraw, $retVal);
121	my $valign = $flags & 0xC;
122
123	if ( $flags & dt::QueryHeight) {
124		$linesToDraw = scalar @lines;
125		$h = $retVal = $linesToDraw * $fh;
126	} else {
127		$linesToDraw = int( $retVal = ( $h / $fh));
128		$linesToDraw++
129			if (( $h % $fh) > 0) and ( $flags & dt::DrawPartial);
130		$valign      = dt::Top
131			if $linesToDraw < scalar @lines;
132		$linesToDraw = $retVal = scalar @lines
133			if $linesToDraw > scalar @lines;
134	}
135
136	if ( $flags & dt::UseClip) {
137		@clipSave = $canvas-> clipRect;
138		$canvas-> clipRect( $x, $y, $x + $w, $y + $h);
139	}
140
141	if ( $valign == dt::Top) {
142		$y = $y2;
143	} elsif ( $valign == dt::VCenter) {
144		$y = $y2 - int(( $h - $linesToDraw * $fh) / 2);
145	} else {
146		$y += $linesToDraw * $fh;
147	}
148
149	my ( $starty, $align) = ( $y, $flags & 0x3);
150
151	for ( @lines) {
152		last unless $linesToDraw--;
153		my $xx;
154		if ( $align == dt::Left) {
155			$xx = $x;
156		} elsif ( $align == dt::Center) {
157			$xx = $x + int(( $w - $canvas-> get_text_width( $_)) / 2);
158		} else {
159			$xx = $x2 - $canvas-> get_text_width( $_);
160		}
161		$y -= $fh;
162		$canvas-> text_out( $_, $xx, $y);
163	}
164
165	if (( $flags & dt::DrawMnemonic) and ( defined $tildes-> {tildeLine})) {
166		my $tl = $tildes-> {tildeLine};
167		my $xx = $x;
168		if ( $align == dt::Center) {
169			$xx = $x + int(( $w - $canvas-> get_text_width( $lines[ $tl])) / 2);
170		} elsif ( $align == dt::Right) {
171			$xx = $x2 - $canvas-> get_text_width( $lines[ $tl]);
172		}
173		$tl++;
174		$canvas-> line(
175			$xx + $tildes-> {tildeStart}, $starty - $fh * $tl,
176			$xx + $tildes-> {tildeEnd}  , $starty - $fh * $tl
177		);
178	}
179
180	$canvas-> clipRect( @clipSave) if $flags & dt::UseClip;
181
182	return $retVal;
183}
184
185sub prelight_color
186{
187	my ( $self, $color, $coeff ) = @_;
188	$coeff //= 1.05;
189	return 0 if $coeff <= 0;
190	$color = $self->map_color($color) if $color & cl::SysFlag;
191	if (( $color == 0xffffff && $coeff > 1) || ($color == 0 && $coeff < 1)) {
192		$coeff = 1/$coeff;
193	}
194	$coeff = ($coeff - 1) * 256;
195	my @channels = cl::to_rgb($color);
196	for (@channels) {
197		my $amp = ( 256 - $_ ) / 8;
198		$amp = -$amp if $coeff < 0;
199		$_ += $coeff + $amp;
200		$_ = 255 if $_ > 255;
201		$_ = 0   if $_ < 0;
202	}
203	return cl::from_rgb(@channels);
204}
205
206sub text_split_lines
207{
208	my ($self, $text) = @_;
209	return ref($text) ?
210		@{ $self-> text_wrap( $text, 0, tw::NewLineBreak ) } :
211		split "\n", $text;
212}
213
214sub new_path
215{
216	require Prima::Drawable::Path;
217	return Prima::Drawable::Path->new(@_);
218}
219
220sub new_gradient
221{
222	require Prima::Drawable::Gradient;
223	return Prima::Drawable::Gradient->new(@_);
224}
225
226sub new_aa_surface
227{
228	require Prima::Drawable::Antialias;
229	return Prima::Drawable::Antialias->new(@_);
230}
231
232sub new_glyph_obj
233{
234	shift;
235	require Prima::Drawable::Glyphs;
236	return Prima::Drawable::Glyphs->new(@_);
237}
238
239sub stroke_img_primitive
240{
241	my ( $self, $request ) = (shift, shift);
242	return 1 if $self->rop == rop::NoOper;
243	return 1 if $self->linePattern eq lp::Null && $self->rop2 == rop::NoOper;
244
245	my $path = $self->new_path;
246	my @offset  = $self->translate;
247	$path->translate(@offset);
248	$path->$request(@_);
249	my $ok = 1;
250	if ( int($self->lineWidth + .5) == 0 ) {
251		# paths produce floating point coordinates and line end arcs,
252		# here we need internal pixel-wise plotting
253		for my $pp ( map { @$_ } @{ $path->points } ) {
254			last unless $ok &= $self->polyline($pp);
255		}
256		return $ok;
257	}
258
259	my %widen;
260	my $method;
261	if ($self->linePattern eq lp::Null) {
262		$widen{linePattern} = lp::Solid;
263		$method = 'clear';
264	} else {
265		$method = 'bar';
266	}
267
268	my $region2 = $self->region;
269	my $path2   = $path->widen(%widen);
270	my $region1 = $path2->region(fm::Winding | fm::Overlay);
271	my @box = $region1->box;
272	$box[$_+2] += $box[$_] for 0,1;
273	my $fp = $self->fillPattern;
274	$self->fillPattern(fp::Solid);
275	$self->translate(0,0);
276	if ( $self-> rop2 == rop::CopyPut && $self->linePattern ne lp::Solid && $self->linePattern ne lp::Null ) {
277		my $color = $self->color;
278		$self->color($self->backColor);
279		my $path3 = $path->widen( linePattern => lp::Solid );
280		my $region3 = $path3->region;
281		$region3->combine( $region1, rgnop::Diff);
282		$region3->combine($region2, rgnop::Intersect) if $region2;
283		$self->region($region3);
284		$ok = $self->bar(@box);
285		$self->color($color);
286	}
287
288	$region1->combine($region2, rgnop::Intersect) if $region2;
289	$self->region($region1);
290	$ok &&= $self->$method(@box);
291	$self->region($region2);
292	$self->fillPattern($fp);
293	$self->translate(@offset);
294	return $ok;
295}
296
297sub fill_img_primitive
298{
299	my ( $self, $request ) = (shift, shift);
300	my $path = $self->new_path;
301	$path->$request(@_);
302	my @offset  = $self->translate;
303	my $region1 = $path->region( $self-> fillMode);
304	$region1->offset(@offset);
305	my $region2 = $self->region;
306	$region1->combine($region2, rgnop::Intersect) if $region2;
307	my @box = $region1->box;
308	$box[$_+2] += $box[$_] for 0,1;
309	$self->region($region1);
310	$self->translate(0,0);
311	my $ok = $self->bar(@box);
312	$self->translate(@offset);
313	$self->region($region2);
314	return $ok;
315}
316
317sub stroke_imgaa_primitive
318{
319	my ( $self, $request ) = (shift, shift);
320	return 1 if $self->rop == rop::NoOper;
321	my $lp = $self->linePattern;
322	return 1 if $lp eq lp::Null && $self->rop2 == rop::NoOper;
323
324	my $aa = $self->new_aa_surface;
325	return 0 unless $aa->can_aa;
326
327	my $path = $self->new_path;
328	$path->$request(@_);
329	$path = $path->widen(
330		linePattern => ( $lp eq lp::Null) ? lp::Solid : $lp
331	);
332	my %save;
333	$save{fillPattern} = $self->fillPattern;
334	$save{fillMode}    = $self->fillMode;
335	$self->fillPattern(fp::Solid);
336	$self->fillMode(fm::Winding);
337	if ( $lp eq lp::Null ) {
338		$save{color} = $self->color;
339		$self->color($self->backColor);
340	}
341	my $ok = 1;
342	for ($path->points(fill => 1)) {
343		$ok &= $aa->fillpoly($_);
344		last unless $ok;
345	}
346	$self->$_($save{$_}) for keys %save;
347	return $ok;
348}
349
350sub fill_imgaa_primitive
351{
352	my ( $self, $request ) = (shift, shift);
353	my $path = $self->new_path;
354	$path->$request(@_);
355	my $aa = $self->new_aa_surface;
356	return 0 unless $aa->can_aa;
357	for ($path->points(fill => 1)) {
358		return 0 unless $aa->fillpoly($_);
359	}
360	return 1;
361}
362
363sub stroke_aa_primitive
364{
365	my ( $self, $request ) = (shift, shift);
366	return 1 if $self->rop == rop::NoOper;
367	my $lp = $self->linePattern;
368	return 1 if $lp eq lp::Null && $self->rop2 == rop::NoOper;
369
370	my $path = $self->new_path;
371	$path->$request(@_);
372	$path = $path->widen(
373		linePattern => ( $lp eq lp::Null) ? lp::Solid : $lp
374	);
375	my %save;
376	$save{fillPattern} = $self->fillPattern;
377	$save{fillMode}    = $self->fillMode;
378	$self->fillPattern(fp::Solid);
379	$self->fillMode(fm::Winding);
380	if ( $lp eq lp::Null ) {
381		$save{color} = $self->color;
382		$self->color($self->backColor);
383	}
384	my $ok = $path->fill;
385	$self->$_($save{$_}) for keys %save;
386	return $ok;
387}
388
389sub fill_aa_primitive
390{
391	my ( $self, $request ) = (shift, shift);
392	my $path = $self->new_path;
393	$path->$request(@_);
394	for ($path->points(fill => 1)) {
395		return 0 unless $self->fillpoly($_);
396	}
397	return 1;
398}
399
400sub text_shape_out
401{
402	my ( $self, $text, $x, $y, $rtl) = @_;
403	my %flags = (skip_if_simple => 1);
404	$flags{rtl} = $rtl if defined $rtl;
405	if ( my $glyphs = $self->text_shape($text, %flags)) {
406		$text = $glyphs;
407	}
408	return $self->text_out( $text, $x, $y);
409}
410
411sub get_text_shape_width
412{
413	my ( $self, $text, $flags) = @_;
414	my %flags = (skip_if_simple => 1);
415	$flags{rtl} = $flags & to::RTL if defined $flags;
416	if ( my $glyphs = $self->text_shape($text, %flags)) {
417		$text = $glyphs;
418	}
419	return $self->get_text_width( $text, $flags // 0);
420}
421
422sub text_wrap_shape
423{
424	my ( $self, $text, $width, %opt) = @_;
425
426	my $opt    = delete($opt{options}) // tw::Default;
427	my $shaped = $self-> text_shape( $text, %opt );
428	return $self->text_wrap( $text, $width // -1, $opt, delete($opt{tabs}) // 8) unless $shaped;
429	my $ret    = $self-> text_wrap( $text, $width // -1, $opt, delete($opt{tabs}) // 8, 0, -1, $shaped);
430
431	if (( my $justify = delete $opt{justify} ) && $ret && @$ret ) {
432		if (
433			$justify->{kashida} &&
434			!($opt & tw::ReturnChunks) &&
435			$text =~ /[\x{600}-\x{6ff}]/
436		) {
437			my $last = @$ret - ($opt & (tw::CalcMnemonic | tw::CollapseTilde)) ? -2 : -1;
438			for ( my $i = 0; $i < $last; $i++) {
439				if ( $opt & tw::ReturnGlyphs ) {
440					$$ret[$i]->justify_arabic($self, $text, $width, %opt, %$justify);
441				} elsif ( my $tx = $self->text_shape( $$ret[$i], %opt)) {
442					my $text = $tx->justify_arabic($self, $$ret[$i], $width, %opt, %$justify, as_text => 1);
443					$$ret[$i] = $text if defined $text;
444				}
445			}
446		}
447
448		if (
449			($justify->{letter} || $justify->{word}) &&
450			!($opt & tw::ReturnChunks)
451		) {
452			# do not justify last (or the only) line
453			my $last = @$ret - ($opt & (tw::CalcMnemonic | tw::CollapseTilde)) ? -3 : -2;
454			for ( my $i = 0; $i < $last; $i++) {
455				if ( $opt & tw::ReturnGlyphs ) {
456					$$ret[$i]->justify_interspace($self, $text, $width, %opt, %$justify);
457				} elsif ( my $tx = $self->text_shape( $$ret[$i], %opt)) {
458					my $text = $tx->justify_interspace($self, $$ret[$i], $width, %opt, %$justify, as_text => 1);
459					$$ret[$i] = $text if defined $text;
460				}
461			}
462		}
463	}
464
465	return $ret;
466}
467
4681;
469
470=head1 NAME
471
472Prima::Drawable::Basic
473
474=head1 NAME
475
476Basic drawing routines for Prima::Drawable
477
478=cut
479