—

              
package SWF::Builder::Shape;
use strict;
use Carp;
use SWF::Element;
use SWF::Builder::ExElement;
use SWF::Builder::Gradient;
our $VERSION="0.01";
{
    package SWF::Builder::Shape;
    sub new {
        my $class = shift;
         
        my $self = bless {
            _current_line_width => 1,
            _current_X => 0,
            _current_Y => 0,
            _edges => SWF::Element::SHAPE->ShapeRecords->new,
            _bounds => SWF::Builder::ExElement::BoundaryRect->new,
        }, $class;
    }
    sub _set_bounds {
        my ($self, $x, $y) = @_;
        my $cw = $self->{_current_line_width} / 2;
        $self->{_bounds}->set_boundary($x-$cw, $y-$cw, $x+$cw, $y+$cw);
    }
    sub _get_stylerecord {
        my $self = shift;
        my $edges = $self->{_edges};
        my $r;
        if (ref($edges->[-1])=~/STYLECHANGERECORD$/) {
            $r = $edges->[-1];
        } else {
            $r = $edges->new_element;
            push @$edges, $r;
        }
        return $r;
    }
    sub r_lineto {
        my $self = shift;
        my $edges = $self->{_edges};    
        while (my($dx, $dy) = splice(@_, 0, 2)) {
            push @$edges, $edges->new_element( DeltaX => $dx*20, DeltaY => $dy*20 );
            $dx = ($self->{_current_X} += $dx);
            $dy = ($self->{_current_Y} += $dy);
            $self->_set_bounds($dx, $dy);
        }
        $self;
    }
    sub lineto {
        my $self = shift;
        my $edges = $self->{_edges};    
         
        while (my($x, $y) = splice(@_, 0, 2)) {
            push @$edges, $edges->new_element( DeltaX => ($x-$self->{_current_X})*20, DeltaY => ($y-$self->{_current_Y})*20 );
            $self->{_current_X} = $x;
            $self->{_current_Y} = $y;
            $self->_set_bounds($x, $y);
        }
        $self;
    }
    sub r_curveto {
        my $self = shift;
        my $edges = $self->{_edges};    
        while(my($cdx, $cdy, $adx, $ady) = splice(@_, 0, 4)) {
            my $curx = $self->{_current_X};
            my $cury = $self->{_current_Y};
         
            push @$edges, $edges->new_element
                (
                 ControlDeltaX => $cdx*20,
                 ControlDeltaY => $cdy*20,
                 AnchorDeltaX  => $adx*20,
                 AnchorDeltaY  => $ady*20,
                 );
            $adx = ($self->{_current_X} += $cdx+$adx);
            $ady = ($self->{_current_Y} += $cdy+$ady);
            $self->_set_bounds($adx, $ady);
            $self->_set_bounds($curx+$cdx, $cury+$cdy);
        }
        $self;
    }
    sub curveto {
        my $self = shift;
        my $edges = $self->{_edges};    
        while(my ($cx, $cy, $ax, $ay) = splice(@_, 0, 4)) {
            my $curx = $self->{_current_X};
            my $cury = $self->{_current_Y};
         
            push @$edges, $edges->new_element
                (
                 ControlDeltaX => ($cx-$curx)*20,
                 ControlDeltaY => ($cy-$cury)*20,
                 AnchorDeltaX  => ($ax-$cx)*20,
                 AnchorDeltaY  => ($ay-$cy)*20,
                 );
            $self->{_current_X} = $ax;
            $self->{_current_Y} = $ay;
            $self->_set_bounds($ax, $ay);
            $self->_set_bounds($cx, $cy);
        }
        $self;
    }
    sub moveto {
        my ($self, $x, $y)=@_;
        my $r = $self->_get_stylerecord;
         
        $r->MoveDeltaX($x*20);
        $r->MoveDeltaY($y*20);
        $self->{_current_X} = $x;
        $self->{_current_Y} = $y;
        $self->_set_bounds($x, $y);
        $self;
    }
    sub r_moveto {
        my ($self, $dx, $dy)=@_;
        my $r = $self->_get_stylerecord;
         
        $dx = ($self->{_current_X} += $dx);
        $dy = ($self->{_current_Y} += $dy);
        $r->MoveDeltaX($dx*20);
        $r->MoveDeltaY($dy*20);
        $self->_set_bounds($dx, $dy);
        $self;
    }
    sub box {
        my ($self, $x1, $y1, $x2, $y2) = @_;
        $self->moveto($x1,$y1)
            ->lineto($x2,$y1)
                ->lineto($x2,$y2)
                    ->lineto($x1,$y2)
                        ->lineto($x1,$y1);
    }
    my %style = ('none' => 0, 'fill' => 1, 'draw' => 1);
    sub fillstyle {
        my ($self, $f) = @_;
        my $r = $self->_get_stylerecord;
        my $index;
        if (exists $style{$f}) {
            $index = $style{$f};
        } else {
            $index = $f;
        }
        $r->FillStyle0($index);
        $self;
    }
    *fillstyle0 = \&fillstyle;
    sub fillstyle1 {
        my ($self, $f) = @_;
        my $r = $self->_get_stylerecord;
        my $index;
        if (exists $style{$f}) {
            $index = $style{$f};
        } else {
            $index = $f;
        }
        $r->FillStyle1($index);
        $self;
    }
    sub linestyle {
        my ($self, $f) = @_;
        my $r = $self->_get_stylerecord;
        my $index;
        if (exists $style{$f}) {
            $index = $style{$f};
        } else {
            $index = $f;
        }
        $r->LineStyle($index);
        $self;
    }
}
#####
{
    package SWF::Builder::Shape::DefineShape;
    @SWF::Builder::Shape::DefineShape::ISA = qw/ SWF::Builder::Shape SWF::Builder::Character::Displayable SWF::Builder::ExElement::Color::AddColor /;
    sub new {
        my $self = shift->SUPER::new;
        $self->SWF::Builder::Character::Displayable::_init;
        $self->SWF::Builder::ExElement::Color::AddColor::_init;
        $self->{_edges} = SWF::Element::SHAPEWITHSTYLE3->ShapeRecords->new;
        $self->{_current_line_width} = -1;
        $self->{_current_line_color} = undef;
        $self->{_current_fill_style} = '';
        $self->{_line_styles} = $self->{_shape_line_styles} = SWF::Element::SHAPEWITHSTYLE3->LineStyles->new;
        $self->{_line_style_hash} = {};
        $self->{_fill_styles} = $self->{_shape_fill_styles} = SWF::Element::SHAPEWITHSTYLE3->FillStyles->new;
        $self->{_fill_style_hash} = {};
        $self;
    }
    sub _add_gradient {
        my ($self, $gradient) = @_;
        $self->{_is_alpha}->configure($self->{_is_alpha}->value | $gradient->{_is_alpha}->value);
        return bless {
            _is_alpha => $self->{_is_alpha},
            _gradient => $gradient,
        }, 'SWF::Builder::Shape::Gradient';
    }
    sub linestyle {
        my $self = shift;
        my ($r, $index, $width, $color);
        $r = $self->_get_stylerecord;
        if ($_[0] eq 'none' or $_[0] eq 0) {
            $index = 0;
            $width = -1;
            $color = undef;
        } else {
            my %param;
            if ($_[0] eq 'Width' or $_[0] eq 'Color') {
                %param = @_;
            } else {
                %param = (Width => $_[0], Color => $_[1]);
            }
            $width = $param{Width};
            $width = $self->{_current_line_width} unless defined $width;
            if (defined $param{Color}) {
                $color = $self->_add_color($param{Color});
            } else {
                $color = $self->{_current_line_color};
            }
            return $self if ($width == $self->{_current_line_width} and $color eq $self->{_current_line_color});
             
            if (exists $self->{_line_style_hash}{"$width:$color"}) {
                $index = $self->{_line_style_hash}{"$width:$color"};
            } else {
                if (@{$self->{_line_styles}} >= 65534) {
                    $self->{_line_styles} = $r->LineStyles;
                    $self->{_line_style_hash} = {};
                    $self->{_fill_styles} = $r->FillStyles;
                    $self->{_fill_style_hash} = {};
                }
                my $ls = $self->{_line_styles};
                push @$ls, $ls->new_element(Width => $width*20, Color => $color);
                $index = $self->{_line_style_hash}{"$width:$color"} = @$ls;
            }
        }
        $r->LineStyle($index);
        $self->{_current_line_width} = $width;
        $self->{_current_line_color} = $color;
        $self;
    }
    sub _fillstyle {
        my $self = shift;
        my $setstyle = shift;
        my ($r, $index, $fillkey);
        $r = $self->_get_stylerecord;
        if ($_[0] eq 'none' or $_[0] eq 0) {
            $index = 0;
            return unless $self->{_current_fill_style};
            $fillkey = '';
        } else {
            my %param;
            if ($_[0] eq 'Color' or $_[0] eq 'Gradient' or $_[0] eq 'Bitmap') {
                %param = @_;
            } else {
                for (ref($_[0])) {
                    /Gradient/ and do {
                        %param = (Gradient => $_[0], Type => $_[1], Matrix => $_[2]);
                        last;
                    };
                    /Bitmap/ and do {
                        %param = (Bitmap => $_[0], Type => $_[1], Matrix => $_[2]);
                        last;
                    };
                    %param = (Color => $_[0]);
                }
            }
            my @param2;
            $fillkey = join(',', %param);
            if (exists $param{Gradient}) {
                push @param2, Gradient       => $self->_add_gradient($param{Gradient}),
                              FillStyleType  =>
                                 (lc($param{Type}) eq 'radial' ? 0x12 : 0x10), 
                              GradientMatrix => $param{Matrix};
  
            } elsif (exists $param{Bitmap}) {
                push @param2, BitmapID      => $param{Bitmap}->{ID},
                              FillStyleType =>
                                  (lc($param{Type}) =~ /^clip(ped)?$/ ? 0x41 : 0x40),
                              BitmapMatrix  => $param{Matrix};
                $self->{_is_alpha}->configure($self->{_is_alpha} | $param{Bitmap}{_is_alpha});
                $self->_depends($param{Bitmap});
            } else {
                push @param2, Color => $self->_add_color($param{Color}),
                              FillStyleType => 0x00;
            }
            return $self if $self->{_current_fill_style} eq $fillkey;
            if (exists $self->{_fill_style_hash}{$fillkey}) {
                $index = $self->{_fill_style_hash}{$fillkey};
            } else {
                if (@{$self->{_fill_styles}} >= 65534) {
                    $self->{_line_styles} = $r->LineStyles;
                    $self->{_line_style_hash} = {};
                    $self->{_fill_styles} = $r->FillStyles;
                    $self->{_fill_style_hash} = {};
                }
                my $fs = $self->{_fill_styles};
                push @$fs, $fs->new_element(@param2);
                $index = $self->{_fill_style_hash}{$fillkey} = @$fs;
            }
        }
        $r->$setstyle($index);
        $self->{_current_fill_style} = $fillkey;
        $self;
    }
    sub fillstyle {
        my $self = shift;
        _fillstyle($self, 'FillStyle0', @_);
    }
    *fillstyle0 = \&fillstyle;
    sub fillstyle1 {
        my $self = shift;
        _fillstyle($self, 'FillStyle1', @_);
    }
    sub get_bbox {
        return @{shift->{_bounds}};
    }
    sub pack {
        my ($self, $stream) = @_;
        $self->prepare_to_pack($stream) or return;
        my $tag = ($self->{_is_alpha} ? SWF::Element::Tag::DefineShape3->new : SWF::Element::Tag::DefineShape2->new);
        $tag->ShapeID($self->{ID});
        $tag->ShapeBounds($self->{_bounds});
        $tag->Shapes
            (
              FillStyles => $self->{_shape_fill_styles},
              LineStyles => $self->{_shape_line_styles},
              ShapeRecords =>$self->{_edges},
             );
        $tag->pack($stream);
    }
}
#####
{
    package SWF::Builder::Shape::Gradient;
    @SWF::Builder::Shape::Gradient::ISA = ('SWF::Element::Array::GRADIENT3');
    sub pack {
        my ($self, $stream) = @_;
        my $g = $self->{_gradient};
        my $a = $g->{_is_alpha}->value;
        $g->{_is_alpha}->configure($self->{_is_alpha});
        $g->pack($stream);
        $g->{_is_alpha}->configure($a);
    }
}
1;
__END__
HideShow 121 lines of Pod
=head1 NAME
SWF::Builder::Shape - SWF shape object
=head1 SYNOPSIS
  my $shape = $mc->new_shape
    ->fillstyle('ff0000')
    ->linestyle(1, '000000')
    ->moveto(0,-11)
    ->lineto(10,6)
    ->lineto(-10,6)
    ->lineto(0,-11);
  my @bbox = $shape->get_bbox;
