{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.LargeWord
-- Copyright   :  (c) Dominic Steinitz 2004 - 2011
-- License     :  BSD
--
-- Maintainer  :  dominic@steinitz.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Provides Word128, Word192 and Word256 and a way of producing other
-- large words if required.
--
-----------------------------------------------------------------------------

module Data.LargeWord
  ( LargeKey(..)
  , Word96
  , Word128
  , Word160
  , Word192
  , Word224
  , Word256
  , loHalf
  , hiHalf
  ) where

import Data.Word
import Data.Bits
import Numeric
import Data.Char

-- Keys have certain capabilities.

class LargeWord a where
   largeWordToInteger :: a -> Integer
   integerToLargeWord :: Integer -> a
   largeWordPlus :: a -> a -> a
   largeWordMinus :: a -> a -> a
   largeWordAnd :: a -> a -> a
   largeWordOr :: a -> a -> a
   largeWordShift :: a -> Int -> a
   largeWordXor :: a -> a -> a
   largeBitSize :: a -> Int

-- Word8 is a key in the obvious way

instance LargeWord Word8 where
  largeWordToInteger = toInteger
  integerToLargeWord = fromInteger
  largeWordPlus = (+)
  largeWordMinus = (-)
  largeWordAnd  = (.&.)
  largeWordOr   = (.|.)
  largeWordShift = shift
  largeWordXor   = xor
  largeBitSize   = bitSize

-- Word16 is a key in the obvious way

instance LargeWord Word16 where
  largeWordToInteger = toInteger
  integerToLargeWord = fromInteger
  largeWordPlus = (+)
  largeWordMinus = (-)
  largeWordAnd  = (.&.)
  largeWordOr   = (.|.)
  largeWordShift = shift
  largeWordXor   = xor
  largeBitSize   = bitSize

-- Word32 is a key in the obvious way.

instance LargeWord Word32 where
  largeWordToInteger = toInteger
  integerToLargeWord = fromInteger
  largeWordPlus = (+)
  largeWordMinus = (-)
  largeWordAnd = (.&.)
  largeWordOr = (.|.)
  largeWordShift = shift
  largeWordXor = xor
  largeBitSize = bitSize

-- Word64 is a key in the obvious way.

instance LargeWord Word64 where
  largeWordToInteger = toInteger
  integerToLargeWord = fromInteger
  largeWordPlus = (+)
  largeWordMinus = (-)
  largeWordAnd = (.&.)
  largeWordOr = (.|.)
  largeWordShift = shift
  largeWordXor = xor
  largeBitSize = bitSize

-- Define larger keys from smaller ones.

data LargeKey a b = LargeKey a b
   deriving (Eq, Ord)

{-# INLINE loHalf #-}
loHalf (LargeKey a b) = a
{-# INLINE hiHalf #-}
hiHalf (LargeKey a b) = b

instance (Ord a, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) =>
   LargeWord (LargeKey a b) where
      largeWordToInteger (LargeKey lo hi) =
         largeWordToInteger lo + (2^(bitSize lo)) * largeWordToInteger hi
      integerToLargeWord x =
         let (h,l) =  x `quotRem` (2^(bitSize lo))
             (lo,hi) = (integerToLargeWord l, integerToLargeWord h) in
                LargeKey lo hi
      largeWordPlus (LargeKey alo ahi) (LargeKey blo bhi) =
         LargeKey lo' hi' where
            lo' = alo + blo
            hi' = ahi + bhi + if lo' < alo then 1 else 0
      largeWordMinus (LargeKey alo ahi) (LargeKey blo bhi) =
         LargeKey lo' hi' where
            lo' = alo - blo
            hi' = ahi - bhi - if lo' > alo then 1 else 0
      largeWordAnd (LargeKey alo ahi) (LargeKey blo bhi) =
         LargeKey lo' hi' where
            lo' = alo .&. blo
            hi' = ahi .&. bhi
      largeWordOr (LargeKey alo ahi) (LargeKey blo bhi) =
         LargeKey lo' hi' where
            lo' = alo .|. blo
            hi' = ahi .|. bhi
      largeWordXor (LargeKey alo ahi) (LargeKey blo bhi) =
         LargeKey lo' hi' where
            lo' = alo `xor` blo
            hi' = ahi `xor` bhi
      largeWordShift w 0 = w
      largeWordShift (LargeKey lo hi) x =
         if x >= 0
            then
               LargeKey (shift lo x)
                        (shift hi x .|. (convab $ shift lo (x - (bitSize lo))))
            else
               LargeKey (shift lo x .|. (convba $ shift hi (x + (bitSize hi))))
                        (shift hi x)
         where convab = integerToLargeWord . largeWordToInteger
               convba = integerToLargeWord . largeWordToInteger
      largeBitSize ~(LargeKey lo hi) = largeBitSize lo + largeBitSize hi

instance (Ord a, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) => Show (LargeKey a b) where
   showsPrec p = showInt . largeWordToInteger

instance (Ord b, Ord a, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) =>
   Num (LargeKey a b) where
      (+) = largeWordPlus
      (-) = largeWordMinus
      (*) a b =  go 0 0
        where
        go i r
         | i == bitSize r = r
         | testBit b i = go (i+1) (r + (a `shiftL` i))
         | otherwise   = go (i+1) r
      negate = id
      abs    = id
      signum a = if a > 0 then 1 else 0
      fromInteger = integerToLargeWord

-- Larger keys are instances of Bits provided their constituents are keys.

instance (Ord a, Ord b, Bits a, Num a, LargeWord a, Bits b, Num b, LargeWord b) =>
   Bits (LargeKey a b) where
      (.&.) = largeWordAnd
      (.|.) = largeWordOr
      xor = largeWordXor
      shift = largeWordShift
      x `rotate`  i | i < 0  = (x `largeWordShift` i) .|.
                               (x `largeWordShift` (i + largeBitSize x))
                    | i == 0 = x
                    | i > 0  = (x `largeWordShift` i) .|.
                               (x `largeWordShift` (i - largeBitSize x))
      complement (LargeKey a b) = LargeKey (complement a) (complement b)
      bitSize = largeBitSize
      isSigned _ = False
#if MIN_VERSION_base(4,6,0)
      bit = bitDefault
      testBit = testBitDefault
      popCount = popCountDefault
#endif

instance (Ord a, Bits a, Bounded a, Integral a, LargeWord a,
                 Bits b, Bounded b, Integral b, LargeWord b) =>
   Bounded (LargeKey a b) where
      minBound = 0
      maxBound =
         result where
            result =
               fromIntegral $
               (1 + fromIntegral (maxBound `asTypeOf` (boflk result)))*
                  (1 + fromIntegral (maxBound `asTypeOf` (aoflk result))) - 1

aoflk :: (LargeKey a b) -> a
aoflk = undefined
boflk :: (LargeKey a b) -> b
boflk = undefined

instance (Bounded a, Bounded b, Enum b, Enum a, Ord a, Bits a, Num a, LargeWord a, Ord b, Bits b, Num b, LargeWord b) =>
   Integral (LargeKey a b) where
      toInteger = largeWordToInteger
      quotRem a b =
              let r = a - q*b
                  q = go 0 (bitSize a) 0
              in (q,r)
       where
       -- Trivial long division
       go t 0 v = if v >= b then t+1 else t
       go t i v
              | v >= b    = go (setBit t i) i' v2
              | otherwise = go t i' v1
         where i' = i - 1
               newBit = if (testBit a i') then 1 else 0
               v1 = (v `shiftL` 1) .|. newBit
               v2 = ((v - b) `shiftL` 1) .|. newBit
      divMod = quotRem

instance (Ord a, Bits a, Num a, Bounded a, Bounded b, Enum a, Enum b, LargeWord a, Ord b, Bits b, Num b, LargeWord b) => Real (LargeKey a b) where
      toRational w = toRational (fromIntegral w :: Integer)


instance (Eq a, Bounded a, Num a, Enum b, Enum a, Bounded b, Num b) => Enum (LargeKey a b) where
	toEnum i = LargeKey (toEnum i) 0
	fromEnum (LargeKey l _) = fromEnum l
	pred (LargeKey 0 h) = LargeKey maxBound (pred h)
	pred (LargeKey l h) = LargeKey (pred l) h
	succ (LargeKey l h) = if l == maxBound then LargeKey 0 (succ h)
                                               else LargeKey (succ l) h

type Word96  = LargeKey Word32 Word64
type Word128 = LargeKey Word64 Word64
type Word160 = LargeKey Word32 Word128
type Word192 = LargeKey Word64 Word128
type Word224 = LargeKey Word32 Word192
type Word256 = LargeKey Word64 Word192