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 >
Encoding:
Perl POD Document  |  1999-01-20  |  9.3 KB  |  362 lines
  1. package RISCOS::DrawFile::Path;
  2.  
  3. use strict;
  4. use vars qw ($VERSION @ISA %winding @winding @winding_map);
  5.  
  6. @ISA = 'RISCOS::DrawFile::Object';
  7. require RISCOS::DrawFile::Object;
  8. use RISCOS::Draw qw(what unwhat pack_dash_block pack_path_block split_path_block
  9.             path_bbox split_dash_block path_transform);
  10. use RISCOS::Colour qw(pack_colour unpack_colour);
  11. $VERSION = 0.02;
  12.  
  13. # 0.02 PrePack calls BBox not BBox calc
  14.  
  15. # These differ from Draw. (ie the Draw module, as in RISCOS::Draw)
  16. %winding = ('non-zero' => 0, 'even-odd' => 1);
  17. @winding = ('non-zero', 'even-odd');
  18. @winding_map = (0, 2);
  19.  
  20. ### use SelfLoader;
  21. sub RISCOS::DrawFile::Path::new ($$);
  22. sub RISCOS::DrawFile::Path::Type ;
  23. sub RISCOS::DrawFile::Path::BBox_Calc ;
  24. sub RISCOS::DrawFile::Path::Translate ;
  25. sub RISCOS::DrawFile::Path::Size ;
  26. sub RISCOS::DrawFile::Path::PrePack ;
  27. sub RISCOS::DrawFile::Path::Pack ;
  28. sub RISCOS::DrawFile::Path::PackPathBlock ;
  29. sub RISCOS::DrawFile::Path::PackDashBlock ;
  30. sub RISCOS::DrawFile::Path::FillColour ;
  31. sub RISCOS::DrawFile::Path::LineColour ;
  32. sub RISCOS::DrawFile::Path::Width ;
  33. sub RISCOS::DrawFile::Path::Join ;
  34. sub RISCOS::DrawFile::Path::StartCap ;
  35. sub RISCOS::DrawFile::Path::EndCap ;
  36. sub RISCOS::DrawFile::Path::Wind ;
  37. sub RISCOS::DrawFile::Path::Dash ;
  38. sub RISCOS::DrawFile::Path::rectangle ;
  39. sub RISCOS::DrawFile::Path::join_the_dots ;
  40. 1;
  41. ### __DATA__
  42. sub new ($$) {
  43.     my $proto = shift;
  44.     my $class = ref($proto) || $proto;
  45.  
  46.     my ($self, $type) = $class->SUPER::new (@_);
  47.     return $self if ref ($self) eq 'ARRAY';
  48.  
  49.     my ($tri_w, $tri_l, $fill_col, $line_col, $width, $join, $start, $end,
  50.     $winding, $dash) = (1, 2);
  51.     return wantarray ? () : undef unless defined $_[0];
  52.     if (ref $_[0] eq 'ARRAY') {
  53.     my ($cols0, $path);
  54.     ($path, $fill_col, $line_col, $width, $join, $start, $end, $winding,
  55.      $dash) = @{$_[0]};
  56.     $width ||= 0;
  57.     $join = what ('join', 2, $join);
  58.     $line_col = 0 unless defined $line_col or defined $fill_col;
  59.     ($fill_col, $line_col) = pack_colour ($fill_col, $line_col);
  60.     if (ref ($start) eq 'ARRAY') {
  61.         ($tri_w, $tri_l) = @$start;
  62.         $start = 3;
  63.     } else {
  64.         $start = what ('cap', 0, $start);
  65.     }
  66.     if (ref ($end) eq 'ARRAY') {
  67.         ($tri_w, $tri_l) = @$start;
  68.         $end = 3;
  69.     } else {
  70.         $end = what ('cap', 0, $end);
  71.     }
  72.     $winding = what (\*winding, 0, $winding);
  73.     # use local winding names
  74.     @{$self->{'__PATH'}} = pack_path_block ($path);
  75.     } else {
  76.     # Time to unpack data
  77.     my $data;
  78.     if (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'LVALUE') {
  79.         # Has bounding box stripped
  80.         $data = ${$_[0]};
  81.     } else {
  82.         my $length;
  83.         ($length, @{$self->{'__BBOX'}}) = unpack 'x4Ii4', $_[0];
  84.         return undef unless length ($_[0]) == $length or $length & 3;
  85.         $data = substr $_[0], 24;
  86.     }
  87.     my $style;
  88.     ($fill_col, $line_col, $width, $style, $tri_w, $tri_l)
  89.       = unpack 'a4a4ICxC2', $data;
  90.     $tri_w /= 16;
  91.     $tri_l /= 16;
  92.     $join = $style & 3;
  93.     $start = ($style >> 2) & 3;    # PRM lies. Start *is* first.
  94.     $end = ($style >> 4) & 3;
  95.     $winding = ($style >> 6) & 1;
  96.     if ($style & 0x80) {
  97.         $dash = unpack 'x20I', $data;    # Get number of elements
  98.         $dash = substr $data, 16, 8 + 4 * $dash;
  99.         # Ref to scalar will be 'packed' by spitting
  100.         $self->{'__PATH'} = substr $data, 16 + length $dash;
  101.     } else {
  102.         $self->{'__PATH'} = substr $data, 16;
  103.     }
  104.     }
  105.     # Leave it uncalculated
  106.     # $self->{'__BBOX'} = $bbox;
  107.     $self->{'__FILLC'} = $fill_col;
  108.     $self->{'__LINEC'} = $line_col;
  109.     $self->{'__WIDTH'} = $width;
  110.     $self->{'__JOIN'} = $join;
  111.     $self->{'__START'} = $start;
  112.     $self->{'__END'} = $end;
  113.     $self->{'__TRIW'} = $tri_w;
  114.     $self->{'__TRIL'} = $tri_l;
  115.     $self->{'__WIND'} = $winding;
  116.     $self->{'__DASH'} = $dash;
  117.  
  118.     wantarray ? ($self, $type) : $self;
  119. }
  120.  
  121. sub Type { 2; }
  122.  
  123. sub BBox_Calc {
  124.     my $self = shift;
  125.     $self->{'__BBOX'} = path_bbox ($self->{'__PATH'}, $self->{'__WIND'}, undef,
  126.                    $self->{'__WIDTH'}, $self->{'__JOIN'},
  127.                    (($self->{'__START'} == 3)
  128.                      ? [$self->{'__TRIW'}, $self->{'__TRIL'}]
  129.                      : $self->{'__START'}),
  130.                    (($self->{'__END'} == 3)
  131.                      ? [$self->{'__TRIW'}, $self->{'__TRIL'}]
  132.                      : $self->{'__END'}), $self->{'__DASH'});
  133. }
  134.  
  135. sub Translate {
  136.     my ($self, $x, $y) = @_;
  137.     my $bbox = $self->{'__BBOX'};
  138.     if (defined $bbox) {
  139.     $$bbox[0] += $x;
  140.     $$bbox[1] += $y;
  141.     $$bbox[2] += $x;
  142.     $$bbox[3] += $y;
  143.     }
  144.     $self->{'__PATH'} = path_transform $self->{'__PATH'}, [1,0,0,1,$x,$y];
  145.     ();
  146. }
  147.  
  148. sub Size {
  149.     my $self = shift;
  150.     my $path = $self->{'__PATH'};
  151.     40 + (defined ($self->{'__DASH'})
  152.         ? length pack_dash_block ($self->{'__DASH'})
  153.         : 0) + length (ref ($path) ? pack_path_block ($path) : $path);
  154. }
  155.  
  156. sub PrePack {
  157.     my $self = shift;
  158.     $self->PackPathBlock;    # Make things fast.
  159.     $self->PackDashBlock;
  160.     $self->BBox (@_);
  161. }
  162.  
  163. sub Pack {
  164.     my $self = shift;
  165.     my $dash = pack_dash_block ($self->{'__DASH'});
  166.     $self->PackPathBlock();    # Make sure its a scalar
  167.     my $style = 0;
  168.  
  169.  
  170.     if (defined $dash) {
  171.     $style = 0x80 if length $dash;
  172.     } else {
  173.     $dash = '';
  174.     }
  175.  
  176.     $style |= ($self->{'__JOIN'} & 3) | (($self->{'__START'} & 3) << 2)
  177.           | (($self->{'__END'} & 3) << 4) | (($self->{'__WIND'} & 1) << 6);
  178.     $self->PackTypeSizeBBox(2)
  179.      . pack ('a4a4ICxC2', $self->{'__FILLC'}, $self->{'__LINEC'},
  180.          $self->{'__WIDTH'}, $style, 16 * $self->{'__TRIW'},
  181.          16 * $self->{'__TRIL'})
  182.      . $dash . $self->{'__PATH'}    # It has to be a scalar now
  183. }
  184.  
  185. # Ensures that the path is in the form of an array of scalars that can be
  186. # concatenated into a path block.
  187. sub PackPathBlock {
  188.     my $self = shift;
  189.     my $path = $self->{'__PATH'};
  190.     return wantarray ? split_path_block ($path) : $path
  191.       unless (ref $path);
  192.  
  193.     return $self->{'__PATH'} = pack_path_block $path unless wantarray;
  194.     # OK, it's a reference to something, and array context return is wanted.
  195.     my (@result) = pack_path_block $path;
  196.     $self->{'__PATH'} = join '', @result;
  197.     @result;
  198. }
  199.  
  200. sub PackDashBlock {
  201.     my $self = shift;
  202.     $self->{'__DASH'} = pack_dash_block ($self->{'__DASH'});
  203. }
  204.  
  205. sub FillColour {
  206.     my $self = shift;
  207.     my $old = $self->{'__FILLC'};
  208.     # Need to be able to pass in undef
  209.     $self->{'__FILLC'} = &pack_colour if @_;
  210.     unpack_colour $old;
  211. }
  212.  
  213. sub LineColour {
  214.     my $self = shift;
  215.     my $old = $self->{'__LINEC'};
  216.     # Need to be able to pass in undef
  217.     $self->{'__LINEC'} = &pack_colour if @_;
  218.     unpack_colour $old;
  219. }
  220.  
  221. sub Width {
  222.     my $self = shift;
  223.     my $old = $self->{'__WIDTH'};
  224.     if (@_) {
  225.     $self->{'__WIDTH'} = $_[0];
  226.     undef $self->{'__BBOX'}
  227.     }
  228.     $old;
  229. }
  230.  
  231. sub Join {
  232.     my $self = shift;
  233.     my $old = unwhat ('join', undef, $self->{'__JOIN'});
  234.     if (@_) {
  235.     $self->{'__JOIN'} = what ('join', 2, $_[0]);
  236.     }
  237.     $old;
  238. }
  239.  
  240. sub StartCap {
  241.     my $self = shift;
  242.     my @old = (unwhat ('cap', undef, $self->{'__START'}),
  243.            $self->{'__TRIW'}, $self->{'__TRIL'});
  244.     if (@_) {
  245.     my $start = shift;
  246.     if (ref ($start) eq 'ARRAY') {
  247.         ($self->{'__TRIW'}, $self->{'__TRIL'}) = @$start;
  248.         $start = 3;
  249.     } else {
  250.         $start = what ('cap', 0, $start);
  251.     }
  252.     $self->{'__START'} = $start;
  253.     undef $self->{'__BBOX'}
  254.     }
  255.     wantarray ? @old : $old[0];
  256. }
  257.  
  258. sub EndCap {
  259.     my $self = shift;
  260.     my @old = (unwhat ('cap', undef, $self->{'__END'}),
  261.            $self->{'__TRIW'}, $self->{'__TRIL'});
  262.     if (@_) {
  263.     my $end = shift;
  264.     if (ref ($end) eq 'ARRAY') {
  265.         ($self->{'__TRIW'}, $self->{'__TRIL'}) = @$end;
  266.         $end = 3;
  267.     } else {
  268.         $end = what ('cap', 0, $end);
  269.     }
  270.     $self->{'__END'} = $end;
  271.     undef $self->{'__BBOX'}
  272.     }
  273.     wantarray ? @old : $old[0];
  274. }
  275.  
  276. sub Wind {
  277.     my $self = shift;
  278.     my $old = unwhat (\*winding, undef, $self->{'__WIND'});
  279.     if (@_) {
  280.     $self->{'__WIND'} = what (\*winding, 0, $_[0]) if @_;
  281.     undef $self->{'__BBOX'}
  282.     }
  283.     $old;
  284. }
  285.  
  286. sub Dash {
  287.     my $self = shift;
  288.     my $old = $self->{'__DASH'};
  289.     if (@_) {
  290.     $self->{'__DASH'} = $_[0] if @_;
  291.     undef $self->{'__BBOX'}
  292.     }
  293.     split_dash_block ($old);
  294. }
  295.  
  296. #$path, $fill_col, $line_col, $width, $join, $start, $end, $winding, $dash
  297. sub rectangle {
  298.     my ($x0, $y0, $x1, $y1) = @{shift @_};
  299.     $y1 = $y0 + $x1 - $x0 unless defined $y1;
  300.     # The implicit pass by reference bites sometimes.
  301.     unshift @_,
  302. #      [[2, $x0, $y0], [8, $x1, $y0], [8, $x1, $y1], [8, $x0, $y1], [5]];
  303.       [[2, $x0, $y0, 8, $x1, $y0, 8, $x1, $y1, 8, $x0, $y1, 5]];    # Cheat!
  304.     RISCOS::DrawFile::Path->new (\@_);
  305. }
  306.  
  307. #$path, $scale, $close, $fill_col, $line_col, $width, $join, $start, $end, $winding, $dash
  308. sub join_the_dots {
  309.     my $inpath = shift;
  310.     my $scale = shift || 1;
  311.     my $close = shift;
  312.     my $path = [2];
  313.     my ($x, $y);
  314.     my $i = 0;
  315.     if (ref $inpath eq 'ARRAY') {
  316.     while ($i < @$inpath) {
  317.         $x = $$inpath[$i++];
  318.         if (ref $x eq 'ARRAY') {
  319.         ($x, $y) = @$x;
  320.         } else {
  321.         $y = $$inpath[$i++];
  322.         }
  323.         push @$path, $x * $scale, $y * $scale, 8;
  324.     }
  325.     } else {
  326.     # \[[x0, x1, x2], [y0, y1, y2]]
  327.     # (I think)
  328.     # or more usefully $foo = [@x, @y]; join_the_dots \$foo;
  329.     $inpath = $$inpath;
  330.     while ($i < @{$$inpath[0]}) {
  331.         $x = $inpath->[0]->[$i];
  332.         $y = $inpath->[1]->[$i++];
  333.         push @$path, $x * $scale, $y * $scale, 8;
  334.     }
  335.     }
  336.     pop @$path;        # Remove the last 8, which would start the next "line"
  337.     push @$path, 5 if $close;
  338.  
  339.     unshift @_, [$path];
  340.     RISCOS::DrawFile::Path->new (\@_);
  341. }
  342. 1;
  343. __END__
  344.  
  345. =head1 NAME
  346.  
  347. RISCOS::DrawFile::Path
  348.  
  349. =head1 SYNOPSIS
  350.  
  351. Class to handle path objects in DrawFiles.
  352.  
  353. =head1 DESCRIPTION
  354.  
  355. =head1 BUGS
  356.  
  357. Not tested enough.
  358.  
  359. =head1 AUTHOR
  360.  
  361. Nicholas Clark <F<nick@unfortu.net>>
  362.