=head1 DESCRIPTION
SWF shape is defined by a list of edges.
=over 4
=item $shape = $mc->new_shape
returns a new shape.
=item $shape->linestyle( [ Width => $width, Color => $color ] )
=item $shape->linestyle( $width, $color )
=item $shape->linestyle( 'none' )
sets line width and color. The color can take a six or eight-figure
hexadecimal string, an array reference of R, G, B, and optional alpha value, 
an array reference of named parameters such as [Red => 255],
and SWF::Element::RGB/RGBA object.
If you set the style 'none', edges are not drawn.
=item $shape->fillstyle( [ Color => $color / Gradient => $gradient, Type => $type, Matrix => $matrix / Bitmap => $bitmap, Type => $type, Matrix => $matrix ] )
=item $shape->fillstyle( $color )
=item $shape->fillstyle( $gradient, $type, $matrix )
=item $shape->fillstyle( $bitmap, $type, $matrix )
=item $shape->fillstyle( 'none' )
sets a fill style.
$color is a solid fill color. 
See $shape->linestyle for the acceptable color value.
$gradient is a gradient object. Give $type 'radial' to fill with 
radial gradient, otherwise linear.
$matrix is a matrix to transform the gradient. 
See L<SWF::Builder::Gradient>.
$bitmap is a bitmap character. Give $type 'clipped' to fill with 
clipped bitmap, otherwise tiled.
$matrix is a matrix to transform the bitmap. 
See L<SWF::Builder::Bitmap>.
=item $shape->fillstyle0( ... )
identical to $shape->fillstyle.
=item $shape->fillstyle1( ... )
sets an additional fillstyle used in self-overlap shape.
=item $shape->moveto( $x, $y )
moves the draw point to ($x, $y).
=item $shape->r_moveto( $dx, $dy )
moves the draw point to ( current X + $dx, current Y + $dy ).
=item $shape->lineto( $x, $y )
draws a line from the current draw point to ($x, $y)
=item $shape->r_lineto( $dx, $dy )
draws a line from the current draw point to ( current X + $dx, current Y + $dy ).
=item $shape->curveto( $cx, $cy, $ax, $ay )
draws a quadratic bezier curve from the current draw point to ($ax, $ay)
using ($cx, $cy) as the control point.
=item $shape->r_curveto( $cdx, $cdy, $adx, $ady )
draws a quadratic bezier curve from the current draw point to 
(current X + $cdx+$adx, current Y + $cdy+$ady)
using (current X + $cdx, current Y + $cdy) as the control point.
=item $shape->box( $x1, $y1, $x2, $y2 )
draws a box. The draw point is moved to ($x1, $y1) after drawing.
=item $shape->get_bbox
returns the bounding box of the shape, a list of coordinates
( top-left X, top-left Y, bottom-right X, bottom-right Y ).
=item $disp_i = $shape->place( ... )
returns the display instance of the shape. See L<SWF::Builder>.
=back
=head1 COPYRIGHT
Copyright 2003 Yasuhiro Sasama (ySas), <ysas@nmt.ne.jp>
This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=cut