home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / Colour.pm < prev    next >
Encoding:
Perl POD Document  |  1999-01-19  |  2.9 KB  |  118 lines
  1. package RISCOS::Colour;
  2.  
  3. require Exporter;
  4. use strict;
  5. use vars qw (@ISA @EXPORT_OK $VERSION);
  6.  
  7. @ISA = qw(Exporter);
  8. @EXPORT_OK = qw(pack_colour unpack_colour interpolate_colour);
  9. $VERSION = 0.03;
  10.  
  11. sub pack_colour {
  12.     my @result;
  13.  
  14.     foreach (@_) {
  15.     if (ref $_ eq 'ARRAY') {
  16.         # (red, green, blue) -> 0xBBGGRR00 (little Endian)
  17.         push @result, pack 'xC3', $$_[0], $$_[1], $$_[2]
  18.     } elsif (ref $_ eq 'SCALAR') {
  19.         push @result, $$_
  20.     } else {
  21.         push @result, pack ('I', defined ($_) ? $_ : -1);
  22.     }
  23.     }
  24.     wantarray ? @result : $result[0];
  25. }
  26.  
  27. sub unpack_colour {
  28.     return (defined $_[0] and $_[0] ne 'ÿÿÿÿ') ? [unpack ('xC3', $_[0])] : undef
  29.       unless wantarray;
  30.     map  { (defined $_ and $_ ne 'ÿÿÿÿ') ? [unpack ('xC3', $_)] : () } @_;
  31. }
  32. sub interpolate_colour {
  33.     my $steps = 0;
  34.     my ($start, $end, @result, @step, $add_end);
  35.     while (defined ($end = shift)) {
  36.     if (ref $end eq 'ARRAY') {
  37.         if (defined $start) {
  38.         foreach (0..2) {$step[$_] = ($end->[$_] - $start->[$_])
  39.                 / $steps;}
  40.         $_ = 0;
  41.         while ($_ < $steps) {
  42.             push @result, [$start->[0] + $step[0] * $_,
  43.                    $start->[1] + $step[1] * $_,
  44.                    $start->[2] + $step[2] * $_];
  45.             $_++;
  46.         }
  47.         }
  48.         $start = $end;
  49.     } else {
  50.         $steps = abs $end;
  51.         $add_end = $end < 0;
  52.     }
  53.     }
  54.     push @result, [@$start] if $add_end;
  55.     @result;
  56. }
  57.  
  58.  
  59. 1;
  60. __END__
  61.  
  62. =head1 NAME
  63.  
  64. RISCOS::Colour -- conversions between S<RISC OS> colour values and arrays
  65.  
  66. =head1 SYNOPSIS
  67.  
  68.     use RISCOS::Units qw(unpack_colour);
  69.     $col = unpack_colour ($packed);
  70.     print "Red = $$col[0]; Green = $$col[1]; $Blue = $$col[2]\n";
  71.  
  72. =head1 DESCRIPTION
  73.  
  74. This module provides conversion functions between arrays of RGB values
  75. and 32 bit integers used by S<RISC OS> to store colours.
  76.  
  77. =over 4
  78.  
  79. =item pack_colour <colour>, ...
  80.  
  81. C<pack_colour> packs integers or arrays of RGB triples into 4 bytes as used in
  82. blocks passed to S<RISC OS> SWIs. C<undef> maps to -1 ('C<ÿÿÿÿ>') which is used
  83. in DrawFiles to mean transparent, integers are taken to be a single colour of
  84. the form 0xBBGGRR00, scalar references are assumed to be already packed, and
  85. array references are assumed to point to 3 integers (red, green, blue) in the
  86. rage 0 - 255. To convert a single colour call in scalar conted:
  87.  
  88.  
  89.     $colour = pack_colour [1, 0, 1];
  90.     # Pack magenta, passing ref to an anonyomous hash
  91.  
  92. To convert a list call in list context:
  93.  
  94.     ($fore, $back) = pack_colour([0,0,0], [255, 255, 255])
  95.     # Black on white
  96.  
  97. =item unpack_colour <colour>, ...
  98.  
  99. C<unpack_clour> converts 4 byte colours to arrays of RGB values. When called in
  100. B<scalar context> a single B<array reference> is returned for the first
  101. argument. When called in B<list context> an <array of array references> is
  102. returned.
  103.  
  104.     ($fore, $back) = unpack_colour ($fore_raw, $back_raw);
  105.     print "Red = $$fore[0]; Green = $$fore[1]; $Blue = $$fore[2]\n";
  106.  
  107. =back
  108.  
  109. =head1 BUGS
  110.  
  111. Not tested enough yet.
  112.  
  113. =head1 AUTHOR
  114.  
  115. Nicholas Clark <F<nick@unfortu.net>>
  116.  
  117. =cut
  118.