basis/math/ratios/ratios.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel kernel.private math math.functions math.private ;
   4 IN: math.ratios
   5
   6 : >fraction ( a/b -- a b )
   7     dup numerator swap denominator ; inline
   8
   9 : 2>fraction ( a/b c/d -- a c b d )
  10     [ >fraction ] bi@ swapd ; inline
  11
  12 <PRIVATE
  13
  14 : fraction> ( a b -- a/b )
  15     dup 1 number= [ drop ] [ <ratio> ] if ; inline
  16
  17 : scale ( a/b c/d -- a*d b*c )
  18     2>fraction >r * swap r> * swap ; inline
  19
  20 : ratio+d ( a/b c/d -- b*d )
  21     denominator swap denominator * ; inline
  22
  23 PRIVATE>
  24
  25 M: integer /
  26     dup zero? [
  27         "Division by zero" throw
  28     ] [
  29         dup 0 < [ [ neg ] bi@ ] when
  30         2dup gcd nip tuck /i >r /i r> fraction>
  31     ] if ;
  32
  33 M: ratio hashcode*
  34     nip >fraction [ hashcode ] bi@ bitxor ;
  35
  36 M: ratio equal?
  37     over ratio? [
  38         2>fraction = [ = ] [ 2drop f ] if
  39     ] [ 2drop f ] if ;
  40
  41 M: ratio number=
  42     2>fraction number= [ number= ] [ 2drop f ] if ;
  43
  44 M: ratio >fixnum >fraction /i >fixnum ;
  45 M: ratio >bignum >fraction /i >bignum ;
  46 M: ratio >float >fraction /f ;
  47
  48 M: ratio numerator numerator>> ;
  49 M: ratio denominator denominator>> ;
  50
  51 M: ratio < scale < ;
  52 M: ratio <= scale <= ;
  53 M: ratio > scale > ;
  54 M: ratio >= scale >= ;
  55
  56 M: ratio + 2dup scale + -rot ratio+d / ;
  57 M: ratio - 2dup scale - -rot ratio+d / ;
  58 M: ratio * 2>fraction * >r * r> / ;
  59 M: ratio / scale / ;
  60 M: ratio /i scale /i ;
  61 M: ratio /f scale /f ;
  62 M: ratio mod [ /i ] 2keep rot * - ;
  63 M: ratio /mod [ /i ] 2keep mod ;