Caltech CS 11 Haskell Lab 3

lab3.hs

data AbstractInteger = Zero | Succ AbstractInteger | Pred AbstractInteger
    deriving (Eq, Show)

instance Ord AbstractInteger where
    -- compare :: AbstractInteger -> AbstractInteger -> Ordering
    compare (Pred x) (Pred y) = compare x y 
    compare (Pred _) Zero = LT
    compare (Pred _) (Succ _) = LT
    compare Zero (Pred _) = GT
    compare Zero Zero = EQ
    compare Zero (Succ _) = LT
    compare (Succ _) (Pred _) = GT
    compare (Succ _) Zero = GT
    compare (Succ x) (Succ y) = compare x y 

    -- (<) :: AbstractInteger -> AbstractInteger -> Bool
    x < y = compare x y == LT

    -- (<=) :: AbstractInteger -> AbstractInteger -> Bool
    x <= y = compare x y /= GT

    -- (>) :: AbstractInteger -> AbstractInteger -> Bool
    x > y = compare x y == GT

    -- (>=) :: AbstractInteger -> AbstractInteger -> Bool
    x >= y = compare x y /= LT

    -- max :: AbstractInteger -> AbstractInteger -> AbstractInteger
    max x y = if x < y then y else x

    -- min :: AbstractInteger -> AbstractInteger -> AbstractInteger
    min x y = if x <= y then x else y

instance Num AbstractInteger where
    -- (+) :: AbstractInteger -> AbstractInteger -> AbstractInteger
    n + Zero = n 
    Zero + n = n 
    (Pred x) + (Succ y) = x + y 
    (Succ x) + (Pred y) = x + y 
    x0@(Pred _) + (Pred y) = (Pred x0) + y 
    x0@(Succ _) + (Succ y) = (Succ x0) + y 

    -- (-) :: AbstractInteger -> AbstractInteger -> AbstractInteger
    x - y = x + (negate y)

    -- (*) :: AbstractInteger -> AbstractInteger -> AbstractInteger
    x@(Pred _) * y@(Pred _) = negate x * negate y
    x@(Pred _) * y@(Succ _) = negate $ negate x * y 
    x@(Succ _) * y@(Pred _) = y * x 
    x@(Succ _) * y@(Succ _) = x + x * (y - (Succ Zero))
    _ * Zero = Zero
    Zero * _ = Zero

    -- negate :: AbstractInteger -> AbstractInteger
    negate (Pred x) = Succ $ negate x
    negate Zero = Zero
    negate (Succ x) = Pred $ negate x

    -- abs :: AbstractInteger -> AbstractInteger
    abs x@(Pred _) = negate x
    abs Zero = Zero
    abs x@(Succ _) = x 

    -- signum :: AbstractInteger -> AbstractInteger
    signum (Pred _) = Pred Zero
    signum Zero = Zero
    signum (Succ _) = Succ Zero

    -- fromInteger :: Integer -> AbstractInteger
    fromInteger n | n < 0 = Pred $ fromInteger (n + 1)
                  | n == 0 = Zero
                  | otherwise = Succ $ fromInteger (n - 1)

ai_toInteger :: AbstractInteger -> Integer
ai_toInteger (Pred x) = (-1) + ai_toInteger x
ai_toInteger Zero = 0
ai_toInteger (Succ x) = 1 + ai_toInteger x

factorial :: (Num a, Ord a) => a -> a
factorial x | x < fromInteger 0 = error "x must be integral and nonnegative"
            | x == fromInteger 0 = fromInteger 1
            | otherwise = x * factorial (x - fromInteger 1)

factorialTR :: (Num a, Ord a) => a -> a
factorialTR x = factTR x 1
    where factTR x n | x < fromInteger 0 = error "x must be integral and nonnegative"
                     | x == fromInteger 0 = n
                     | otherwise = factTR (x - fromInteger 1) (x * n)

data Quaternion = Q Double Double Double Double
    deriving Eq

instance Show Quaternion where
    show (Q r i j k) = "(" ++ show r ++ " + " ++ show i ++ "i + " ++ show j ++ "j + " ++ show k ++ "k" ++ ")"

instance Num Quaternion where
    -- (+) :: Q -> Q -> Q
    Q a0 b0 c0 d0 + (Q a1 b1 c1 d1) = Q (a0 + a1) (b0 + b1) (c0 + c1) (d0 + d1)

    -- (-) :: Q -> Q -> Q
    Q a0 b0 c0 d0 - (Q a1 b1 c1 d1) = Q (a0 - a1) (b0 - b1) (c0 - c1) (d0 - d1)

    -- (*) :: Q -> Q -> Q
    Q a1 b1 c1 d1 * (Q a2 b2 c2 d2) = Q (a1*a2 - b1*b2 - c1*c2 - d1*d2) (a1*b2 + b1*a2 + c1*d2 - d1*c2) (a1*c2 - b1*d2 + c1*a2 + d1*b2) (a1*d2 + b1*c2 - c1*b2 + d1*a2)

    -- negate :: Q -> Q
    negate (Q a b c d) = Q (-a) (-b) (-c) (-d)

    -- abs :: Q -> Q
    abs (Q a b c d) = Q (sqrt (a*a + b*b + c*c + d*d)) 0.0 0.0 0.0

    -- signum :: Q -> Q
    signum q@(Q a b c d) = Q (a / z) (b / z) (c / z) (d / z)
                                    where Q z _ _ _ = abs q

    -- fromInteger :: Integer -> Q
    fromInteger n = Q (fromInteger n) 0.0 0.0 0.0

testQuaternions :: IO ()
testQuaternions = mapM_ (\(a,b) -> putStrLn (show i ++ " * " ++ show i ++ " = " ++ show (i*i)))
                        [(x,y) | x <- [i,j,k], y <- [i,j,k]
                    where i = Q 0.0 1.0 0.0 0.0
                          j = Q 0.0 0.0 1.0 0.0
                          k = Q 0.0 0.0 0.0 1.0