94 lines
2.2 KiB
Haskell
94 lines
2.2 KiB
Haskell
|
module Data.Number.Internal
|
||
|
|
( operator
|
||
|
|
, cut
|
||
|
|
, first
|
||
|
|
, rest
|
||
|
|
, split
|
||
|
|
) where
|
||
|
|
|
||
|
|
import Data.Number.Types
|
||
|
|
import Data.Ratio
|
||
|
|
import Numeric.Peano
|
||
|
|
|
||
|
|
|
||
|
|
type Matrix = (Whole, Whole, Whole, Whole, Whole, Whole, Whole, Whole)
|
||
|
|
|
||
|
|
|
||
|
|
operator :: Matrix -> Number -> Number -> Number
|
||
|
|
operator c x y =
|
||
|
|
case operator' c x y False of
|
||
|
|
[] -> E
|
||
|
|
m -> if head m < 0
|
||
|
|
then M $ fromList (map toNat m)
|
||
|
|
else fromList (map toNat m)
|
||
|
|
where
|
||
|
|
fromList [] = E
|
||
|
|
fromList (x:xs) = x :| fromList xs
|
||
|
|
|
||
|
|
operator' :: Matrix -> Number -> Number -> Bool -> [Whole]
|
||
|
|
operator' (_,_,_,_,0,0,0,0) _ _ _ = []
|
||
|
|
operator' (a,b,c,d,e,f,g,h) x y end
|
||
|
|
| t = r : operator' (e, f, g, h, a-e*r, b-f*r, c-g*r, d-h*r) x y end
|
||
|
|
| x/=E && s = operator' (b, a+b*p, d, c+d*p, f, e+f*p, h, g+h*p) x' y end
|
||
|
|
| x==E && s = operator' (b, b, d, d, f, f, h, h) E y end
|
||
|
|
| y/=E = operator' (c, d, a+c*q, b+d*q, g, h, e+g*q, f+h*q) x y' end
|
||
|
|
| otherwise = operator' (c, d, c, d, g, h, g, h) x E True
|
||
|
|
where
|
||
|
|
r = a // e
|
||
|
|
(p, x') = split x
|
||
|
|
(q, y') = split y
|
||
|
|
t = not (any (==0) [e,f,g,h]) && all (==r) [b//f, c//g, d//h]
|
||
|
|
s | end = True
|
||
|
|
| any (==0) [f,g,e,h] = False
|
||
|
|
| otherwise = abs (b%f - a%e) > abs (c%g - a%e)
|
||
|
|
|
||
|
|
|
||
|
|
cut :: Nat -> Number -> Number
|
||
|
|
cut _ E = E
|
||
|
|
cut n (M x) = M (cut n x)
|
||
|
|
cut n _ | n <= 0 = E
|
||
|
|
cut n (x :| xs) = x :| cut (n-1) xs
|
||
|
|
|
||
|
|
|
||
|
|
split :: Number -> (Whole, Number)
|
||
|
|
split x = (first x, rest x)
|
||
|
|
|
||
|
|
|
||
|
|
first :: Number -> Whole
|
||
|
|
first E = 0
|
||
|
|
first (M E) = 0
|
||
|
|
first (M (x:|_)) = Whole x Neg
|
||
|
|
first (x:|_) = Whole x Pos
|
||
|
|
|
||
|
|
|
||
|
|
rest :: Number -> Number
|
||
|
|
rest E = E
|
||
|
|
rest (M E) = E
|
||
|
|
rest (M x) = M (rest x)
|
||
|
|
rest (_:|xs) = xs
|
||
|
|
|
||
|
|
|
||
|
|
-- Peano arithmethics --
|
||
|
|
|
||
|
|
toNat :: Whole -> Nat
|
||
|
|
toNat (Whole n _) = n
|
||
|
|
|
||
|
|
(//) :: Integral a => a -> a -> a
|
||
|
|
(//) = quot
|
||
|
|
|
||
|
|
instance Real Whole where
|
||
|
|
toRational = (%1) . toInteger
|
||
|
|
|
||
|
|
instance Integral Whole where
|
||
|
|
toInteger (Whole z Pos) = (fromPeano z)
|
||
|
|
toInteger (Whole z Neg) = -(fromPeano z)
|
||
|
|
|
||
|
|
quotRem (Whole a s) (Whole b s') = (Whole q sign, Whole r Pos)
|
||
|
|
where
|
||
|
|
q = quot a b
|
||
|
|
r = a - q * b
|
||
|
|
sign | s == s' && s == Pos = Pos
|
||
|
|
| s == s' && s == Neg = Pos
|
||
|
|
| otherwise = Neg
|
||
|
|
|