home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Non-RPC
/
!Perl
/
riscos
/
RISCOS
/
DrawFile
/
Path.pm
< prev
next >
Wrap
Text File
|
1999-01-20
|
10KB
|
362 lines
package RISCOS::DrawFile::Path;
use strict;
use vars qw ($VERSION @ISA %winding @winding @winding_map);
@ISA = 'RISCOS::DrawFile::Object';
require RISCOS::DrawFile::Object;
use RISCOS::Draw qw(what unwhat pack_dash_block pack_path_block split_path_block
path_bbox split_dash_block path_transform);
use RISCOS::Colour qw(pack_colour unpack_colour);
$VERSION = 0.02;
# 0.02 PrePack calls BBox not BBox calc
# These differ from Draw. (ie the Draw module, as in RISCOS::Draw)
%winding = ('non-zero' => 0, 'even-odd' => 1);
@winding = ('non-zero', 'even-odd');
@winding_map = (0, 2);
### use SelfLoader;
sub RISCOS::DrawFile::Path::new ($$);
sub RISCOS::DrawFile::Path::Type ;
sub RISCOS::DrawFile::Path::BBox_Calc ;
sub RISCOS::DrawFile::Path::Translate ;
sub RISCOS::DrawFile::Path::Size ;
sub RISCOS::DrawFile::Path::PrePack ;
sub RISCOS::DrawFile::Path::Pack ;
sub RISCOS::DrawFile::Path::PackPathBlock ;
sub RISCOS::DrawFile::Path::PackDashBlock ;
sub RISCOS::DrawFile::Path::FillColour ;
sub RISCOS::DrawFile::Path::LineColour ;
sub RISCOS::DrawFile::Path::Width ;
sub RISCOS::DrawFile::Path::Join ;
sub RISCOS::DrawFile::Path::StartCap ;
sub RISCOS::DrawFile::Path::EndCap ;
sub RISCOS::DrawFile::Path::Wind ;
sub RISCOS::DrawFile::Path::Dash ;
sub RISCOS::DrawFile::Path::rectangle ;
sub RISCOS::DrawFile::Path::join_the_dots ;
1;
### __DATA__
sub new ($$) {
my $proto = shift;
my $class = ref($proto) || $proto;
my ($self, $type) = $class->SUPER::new (@_);
return $self if ref ($self) eq 'ARRAY';
my ($tri_w, $tri_l, $fill_col, $line_col, $width, $join, $start, $end,
$winding, $dash) = (1, 2);
return wantarray ? () : undef unless defined $_[0];
if (ref $_[0] eq 'ARRAY') {
my ($cols0, $path);
($path, $fill_col, $line_col, $width, $join, $start, $end, $winding,
$dash) = @{$_[0]};
$width ||= 0;
$join = what ('join', 2, $join);
$line_col = 0 unless defined $line_col or defined $fill_col;
($fill_col, $line_col) = pack_colour ($fill_col, $line_col);
if (ref ($start) eq 'ARRAY') {
($tri_w, $tri_l) = @$start;
$start = 3;
} else {
$start = what ('cap', 0, $start);
}
if (ref ($end) eq 'ARRAY') {
($tri_w, $tri_l) = @$start;
$end = 3;
} else {
$end = what ('cap', 0, $end);
}
$winding = what (\*winding, 0, $winding);
# use local winding names
@{$self->{'__PATH'}} = pack_path_block ($path);
} else {
# Time to unpack data
my $data;
if (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'LVALUE') {
# Has bounding box stripped
$data = ${$_[0]};
} else {
my $length;
($length, @{$self->{'__BBOX'}}) = unpack 'x4Ii4', $_[0];
return undef unless length ($_[0]) == $length or $length & 3;
$data = substr $_[0], 24;
}
my $style;
($fill_col, $line_col, $width, $style, $tri_w, $tri_l)
= unpack 'a4a4ICxC2', $data;
$tri_w /= 16;
$tri_l /= 16;
$join = $style & 3;
$start = ($style >> 2) & 3; # PRM lies. Start *is* first.
$end = ($style >> 4) & 3;
$winding = ($style >> 6) & 1;
if ($style & 0x80) {
$dash = unpack 'x20I', $data; # Get number of elements
$dash = substr $data, 16, 8 + 4 * $dash;
# Ref to scalar will be 'packed' by spitting
$self->{'__PATH'} = substr $data, 16 + length $dash;
} else {
$self->{'__PATH'} = substr $data, 16;
}
}
# Leave it uncalculated
# $self->{'__BBOX'} = $bbox;
$self->{'__FILLC'} = $fill_col;
$self->{'__LINEC'} = $line_col;
$self->{'__WIDTH'} = $width;
$self->{'__JOIN'} = $join;
$self->{'__START'} = $start;
$self->{'__END'} = $end;
$self->{'__TRIW'} = $tri_w;
$self->{'__TRIL'} = $tri_l;
$self->{'__WIND'} = $winding;
$self->{'__DASH'} = $dash;
wantarray ? ($self, $type) : $self;
}
sub Type { 2; }
sub BBox_Calc {
my $self = shift;
$self->{'__BBOX'} = path_bbox ($self->{'__PATH'}, $self->{'__WIND'}, undef,
$self->{'__WIDTH'}, $self->{'__JOIN'},
(($self->{'__START'} == 3)
? [$self->{'__TRIW'}, $self->{'__TRIL'}]
: $self->{'__START'}),
(($self->{'__END'} == 3)
? [$self->{'__TRIW'}, $self->{'__TRIL'}]
: $self->{'__END'}), $self->{'__DASH'});
}
sub Translate {
my ($self, $x, $y) = @_;
my $bbox = $self->{'__BBOX'};
if (defined $bbox) {
$$bbox[0] += $x;
$$bbox[1] += $y;
$$bbox[2] += $x;
$$bbox[3] += $y;
}
$self->{'__PATH'} = path_transform $self->{'__PATH'}, [1,0,0,1,$x,$y];
();
}
sub Size {
my $self = shift;
my $path = $self->{'__PATH'};
40 + (defined ($self->{'__DASH'})
? length pack_dash_block ($self->{'__DASH'})
: 0) + length (ref ($path) ? pack_path_block ($path) : $path);
}
sub PrePack {
my $self = shift;
$self->PackPathBlock; # Make things fast.
$self->PackDashBlock;
$self->BBox (@_);
}
sub Pack {
my $self = shift;
my $dash = pack_dash_block ($self->{'__DASH'});
$self->PackPathBlock(); # Make sure its a scalar
my $style = 0;
if (defined $dash) {
$style = 0x80 if length $dash;
} else {
$dash = '';
}
$style |= ($self->{'__JOIN'} & 3) | (($self->{'__START'} & 3) << 2)
| (($self->{'__END'} & 3) << 4) | (($self->{'__WIND'} & 1) << 6);
$self->PackTypeSizeBBox(2)
. pack ('a4a4ICxC2', $self->{'__FILLC'}, $self->{'__LINEC'},
$self->{'__WIDTH'}, $style, 16 * $self->{'__TRIW'},
16 * $self->{'__TRIL'})
. $dash . $self->{'__PATH'} # It has to be a scalar now
}
# Ensures that the path is in the form of an array of scalars that can be
# concatenated into a path block.
sub PackPathBlock {
my $self = shift;
my $path = $self->{'__PATH'};
return wantarray ? split_path_block ($path) : $path
unless (ref $path);
return $self->{'__PATH'} = pack_path_block $path unless wantarray;
# OK, it's a reference to something, and array context return is wanted.
my (@result) = pack_path_block $path;
$self->{'__PATH'} = join '', @result;
@result;
}
sub PackDashBlock {
my $self = shift;
$self->{'__DASH'} = pack_dash_block ($self->{'__DASH'});
}
sub FillColour {
my $self = shift;
my $old = $self->{'__FILLC'};
# Need to be able to pass in undef
$self->{'__FILLC'} = &pack_colour if @_;
unpack_colour $old;
}
sub LineColour {
my $self = shift;
my $old = $self->{'__LINEC'};
# Need to be able to pass in undef
$self->{'__LINEC'} = &pack_colour if @_;
unpack_colour $old;
}
sub Width {
my $self = shift;
my $old = $self->{'__WIDTH'};
if (@_) {
$self->{'__WIDTH'} = $_[0];
undef $self->{'__BBOX'}
}
$old;
}
sub Join {
my $self = shift;
my $old = unwhat ('join', undef, $self->{'__JOIN'});
if (@_) {
$self->{'__JOIN'} = what ('join', 2, $_[0]);
}
$old;
}
sub StartCap {
my $self = shift;
my @old = (unwhat ('cap', undef, $self->{'__START'}),
$self->{'__TRIW'}, $self->{'__TRIL'});
if (@_) {
my $start = shift;
if (ref ($start) eq 'ARRAY') {
($self->{'__TRIW'}, $self->{'__TRIL'}) = @$start;
$start = 3;
} else {
$start = what ('cap', 0, $start);
}
$self->{'__START'} = $start;
undef $self->{'__BBOX'}
}
wantarray ? @old : $old[0];
}
sub EndCap {
my $self = shift;
my @old = (unwhat ('cap', undef, $self->{'__END'}),
$self->{'__TRIW'}, $self->{'__TRIL'});
if (@_) {
my $end = shift;
if (ref ($end) eq 'ARRAY') {
($self->{'__TRIW'}, $self->{'__TRIL'}) = @$end;
$end = 3;
} else {
$end = what ('cap', 0, $end);
}
$self->{'__END'} = $end;
undef $self->{'__BBOX'}
}
wantarray ? @old : $old[0];
}
sub Wind {
my $self = shift;
my $old = unwhat (\*winding, undef, $self->{'__WIND'});
if (@_) {
$self->{'__WIND'} = what (\*winding, 0, $_[0]) if @_;
undef $self->{'__BBOX'}
}
$old;
}
sub Dash {
my $self = shift;
my $old = $self->{'__DASH'};
if (@_) {
$self->{'__DASH'} = $_[0] if @_;
undef $self->{'__BBOX'}
}
split_dash_block ($old);
}
#$path, $fill_col, $line_col, $width, $join, $start, $end, $winding, $dash
sub rectangle {
my ($x0, $y0, $x1, $y1) = @{shift @_};
$y1 = $y0 + $x1 - $x0 unless defined $y1;
# The implicit pass by reference bites sometimes.
unshift @_,
# [[2, $x0, $y0], [8, $x1, $y0], [8, $x1, $y1], [8, $x0, $y1], [5]];
[[2, $x0, $y0, 8, $x1, $y0, 8, $x1, $y1, 8, $x0, $y1, 5]]; # Cheat!
RISCOS::DrawFile::Path->new (\@_);
}
#$path, $scale, $close, $fill_col, $line_col, $width, $join, $start, $end, $winding, $dash
sub join_the_dots {
my $inpath = shift;
my $scale = shift || 1;
my $close = shift;
my $path = [2];
my ($x, $y);
my $i = 0;
if (ref $inpath eq 'ARRAY') {
while ($i < @$inpath) {
$x = $$inpath[$i++];
if (ref $x eq 'ARRAY') {
($x, $y) = @$x;
} else {
$y = $$inpath[$i++];
}
push @$path, $x * $scale, $y * $scale, 8;
}
} else {
# \[[x0, x1, x2], [y0, y1, y2]]
# (I think)
# or more usefully $foo = [@x, @y]; join_the_dots \$foo;
$inpath = $$inpath;
while ($i < @{$$inpath[0]}) {
$x = $inpath->[0]->[$i];
$y = $inpath->[1]->[$i++];
push @$path, $x * $scale, $y * $scale, 8;
}
}
pop @$path; # Remove the last 8, which would start the next "line"
push @$path, 5 if $close;
unshift @_, [$path];
RISCOS::DrawFile::Path->new (\@_);
}
1;
__END__
=head1 NAME
RISCOS::DrawFile::Path
=head1 SYNOPSIS
Class to handle path objects in DrawFiles.
=head1 DESCRIPTION
=head1 BUGS
Not tested enough.
=head1 AUTHOR
Nicholas Clark <F<nick@unfortu.net>>