home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Fraction.pm < prev    next >
Encoding:
Perl POD Document  |  2002-09-09  |  7.4 KB  |  346 lines
  1. ############# Class : fract ##############
  2. package Math::Cephes::Fraction;
  3. use strict;
  4. use vars qw(%OWNER %BLESSEDMEMBERS %ITERATORS 
  5.         @EXPORT_OK %EXPORT_TAGS $VERSION);
  6.  
  7. require Exporter;
  8. *import = \&Exporter::import;
  9. #my @fract = qw(radd rsub rmul rdiv euclid fract mixed_fract);
  10. my @fract = qw(euclid fract mixed_fract);
  11. @EXPORT_OK = (@fract);
  12. %EXPORT_TAGS = ('fract' => [@fract]);
  13.  
  14. %OWNER = ();
  15. %BLESSEDMEMBERS = ();
  16. %ITERATORS = ();
  17. $VERSION = '0.36';
  18.  
  19. #use Math::Cephes qw(new_fract euclid);
  20. require Math::Cephes;
  21.  
  22. sub new {
  23.     my $self = shift;
  24.     my @args = @_;
  25.     $self = Math::Cephes::new_fract(@args);
  26.     return undef if (!defined($self));
  27.     bless $self, "Math::Cephes::Fraction";
  28.     $OWNER{$self} = 1;
  29.     my %retval;
  30.     tie %retval, "Math::Cephes::Fraction", $self;
  31.     return bless \%retval,"Math::Cephes::Fraction";
  32. }
  33.  
  34. sub fract {
  35.   return Math::Cephes::Fraction->new(@_);
  36. }
  37.  
  38. sub n {
  39.     my ($self, $value) = @_;
  40.     return $self->{n} unless $value;
  41.     $self->{n} = $value;
  42.     return $value;
  43. }
  44.  
  45. sub d {
  46.     my ($self, $value) = @_;
  47.     return $self->{d} unless $value;
  48.     $self->{d} = $value;
  49.     return $value;
  50. }
  51.  
  52. sub euclid {
  53.   return Math::Cephes::euclid($_[0], $_[1]);
  54. }
  55.  
  56. sub TIEHASH {
  57.     my ($classname,$obj) = @_;
  58.     return bless $obj, $classname;
  59. }
  60.   
  61. sub DESTROY {
  62.   return undef if ref($_[0]) ne 'HASH';
  63.     my $self = tied(%{$_[0]});
  64.     delete $ITERATORS{$self};
  65.     if (exists $OWNER{$self}) {
  66.         Math::Cephes::delete_fract($self);
  67.         delete $OWNER{$self};
  68.     }
  69. }
  70.  
  71. sub DISOWN {
  72.     my $self = shift;
  73.     my $ptr = tied(%$self);
  74.     delete $OWNER{$ptr};
  75.     };
  76.  
  77. sub ACQUIRE {
  78.     my $self = shift;
  79.     my $ptr = tied(%$self);
  80.     $OWNER{$ptr} = 1;
  81.     };
  82.  
  83. sub FETCH {
  84.     my ($self,$field) = @_;
  85.     no strict 'refs';
  86.     my $member_func = "Math::Cephes::fract_${field}_get";
  87.     my $val = &$member_func($self);
  88.     if (exists $BLESSEDMEMBERS{$field}) {
  89.         return undef if (!defined($val));
  90.         my %retval;
  91.         tie %retval,$BLESSEDMEMBERS{$field},$val;
  92.         return bless \%retval, $BLESSEDMEMBERS{$field};
  93.     }
  94.     return $val;
  95. }
  96.  
  97. sub STORE {
  98.     my ($self,$field,$newval) = @_;
  99.     no strict 'refs';
  100.     my $member_func = "Math::Cephes::fract_${field}_set";
  101.     if (exists $BLESSEDMEMBERS{$field}) {
  102.         &$member_func($self,tied(%{$newval}));
  103.     } else {
  104.         &$member_func($self,$newval);
  105.     }
  106. }
  107.  
  108. sub FIRSTKEY {
  109.     my $self = shift;
  110.     $ITERATORS{$self} = ['n', 'd', ];
  111.     my $first = shift @{$ITERATORS{$self}};
  112.     return $first;
  113. }
  114.  
  115. sub NEXTKEY {
  116.     my $self = shift;
  117.     my $nelem = scalar @{$ITERATORS{$self}};
  118.     if ($nelem > 0) {
  119.         my $member = shift @{$ITERATORS{$self}};
  120.         return $member;
  121.     } else {
  122.         $ITERATORS{$self} = ['n', 'd', ];
  123.         return ();
  124.     }
  125. }
  126.  
  127.  
  128. sub mixed_fract {
  129.   my $f = shift;
  130.   my $nin = int($f->{n});
  131.   my $din = int($f->{d});
  132.   my $gcd;
  133.    if ($din < 0) {
  134.      $din *= -1;
  135.      $nin *= -1;
  136.    }
  137.    if (abs($nin) < abs($din)) {
  138.      if ( $nin == 0 ) {
  139.        return (0, 0, 0);
  140.      }
  141.      else {
  142.        ($gcd, $nin, $din) = euclid($nin, $din);
  143.        return (0, $nin, $din);
  144.      }
  145.    }
  146.    else {
  147.      my $n = abs($nin) % $din;
  148.      my $w = int($nin / $din);
  149.      if ($n == 0) {
  150.        return ($w, 0, 1);
  151.      }
  152.      else {
  153.        ($gcd, $n, $din)  = euclid($n, $din);
  154.        return ($w, $n, $din);
  155.      }
  156.    }
  157. }
  158.  
  159. sub as_string {
  160.   my $f = shift;
  161.   my ($gcd, $string);
  162.   my $num = int($f->{n});
  163.   my $den = int($f->{d});
  164.   if ( abs($num % $den) == 0) {
  165.     my $w = $num / $den;
  166.     $string = "$w";
  167.   }
  168.   elsif ($num == 0) {
  169.     $string = '0';
  170.   }
  171.   else {
  172.     if ($den < 0) {
  173.       $num *= -1;
  174.       $den *= -1;
  175.     }
  176.     ($gcd, $num, $den) = euclid($num, $den);
  177.     $string = "$num/$den";
  178.   }
  179.   return $string;
  180. }
  181.  
  182. sub as_mixed_string {
  183.   my $f = shift;
  184.   my ($gcd, $string);
  185.   my $num = int($f->{n});
  186.   my $den = int($f->{d});
  187.   if ($den < 0) {
  188.     $den *= -1;
  189.     $num *= -1;
  190.   }
  191.   if (abs($num) < abs($den)) {
  192.     if ( $num == 0 ) {
  193.       $string = '0';
  194.      }
  195.      else {
  196.        ($gcd, $num, $den) = euclid($num, $den);
  197.        $string = "$num/$den";
  198.      }
  199.    }
  200.    else {
  201.      my $n = abs($num) % $den;
  202.      my $w = int($num / $den);
  203.      if ($n == 0) {
  204.        $string = "$w";
  205.      }
  206.      else {
  207.        ($gcd, $num, $den) = euclid($num, $den);
  208.        $string = "$w $n/$den";
  209.      }
  210.    }
  211.   return $string;
  212. }
  213.  
  214.   
  215. sub radd {
  216.   my ($f1, $f2) = @_;
  217.   my $f = Math::Cephes::Fraction->new();
  218.   Math::Cephes::radd($f1, $f2, $f);
  219.   return $f;
  220. }
  221.  
  222. sub rsub {
  223.   my ($f1, $f2) = @_;
  224.   my $f = Math::Cephes::Fraction->new();
  225.   Math::Cephes::rsub($f2, $f1, $f);
  226.   return $f;
  227. }
  228.  
  229. sub rmul {
  230.   my ($f1, $f2) = @_;
  231.   my $f = Math::Cephes::Fraction->new();
  232.   Math::Cephes::rmul($f1, $f2, $f);
  233.   return $f;
  234. }
  235.  
  236. sub rdiv {
  237.   my ($f1, $f2) = @_;
  238.   my $f = Math::Cephes::Fraction->new();
  239.   Math::Cephes::rdiv($f2, $f1, $f);
  240.   return $f;
  241. }
  242.  
  243. 1;
  244.  
  245. __END__
  246.  
  247. =head1 NAME
  248.  
  249.   Math::Cephes::Fraction - Perl interface to the cephes math fraction routines
  250.  
  251. =head1 SYNOPSIS
  252.  
  253.   use Math::Cephes::Fraction qw(fract);
  254.   my $f1 = fract(2,3);          # $f1 = 2/3
  255.   my $f2 = fract(3,4);          # $f2 = 3/4
  256.   my $f3 = $f1->radd($f2);      # $f3 = $f1 + $f2
  257.  
  258. =head1 DESCRIPTION
  259.  
  260. This module is a layer on top of the basic routines in the
  261. cephes math library to handle fractions. A fraction object
  262. is created via any of the following syntaxes:
  263.  
  264.   my $f = Math::Cephes::Fraction->new(3, 2);  # $f = 3/2
  265.   my $g = new Math::Cephes::Fraction(5, 3);   # $g = 5/3
  266.   my $h = fract(7, 5);                        # $h = 7/5
  267.  
  268. the last one being available by importing I<:fract>. If no arguments
  269. are specified, as in
  270.  
  271.   my $h = fract();
  272.  
  273. then the defaults $z = 0/1 are assumed. The numerator and 
  274. denominator of a fraction are represented respectively by
  275.  
  276.    $f->{n}; $f->{d}
  277.  
  278. or, as methods,
  279.  
  280.   $f->n;  $f->d;
  281.  
  282. and can be set according to
  283.  
  284.   $f->{n} = 4; $f->{d} = 9;
  285.  
  286. or, again, as methods,
  287.  
  288.  $f->n(4)  ; $f->(d) = 9;
  289.  
  290. The fraction can be printed out as
  291.  
  292.   print $f->as_string;
  293.  
  294. or as a mixed fraction as
  295.  
  296.   print $f->as_mixed_string;
  297.  
  298. These routines reduce the fraction to its basic form before printing. 
  299. This uses the I<euclid> routine which finds the greatest common
  300. divisor of two numbers, as follows:
  301.  
  302.  ($gcd, $m_reduced, $n_reduced) = euclid($m, $n); 
  303.  
  304. which returns the greatest common divisor of $m and $n, as well as
  305. the result of reducing $m and $n by $gcd
  306.  
  307. A summary of the basic routines is as follows.
  308.  
  309.  $x = fract(3, 4);     #  x = 3 / 4
  310.  $y = fract(2, 3);       #  y = 2 / 3
  311.  $z = $x->radd( $y );    #  z = x + y
  312.  $z = $x->rsub( $y );    #  z = x - y 
  313.  $z = $x->rmul( $y );    #  z = x * y
  314.  $z = $x->rdiv( $y );    #  z = x / y
  315.  print $z->{n}, ' ', $z->{d};  # prints numerator and denominator of $z
  316.  print $z->as_string;         # prints the fraction $z
  317.  print $z->as_mixed_string;   # converts $z to a mixed fraction, then prints it
  318.  
  319.  $m = 60;
  320.  $n = 144;
  321.  ($gcd, $m_reduced, $n_reduced) = euclid($m, $n); 
  322.  
  323. =head1 BUGS
  324.  
  325. Please report any to Randy Kobes <randy@theoryx5.uwinnipeg.ca>
  326.  
  327. =head1 SEE ALSO
  328.  
  329. For the basic interface to the cephes fraction routines, see
  330. L<Math::Cephes>. See also L<Math::Fraction>
  331. for a more extensive interface to fraction routines.
  332.  
  333. =head1 COPYRIGHT
  334.  
  335. The C code for the Cephes Math Library is
  336. Copyright 1984, 1987, 1989, 2002 by Stephen L. Moshier, 
  337. and is available at http://www.netlib.org/cephes/.
  338. Direct inquiries to 30 Frost Street, Cambridge, MA 02140.
  339.  
  340. The perl interface is copyright 2000, 2002 by Randy Kobes.
  341. This library is free software; you can redistribute it and/or
  342. modify it under the same terms as Perl itself.
  343.  
  344. =cut
  345.  
  346.