Data.Bignum.hs

module Data.Bignum (Bignum, toBignum) where

import Data.Word
import Data.Bits
import Data.List

newtype Bignum = Bignum {bignum_list :: [Word32]} deriving Eq

class IsBignum a where
     toBignum :: a -> Bignum
     fromBignum :: Bignum -> a

-- instance (Integral a) => IsBignum a where
instance IsBignum Integer where
    toBignum x
        | x < 0     = error "toBignum : domain error"
        | otherwise = Bignum $ unfoldr (\y -> if y==0 then Nothing else Just (fromIntegral (y `mod` 65536), fromIntegral (y `div` 65536))) x
    fromBignum (Bignum xs) = foldr (\x a -> a * 65536 + fromIntegral x) 0 xs

integerAdd :: Word32 -> Word32 -> Word32 -> (Word32, Word32)
integerAdd x y c =
  let n = x + y + c
  in if n < 65536 then (n, 0) else (n - 65536, 1)

bignumAddInt :: [Word32] -> Word32 -> [Word32]
bignumAddInt [] n = if n == 0 then [] else [n]
bignumAddInt (x:xs) n = y : bignumAddInt xs c
  where (y, c) = integerAdd x 0 n

integerMul :: Word32 -> Word32 -> Word32 -> (Word32, Word32)
integerMul x y c =
  let n = x * y + c
  in if n < 65536
     then (n, 0)
     else (n `mod` 65536, n `div` 65536)

bignumMulInt :: [Word32] -> Word32 -> [Word32]
bignumMulInt xs n
  | n == 0    = [0]
  | n == 1    = xs
  | otherwise = iter xs 0
    where iter [] c = if c == 0 then [] else [c]
          iter (x:xs) c = let (y, c') = integerMul x n c
                          in y : iter xs c'

instance Num Bignum where
    (Bignum xs) + (Bignum ys) = Bignum $ iter xs ys 0
        where iter [] ys c = bignumAddInt ys c
              iter xs [] c = bignumAddInt xs c
              iter (x:xs) (y:ys) c =
                  let (n, c') = integerAdd x y c
                  in n : iter xs ys c'

    (Bignum [x]) * (Bignum ys) = Bignum $ bignumMulInt ys x
    (Bignum xs) * (Bignum [y]) = Bignum $ bignumMulInt xs y
    (Bignum xs) * (Bignum ys)  = Bignum $ iter xs ys [0]
        where iter _  []     a = a
              iter xs (y:ys) a = iter (0:xs) ys (bignum_list ((Bignum $ bignumMulInt xs y) + Bignum a))

    abs = id
    signum (Bignum []) = 0
    signum x = 1
    fromInteger x = toBignum x

integerDiv :: Word32 -> Word32 -> Word32 -> (Word32, Word32)
integerDiv x y c =
  let n = c * 65536 + x
  in (n `div` y, n `mod` y)

bignumDivInt :: [Word32] -> Word32 -> ([Word32], Word32)
bignumDivInt xs 0 = error "bignum: divide by zero"
bignumDivInt xs 1 = (xs, 0)
bignumDivInt xs n = iter (reverse xs) 0 []
  where iter [] c [] = ([], c)
        iter [] c a  = (a, c)
        iter (x:xs) c a =
          let (p, q) = integerDiv x n c
          in iter xs q (if p == 0 && null a then a else p:a)

swap (x,y) = (y,x)

instance Show Bignum where
     show (Bignum x) = concatMap show $ reverse $ unfoldr (\ys->if ys==[] then Nothing else Just $ swap $ bignumDivInt ys 10) x

fibonacci.hs

import Data.List
import Data.Bignum

data Mat a = Mat a a a a deriving (Show, Eq)

instance (Num a) => Num (Mat a) where
    (Mat a b c d) * (Mat p q r s) = Mat (a*p+b*r) (a*q+b*s) (c*p+d*r) (c*q+d*s)
    (Mat a b c d) + (Mat p q r s) = Mat (a+p) (b+q) (c+r) (d+s)
    abs=undefined
    signum=undefined
    fromInteger x = let y = fromInteger x in (Mat y y y y)

fibonacci :: Integer -> Bignum
fibonacci n = case (Mat (toBignum (1::Integer)) (toBignum (1::Integer)) (toBignum (1::Integer)) (toBignum (0::Integer))) ^ n of Mat a b c d -> b

splitInto :: Int->[a]->[[a]]
splitInto n = unfoldr (\x->if null x then Nothing else Just $ splitAt n x)

main :: IO ()
main = mapM_ putStrLn $ splitInto 20 $ show $ fibonacci 10000