1package SWF::Builder::Character::Shape; 2 3use strict; 4use Carp; 5use SWF::Element; 6use SWF::Builder::Character; 7use SWF::Builder::ExElement; 8use SWF::Builder::Gradient; 9use SWF::Builder::Shape; 10 11our $VERSION="0.05"; 12 13@SWF::Builder::Character::Shape::ISA = qw/ SWF::Builder::Character::UsableAsMask /; 14@SWF::Builder::Character::Shape::Imported::ISA = qw/ SWF::Builder::Character::Imported SWF::Builder::Character::Shape /; 15 16{ 17 package SWF::Builder::Character::Shape::Def; 18 19 use SWF::Builder::ExElement; 20 21 @SWF::Builder::Character::Shape::Def::ISA = qw/ SWF::Builder::Shape SWF::Builder::Character::Shape SWF::Builder::ExElement::Color::AddColor /; 22 23 sub new { 24 my $self = shift->SUPER::new; 25 } 26 27 sub _init { 28 my $self = shift; 29 $self->_init_character; 30 $self->_init_is_alpha; 31 32 $self->{_edges} = SWF::Element::SHAPEWITHSTYLE3->ShapeRecords->new; 33 $self->{_current_line_width} = -1; 34 $self->{_current_line_color} = ''; 35 $self->{_current_FillStyle0} = ''; 36 $self->{_current_FillStyle1} = ''; 37 $self->{_line_styles} = $self->{_shape_line_styles} = SWF::Element::SHAPEWITHSTYLE3->LineStyles->new; 38 $self->{_line_style_hash} = {}; 39 $self->{_fill_styles} = $self->{_shape_fill_styles} = SWF::Element::SHAPEWITHSTYLE3->FillStyles->new; 40 $self->{_fill_style_hash} = {}; 41 $self->{_links} = []; 42 43 $self; 44 } 45 46 sub _add_gradient { 47 my ($self, $gradient) = @_; 48 49 $self->{_is_alpha}->configure($self->{_is_alpha}->value | $gradient->{_is_alpha}->value); 50 return bless { 51 _is_alpha => $self->{_is_alpha}, 52 _gradient => $gradient, 53 }, 'SWF::Builder::Shape::Gradient'; 54 } 55 56 sub linestyle { 57 my $self = shift; 58 my ($index, $width, $color); 59 60 if ($_[0] eq 'none' or $_[0] eq 0) { 61 $index = 0; 62 $width = -1; 63 $color = ''; 64 } else { 65 my %param; 66 if ($_[0] eq 'Width' or $_[0] eq 'Color') { 67 %param = @_; 68 } else { 69 %param = (Width => $_[0], Color => $_[1]); 70 } 71 $width = $param{Width}; 72 $width = $self->{_current_line_width} unless defined $width; 73 if (defined $param{Color}) { 74 $color = $self->_add_color($param{Color}); 75 } else { 76 $color = $self->{_current_line_color}; 77 } 78 return $self if ($width == $self->{_current_line_width} and $color eq $self->{_current_line_color}); 79 80 if (exists $self->{_line_style_hash}{"$width:$color"}) { 81 $index = $self->{_line_style_hash}{"$width:$color"}; 82 } else { 83 if (@{$self->{_line_styles}} >= 65534) { 84 my $r = $self->_get_stylerecord; 85 $self->{_line_styles} = $r->LineStyles; 86 $self->{_line_style_hash} = {}; 87 $self->{_fill_styles} = $r->FillStyles; 88 $self->{_fill_style_hash} = {}; 89 } 90 my $ls = $self->{_line_styles}; 91 push @$ls, $ls->new_element(Width => $width*20, Color => $color); 92 $index = $self->{_line_style_hash}{"$width:$color"} = @$ls; 93 } 94 } 95 $self->_set_style(LineStyle => $index); 96 $self->{_current_line_width} = $width; 97 $self->{_current_line_color} = $color; 98 $self; 99 } 100 101 sub _fillstyle { 102 my $self = shift; 103 my $setstyle = shift; 104 my ($index, $fillkey); 105 106 if ($_[0] eq 'none' or $_[0] eq 0) { 107 $index = 0; 108 $fillkey = ''; 109 } else { 110 my %param; 111 if ($_[0] eq 'Color' or $_[0] eq 'Gradient' or $_[0] eq 'Bitmap') { 112 %param = @_; 113 } else { 114 for (ref($_[0])) { 115 /Gradient/ and do { 116 %param = (Gradient => $_[0], Type => $_[1], Matrix => $_[2]); 117 last; 118 }; 119 /Bitmap/ and do { 120 %param = (Bitmap => $_[0], Type => $_[1], Matrix => $_[2]); 121 last; 122 }; 123 %param = (Color => $_[0]); 124 } 125 } 126 my @param2; 127 128 $fillkey = join(',', %param); 129 if (exists $param{Gradient}) { 130 unless (UNIVERSAL::isa($param{Matrix}, 'SWF::Builder::ExElement::MATRIX')) { 131 $param{Matrix} = SWF::Builder::ExElement::MATRIX->new->init($param{Matrix}); 132 } 133 push @param2, Gradient => $self->_add_gradient($param{Gradient}), 134 FillStyleType => 135 (lc($param{Type}) eq 'radial' ? 0x12 : 0x10), 136 GradientMatrix => $param{Matrix}; 137 138 } elsif (exists $param{Bitmap}) { 139 unless (UNIVERSAL::isa($param{Matrix}, 'SWF::Builder::ExElement::MATRIX')) { 140 my $m = $param{Bitmap}->matrix; 141 $m->init($param{Matrix}) if defined $param{Matrix}; 142 $param{Matrix} = $m; 143 } 144 push @param2, BitmapID => $param{Bitmap}->{ID}, 145 FillStyleType => 146 (lc($param{Type}) =~ /^clip(ped)?$/ ? 0x41 : 0x40), 147 BitmapMatrix => $param{Matrix}; 148 $self->{_is_alpha}->configure($self->{_is_alpha} | $param{Bitmap}{_is_alpha}); 149 $self->_depends($param{Bitmap}); 150 } else { 151 push @param2, Color => $self->_add_color($param{Color}), 152 FillStyleType => 0x00; 153 } 154 155 return $self if $self->{"_current_$setstyle"} eq $fillkey; 156 157 if (exists $self->{_fill_style_hash}{$fillkey}) { 158 $index = $self->{_fill_style_hash}{$fillkey}; 159 } else { 160 if (@{$self->{_fill_styles}} >= 65534) { 161 my $r = $self->_get_stylerecord; 162 $self->{_line_styles} = $r->LineStyles; 163 $self->{_line_style_hash} = {}; 164 $self->{_fill_styles} = $r->FillStyles; 165 $self->{_fill_style_hash} = {}; 166 } 167 my $fs = $self->{_fill_styles}; 168 push @$fs, $fs->new_element(@param2); 169 $index = $self->{_fill_style_hash}{$fillkey} = @$fs; 170 } 171 } 172 $self->_set_style($setstyle => $index); 173 $self->{"_current_$setstyle"} = $fillkey; 174 $self; 175 } 176 177 sub fillstyle { 178 my $self = shift; 179 _fillstyle($self, 'FillStyle0', @_); 180 } 181 182 *fillstyle0 = \&fillstyle; 183 184 sub fillstyle1 { 185 my $self = shift; 186 _fillstyle($self, 'FillStyle1', @_); 187 } 188 189 sub anchor { 190 my ($self, $anchor) = @_; 191 192 $self->{_anchors}{$anchor} = [$#{$self->{_edges}}, $self->{_current_X}, $self->{_current_Y}, $#{$self->{_links}}]; 193 $self->{_last_anchor} = $anchor; 194 $self; 195 } 196 197 sub _set_bounds { 198 my ($self, $x, $y, $f) = @_; 199 $self->SUPER::_set_bounds($x, $y); 200 return if $f; 201 202 if (defined $self->{_links}[-1]) { 203# my $cw = $self->{_current_line_width} * 10; 204 my $m = $self->{_links}[-1]; 205# $m->[6]->set_boundary($x-$cw, $y-$cw, $x+$cw, $y+$cw); 206 my (undef, $tlx, $tly) = @{$m->[5]}; 207 if ($x*$x+$y*$y < $tlx*$tlx+$tly*$tly) { 208 $m->[5] = [$#{$self->{_edges}}, $x, $y]; 209 } 210 } 211 } 212 213 sub _set_style { 214 my ($self, %param) = @_; 215 216 if (exists $param{MoveDeltaX} and defined $self->{_links}[-1]) { 217 my $m = $self->{_links}[-1]; 218 $m->[1] = $#{$self->{_edges}}; 219 $m->[3] = $self->{_current_X}; 220 $m->[4] = $self->{_current_Y}; 221 } 222 223 my $r = $self->SUPER::_set_style(%param); 224 225 if (exists $param{MoveDeltaX}) { 226 my ($x, $y) = ($param{MoveDeltaX}, $param{MoveDeltaY}); 227 my @linkinfo = 228 ($#{$self->{_edges}}, # start edge index 229 undef, # last continuous edge index 230 [$#{$self->{_edges}}], # STYLECHANGERECORD indice 231 undef, # last X 232 undef, # last Y 233 [$#{$self->{_edges}}, $x, $y], # top left 234# SWF::Builder::ExElement::BoundaryRect->new, # boundary 235 ); 236 if (exists $self->{_links}[-1] and $self->{_links}[-1][0] == $linkinfo[0]) { 237 $self->{_links}[-1] = \ @linkinfo; 238 } else { 239 push @{$self->{_links}}, \ @linkinfo; 240 } 241 if (defined $self->{_last_anchor}) { 242 my $last_anchor = $self->{_anchors}{$self->{_last_anchor}}; 243 if ($last_anchor->[0] == $#{$self->{_edges}} or $last_anchor->[0] == $#{$self->{_edges}}-1) { 244 $last_anchor->[0] = $#{$self->{_edges}}; 245 $last_anchor->[1] = $x; 246 $last_anchor->[2] = $y; 247 $last_anchor->[3] = $#{$self->{_links}}; 248 } 249 } 250 $r->LineStyle($self->{_line_style_hash}{$self->{_current_line_width}.':'.$self->{_current_line_color}}) unless defined $r->LineStyle; 251 $r->FillStyle0($self->{_fill_style_hash}{$self->{_current_FillStyle0}}) unless defined $r->FillStyle0; 252 $r->FillStyle1($self->{_fill_style_hash}{$self->{_current_FillStyle1}}) unless defined $r->FillStyle1; 253 } else { 254 push @{$self->{_links}[-1][2]}, $#{$self->{_edges}} if $self->{_links}[-1][2][-1] != $#{$self->{_edges}}; 255 } 256 $r; 257 } 258 259 sub _pack { 260 my ($self, $stream) = @_; 261 262 my $tag = ($self->{_is_alpha} ? SWF::Element::Tag::DefineShape3->new : SWF::Element::Tag::DefineShape2->new); 263 $tag->ShapeID($self->{ID}); 264 $tag->ShapeBounds($self->{_bounds}); 265 $tag->Shapes 266 ( 267 FillStyles => $self->{_shape_fill_styles}, 268 LineStyles => $self->{_shape_line_styles}, 269 ShapeRecords =>$self->{_edges}, 270 ); 271 $tag->pack($stream); 272 } 273} 274 275##### 276 277{ 278 package SWF::Builder::Shape::Gradient; 279 280 @SWF::Builder::Shape::Gradient::ISA = ('SWF::Element::Array::GRADIENT3'); 281 282 sub pack { 283 my ($self, $stream) = @_; 284 285 my $g = $self->{_gradient}; 286 my $a = $g->{_is_alpha}->value; 287 $g->{_is_alpha}->configure($self->{_is_alpha}); 288 $g->pack($stream); 289 $g->{_is_alpha}->configure($a); 290 } 291} 292 2931; 294__END__ 295 296 297=head1 NAME 298 299SWF::Builder::Character::Shape - SWF shape character. 300 301=head1 SYNOPSIS 302 303 my $shape = $mc->new_shape 304 ->fillstyle('ff0000') 305 ->linestyle(1, '000000') 306 ->moveto(0,-11) 307 ->lineto(10,6) 308 ->lineto(-10,6) 309 ->lineto(0,-11); 310 my @bbox = $shape->get_bbox; 311 312=head1 DESCRIPTION 313 314SWF shape is defined by a list of edges. Set linestyle for the edges and 315fillstyle to fill the enclosed area, and draw edges with 'pen' 316which has own drawing position. 317Most drawing methods draw from the current pen position and move the pen 318to the last drawing position. 319 320=head2 Coordinate System 321 322The positive X-axis points toward right, and the Y-axis points toward down. 323All angles are measured clockwise. 324Placing, scaling, and rotating the display instance of the shape are based 325on the origin of the shape coodinates. 326 327=head2 Creator and Display Method 328 329=over 4 330 331=item $shape = $mc->new_shape 332 333returns a new shape character. 334 335=item $disp_i = $shape->place( ... ) 336 337returns the display instance of the shape. See L<SWF::Builder>. 338 339=back 340 341=head2 Methods to Draw Edges 342 343All drawing methods return $shape itself. You can call these methods successively. 344 345=over 4 346 347=item $shape->linestyle( [ Width => $width, Color => $color ] ) 348 349=item $shape->linestyle( $width, $color ) 350 351=item $shape->linestyle( 'none' ) 352 353sets line width and color. The color can take a six or eight-figure 354hexadecimal string, an array reference of R, G, B, and optional alpha value, 355an array reference of named parameters such as [Red => 255], 356and SWF::Element::RGB/RGBA object. 357If you set the style 'none', edges are not drawn. 358 359=item $shape->fillstyle( [ Color => $color / Gradient => $gradient, Type => $type, Matrix => $matrix / Bitmap => $bitmap, Type => $type, Matrix => $matrix ] ) 360 361=item $shape->fillstyle( $color ) 362 363=item $shape->fillstyle( $gradient, $type, $matrix ) 364 365=item $shape->fillstyle( $bitmap, $type, $matrix ) 366 367=item $shape->fillstyle( 'none' ) 368 369sets a fill style. 370 371$color is a solid fill color. 372See $shape->linestyle for the acceptable color value. 373 374$gradient is a gradient object. Give $type 'radial' to fill with 375radial gradient, otherwise linear. 376$matrix is a matrix to transform the gradient. 377See L<SWF::Builder::Gradient>. 378 379$bitmap is a bitmap character. Give $type 'clipped' to fill with 380clipped bitmap, otherwise tiled. 381$matrix is a matrix to transform the bitmap. 382See L<SWF::Builder::Character::Bitmap>. 383 384=item $shape->fillstyle0( ... ) 385 386synonym of $shape->fillstyle. 387 388=item $shape->fillstyle1( ... ) 389 390sets an additional fillstyle used in self-overlap shape. 391 392=item $shape->moveto( $x, $y ) 393 394moves the pen to ($x, $y). 395 396=item $shape->r_moveto( $dx, $dy ) 397 398moves the pen relatively to ( current X + $dx, current Y + $dy ). 399 400=item $shape->lineto( $x, $y [, $x2, $y2, ...] ) 401 402draws a connected line to ($x, $y), ($x2, $y2), ... 403 404=item $shape->r_lineto( $dx, $dy [, $dx2, $dy2, ...] ) 405 406draws a connected line relatively to ( current X + $dx, current Y + $dy ), 407( former X + $dx2, former Y + $dy2 ), ... 408 409=item $shape->curveto( $cx, $cy, $ax, $ay [,$cx2, $cy2, $ax2, $ay2, ...] ) 410 411draws a quadratic Bezier curve to ($ax, $ay) 412using ($cx, $cy) as the control point. 413 414=item $shape->r_curveto( $cdx, $cdy, $adx, $ady [,$cdx2, $cdy2, $adx2, $ady2, ...] ) 415 416draws a quadratic Bezier curve to 417(current X + $cdx+$adx, current Y + $cdy+$ady) 418using (current X + $cdx, current Y + $cdy) as the control point. 419 420=item $shape->curve3to( $cx1, $cy1, $cx2, $cy2, $ax, $ay [, ...] ) 421 422draws a cubic Bezier curve to ($ax, $ay) using ($cx1, $cy1) and 423($cx2, $cy2) as control points. 424 425=item $shape->r_curve3to( $cdx1, $cdy1, $cdx2, $cdy2, $adx, $ady [, ...] ) 426 427draws a cubic Bezier curve to (current X + $cx1 + $cx2 + $ax, current Y + $cy1 + $cy2 + $ay) 428using (current X + $cx1, current Y + $cy1) and (current X + $cx1 + $cx2, current Y + $cy1 + $cy2) as control points. 429 430=item $shape->arcto( $startangle, $centralangle, $rx [, $ry [, $rot]] ) 431 432draws an elliptic arc from the current pen position. 433$startangle is the starting angle of the arc in degrees. 434$centralangle is the central angle of the arc in degrees. 435$rx and $ry are radii of the full ellipse. If $ry is not specified, 436a circular arc is drawn. 437Optional $rot is the rotation angle of the full ellipse. 438 439=item $shape->radial_moveto( $r, $theta ) 440 441moves the pen from the current position to distance $r and angle $theta in degrees 442measured clockwise from X-axis. 443 444=item $shape->r_radial_moveto( $r, $dtheta ) 445 446moves the pen from the current position to distance $r and angle $dtheta in degrees 447measured clockwise from the current direction. 448The current direction is calculated from the start point of 449the last line segment or the control point of the last curve segment, 450and is reset to 0 when the pen was moved without drawing. 451 452=item $shape->radial_lineto( $r, $theta [, $r2, $theta2,... ] ) 453 454draws a line from the current position to distance $r and angle $theta 455measured clockwise from X-axis in degrees. 456 457=item $shape->r_radial_lineto( $r, $dtheta [, $r2, $dtheta2,... ] ) 458 459draws a line from the current position to distance $r and angle $dtheta 460measured clockwise from the current direction in degrees. 461The current direction is calculated from the start point of 462the last line segment or the control point of the last curve segment, 463and is reset to 0 when the pen was moved without drawing. 464 465=item $shape->close_path() 466 467closes the path drawn by '...to' commands. 468This draws a line to the position set by the last '*moveto' command. 469After drawing shapes or text by the methods described the next section, 470'close_path' may not work properly because those methods may use 'moveto' internally. 471 472=back 473 474=head2 Methods to Draw Shapes and Texts 475 476 477 478=over 4 479 480=item $shape->font( $font ) 481 482applies the font to the following text. 483$font is an SWF::Builder::Font object. 484 485=item $shape->size( $size ) 486 487sets a font size to $size in pixel. 488 489=item $text->text( $string ) 490 491draws the $string with the current Y coordinate as the baseline 492and moves the pen to the position which the next letter will be written. 493 494=item $shape->box( $x1, $y1, $x2, $y2 ) 495 496draws a rectangle from ($x1, $y1) to ($x2, $y2) and moves the pen to ($x1, $y1). 497 498=item $shape->rect( $w, $h, [, $rx [, $ry]] ) 499 500draws a rectangle with width $w and height $h from the current position. 501If optional $rx is set, draws a rounded rectangle. $rx is a corner radius. 502You can also set $ry, elliptic Y radius ($rx for X radius). 503The pen does not move after drawing. 504 505=item $shape->circle( $r ) 506 507draws a circle with radius $r. 508The current pen position is used as the center. 509The pen does not move after drawing. 510 511=item $shape->ellipse( $rx, $ry [, $rot] ) 512 513draws an ellipse with radii $rx and $ry. 514The current pen position is used as the center. 515Optional $rot is a rotation angle. 516The pen does not move after drawing. 517 518=item $shape->starshape( $size [, $points [, $thickness [, $screw]]] ) 519 520draws a $points pointed star shape with size $size. 521The current pen position is used as the center. 522If $points is not specified, 5-pointed star (pentagram) is drawn. 523 524Optional $thickness can take a number 0(thin) to 2(thick). 5250 makes to draw lines like spokes and 2 makes to draw a convex polygon. 526Default is 1. 527 528Optional $screw is an angle to screw the concave corners of 529the star in degrees. 530 531The pen does not move after drawing. 532 533=item $shape->path( $pathdata ) 534 535draws a path defined by $pathdata. 536$pathdata is a string compatible with 'd' attribute in 'path' element of SVG. 537See SVG specification for details. 538 539=back 540 541=head2 Methods for Pen Position and Coordinates 542 543=over 4 544 545=item $shape->get_bbox 546 547returns the bounding box of the shape, a list of coordinates 548( top-left X, top-left Y, bottom-right X, bottom-right Y ). 549 550=item $shape->get_pos 551 552returns the current pen position ($x, $y). 553 554=item $shape->push_pos 555 556pushes the current pen position onto the internal stack. 557 558=item $shape->pop_pos 559 560pops the pen position from the internal stack and move there. 561 562=item $shape->lineto_pop_pos 563 564pops the pen position from the internal stack and draw line to there. 565 566=item $shape->transform( \@matrix_options [, \&sub] ) 567 568transforms the coordinates for subsequent drawings by the matrix. 569Matrix options are pairs of a keyword and a scalar parameter or 570array reference of coordinates list, as follows: 571 572 scale => $scale or [$scalex, $scaley] # scales up/down by $scale. 573 rotate => $angle # rotate $angle degree clockwise. 574 translate => [$x, $y] # translate coordinates to ($x, $y) 575 moveto => [$x, $y] # same as 'translate' 576 577 and all SWF::Element::MATRIX fields 578 ( ScaleX / ScaleY / RotateSkew0 / RotateSkew1 / TranslateX / TranslateY ). 579 580ATTENTION: 'translate/moveto' takes coordinates in pixel, while 'TranslateX' and 'TranslateY' in TWIPS (20 TWIPS = 1 pixel). 581 582If &sub is specified, this method calls &sub with a shape object 583with transformed coordinates, and return the original, untransformed shape object. 584Otherwise, it returns a transformed shape object. 585You may need to call 'end_transform' to stop transformation. 586 587This method does not affect either paths drawn before or the current pen position. 588 589=item $tx_shape->end_transform 590 591stops transformation of the coordinates and returns the original shape object. 592 593=back 594 595=head1 COPYRIGHT 596 597Copyright 2003 Yasuhiro Sasama (ySas), <ysas@nmt.ne.jp> 598 599This library is free software; you can redistribute it 600and/or modify it under the same terms as Perl itself. 601 602=cut 603