1 files changed, 98 insertions, 0 deletions
diff --git a/progs/prelude/PreludeRatio.hs b/progs/prelude/PreludeRatio.hs
new file mode 100644
index 0000000..564558e
--- /dev/null
+++ b/progs/prelude/PreludeRatio.hs
@@ -0,0 +1,98 @@
+-- Standard functions on rational numbers
+
+module	PreludeRatio (
+    Ratio, Rational(..), (%), numerator, denominator, approxRational ) where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+infixl 7  %, :%
+
+prec = 7
+
+data  (Integral a)	=> Ratio a = a {-# STRICT #-} :% a {-# STRICT #-}
+                              deriving (Eq, Binary)
+
+type  Rational		=  Ratio Integer
+
+(%)			:: (Integral a) => a -> a -> Ratio a
+numerator, denominator	:: (Integral a) => Ratio a -> a
+approxRational		:: (RealFrac a) => a -> a -> Rational
+
+
+reduce _ 0		=  error "(%){PreludeRatio}: zero denominator"
+reduce x y		=  (x `quot` d) :% (y `quot` d)
+			   where d = gcd x y
+
+
+x % y			=  reduce (x * signum y) (abs y)
+
+numerator (x:%y)	=  x
+
+denominator (x:%y)	=  y
+
+
+instance  (Integral a)	=> Ord (Ratio a)  where
+    (x:%y) <= (x':%y')	=  x * y' <= x' * y
+    (x:%y) <  (x':%y')	=  x * y' <  x' * y
+
+instance  (Integral a)	=> Num (Ratio a)  where
+    (x:%y) + (x':%y')	=  reduce (x*y' + x'*y) (y*y')
+    (x:%y) * (x':%y')	=  reduce (x * x') (y * y')
+    negate (x:%y)	=  (-x) :% y
+    abs (x:%y)		=  abs x :% y
+    signum (x:%y)	=  signum x :% 1
+    fromInteger x	=  fromInteger x :% 1
+
+instance  (Integral a)	=> Real (Ratio a)  where
+    toRational (x:%y)	=  toInteger x :% toInteger y
+
+instance  (Integral a)	=> Fractional (Ratio a)  where
+    (x:%y) / (x':%y')	=  (x*y') % (y*x')
+    recip (x:%y)	=  if x < 0 then (-y) :% (-x) else y :% x
+    fromRational (x:%y) =  fromInteger x :% fromInteger y
+
+instance  (Integral a)	=> RealFrac (Ratio a)  where
+    properFraction (x:%y) = (fromIntegral q, r:%y)
+			    where (q,r) = quotRem x y
+
+instance  (Integral a)	=> Enum (Ratio a)  where
+    enumFrom		=  iterate ((+)1)
+    enumFromThen n m	=  iterate ((+)(m-n)) n
+
+instance  (Integral a) => Text (Ratio a)  where
+    readsPrec p  =  readParen (p > prec)
+			      (\r -> [(x%y,u) | (x,s)   <- reads r,
+					        ("%",t) <- lex s,
+						(y,u)   <- reads t ])
+
+    showsPrec p (x:%y)	=  showParen (p > prec)
+    	    	    	       (shows x . showString " % " . shows y)
+
+
+-- approxRational, applied to two real fractional numbers x and epsilon,
+-- returns the simplest rational number within epsilon of x.  A rational
+-- number n%d in reduced form is said to be simpler than another n'%d' if
+-- abs n <= abs n' && d <= d'.  Any real interval contains a unique
+-- simplest rational; here, for simplicity, we assume a closed rational
+-- interval.  If such an interval includes at least one whole number, then
+-- the simplest rational is the absolutely least whole number.  Otherwise,
+-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
+-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of
+-- the simplest rational between d'%r' and d%r.
+
+approxRational x eps	=  simplest (x-eps) (x+eps)
+	where simplest x y | y < x	=  simplest y x
+			   | x == y	=  xr
+			   | x > 0	=  simplest' n d n' d'
+			   | y < 0	=  - simplest' (-n') d' (-n) d
+			   | otherwise	=  0 :% 1
+					where xr@(n:%d) = toRational x
+					      (n':%d')	= toRational y
+
+	      simplest' n d n' d'	-- assumes 0 < n%d < n'%d'
+			| r == 0     =	q :% 1
+			| q /= q'    =	(q+1) :% 1
+			| otherwise  =	(q*n''+d'') :% n''
+				     where (q,r)      =	 quotRem n d
+					   (q',r')    =	 quotRem n' d'
+					   (n'':%d'') =	 simplest' d' r' d r