{-# OPTIONS -fglasgow-exts #-}
-- | Defines the mapping between haskell types and a set of optimization
-- parameters used to represent said type.

module Optimize.Parameter where 

import Foreign.Storable
import Foreign.Ptr
import Foreign.C.Types
import Char


smallDouble :: Double
smallDouble = 1.0e-12
bigDouble = 1.0e6

data ParamInfo = ParamInfo {
    limitLow :: {-# UNBOX #-} !Double,
    limitHigh :: {-# UNBOX #-} !Double,
    isIntegral :: {-# UNBOX #-} !Bool
}

paramInfoFloat = ParamInfo {
    limitLow = -bigDouble,
    limitHigh = bigDouble,
    isIntegral = False
}

paramInfoInt = paramInfoFloat { limitLow = realToFrac (minBound :: Int), limitHigh = realToFrac (maxBound :: Int), isIntegral = True }

data Limit a = Limit { minLimit :: Maybe a, maxLimit :: Maybe a }

limit x y = Limit { minLimit = Just x, maxLimit = Just y }
limitMin x = Limit { minLimit = Just x, maxLimit = Nothing }
limitMax x = Limit { minLimit = Nothing, maxLimit = Just x }
limitPositive,limitNegative,limitUnit :: Num a => Limit a
limitPositive = limitMin 0
limitNegative = limitMax 0
limitUnit = limit 0 1



-- z is the meta-info for the given type. such as bounds.

-- This really should be a superclass of Monoid
class Empty a where
    empty :: a

instance Empty () where
    empty = ()
instance (Empty x, Empty y) => Empty (x,y) where
    empty = (empty,empty)
instance (Empty x, Empty y, Empty z) => Empty (x,y,z) where
    empty = (empty,empty,empty)
instance Empty (Maybe a) where
    empty = Nothing
instance Empty (Limit a) where
    empty = Limit { minLimit = Nothing, maxLimit = Nothing }

class Empty z => Parameter z x | x -> z where
    pokeParam :: z -> x -> Ptr Double -> IO ()
    peekParam :: z -> Ptr Double -> IO x    -- needs to be as fast as possible
    -- x is only needed on these for its type. (can we do this in a better way?)
    paramInfo :: x -> z -> [ParamInfo] -> [ParamInfo]
    numParams :: x -> z ->  Int

instance Parameter () () where
    pokeParam _ _ _ = return ()
    peekParam _ _ = return ()
    numParams _ _ = 0
    paramInfo _ _ x = x


instance Parameter () Bool where
    pokeParam _ False p = poke p 0
    pokeParam _ True p = poke p 1
    peekParam _ p = do
        x <- peek p
        return (not $ abs x < smallDouble)
    paramInfo _ _ xs = ParamInfo { limitLow = 0, limitHigh = 1, isIntegral = True }:xs
    numParams _ _ = 1

instance (Parameter za a, Parameter zb b) => Parameter (za,zb) (a,b) where
    pokeParam (za,zb) ((a::a),b) p = do
        pokeParam za a p 
        pokeParam zb b (p `advancePtr` numParams (undefined::a) za) 
    peekParam (za,zb) p = do
        (a::a) <- peekParam za p 
        b <- peekParam zb (p `advancePtr` numParams (undefined::a) za)
        return (a,b)
    paramInfo (_ :: (a,b)) (za,zb) = paramInfo a za . paramInfo b zb where
        a = undefined :: a
        b = undefined :: b

    numParams (_ :: (a,b)) (za,zb) = numParams a za + numParams b zb  where
        a = undefined :: a
        b = undefined :: b

instance (Parameter za a, Parameter zb b, Parameter zc c) => Parameter (za,zb,zc) (a,b,c) where
    pokeParam (za,zb,zc) (a,b,c) p = do
        pokeParam (za,(zb,zc)) (a,(b,c)) p
    peekParam (za,zb,zc) p = do
        (a,(b,c)) <- peekParam (za,(zb,zc)) p 
        return (a,b,c)
    paramInfo (_ :: (a,b,c)) (za,zb,zc) = paramInfo a za . paramInfo b zb . paramInfo c zc where
        a = undefined :: a
        b = undefined :: b
        c = undefined :: c

    numParams (_ :: (a,b,c)) (za,zb,zc) = numParams a za + numParams b zb + numParams c zc  where
        a = undefined :: a
        b = undefined :: b
        c = undefined :: c

instance Parameter (Limit Double) Double where
    pokeParam _ x p = poke p  x
    peekParam _ p = peek p 
    paramInfo _ Limit { minLimit = Nothing, maxLimit = Nothing } xs = paramInfoFloat :xs
    paramInfo _ Limit { minLimit = Just x, maxLimit = Nothing } xs = paramInfoFloat { limitLow =  x }:xs
    paramInfo _ Limit { minLimit = Just x, maxLimit = Just y } xs = paramInfoFloat { limitLow =  x, limitHigh =  y }:xs
    paramInfo _ Limit { minLimit = Nothing, maxLimit = Just y } xs = paramInfoFloat { limitHigh =  y }:xs
    numParams _ _ = 1
    
instance Parameter (Limit Int) Int where
    pokeParam _ x p = poke p (realToFrac x)
    peekParam _ p = peek p >>= return . round
    paramInfo _ Limit { minLimit = Nothing, maxLimit = Nothing } xs = paramInfoInt :xs
    paramInfo _ Limit { minLimit = Just x, maxLimit = Nothing } xs = paramInfoInt { limitLow = realToFrac x }:xs
    paramInfo _ Limit { minLimit = Just x, maxLimit = Just y } xs = paramInfoInt { limitLow = realToFrac x, limitHigh = realToFrac y }:xs
    paramInfo _ Limit { minLimit = Nothing, maxLimit = Just y } xs = paramInfoInt { limitHigh = realToFrac y }:xs
    numParams _ _ = 1


-- Of questionable utility.
instance Parameter ()  Char where 
    pokeParam _ x p = poke p (realToFrac $ ord x)
    peekParam _ p = peek p >>= return . chr . round
    paramInfo _ () xs = paramInfoInt { limitLow = 0x20, limitHigh = 0x7e }:xs
    numParams _ _ = 1
    


instance Parameter (Limit Float) Float where
    pokeParam _ x p = poke p (realToFrac x)
    peekParam _ p = peek p >>= return . realToFrac
    paramInfo _ Limit { minLimit = Nothing, maxLimit = Nothing } xs = paramInfoFloat :xs
    paramInfo _ Limit { minLimit = Just x, maxLimit = Nothing } xs = paramInfoFloat { limitLow = realToFrac x }:xs
    paramInfo _ Limit { minLimit = Just x, maxLimit = Just y } xs = paramInfoFloat { limitLow = realToFrac x, limitHigh = realToFrac y }:xs
    paramInfo _ Limit { minLimit = Nothing, maxLimit = Just y } xs = paramInfoFloat { limitHigh = realToFrac y }:xs
    numParams _ _ = 1

instance Parameter zb b => Parameter zb (Maybe b) where
    pokeParam zb (Nothing :: Maybe b) p = do
        pokeParam ((),zb) (Left () :: Either () b) p
    pokeParam zb (Just b :: Maybe b) p = do
        pokeParam ((),zb) (Right b :: Either () b) p
    peekParam zb p = do
        v <- peekParam ((),zb) p
        case v of
            Right b -> return $ Just b
            Left () -> return $ Nothing
    paramInfo (_ :: Maybe b) z = paramInfo (undefined :: Either () b) ((),z)
    numParams (_ :: Maybe b) z = numParams (undefined :: Either () b) ((),z)

    
    
    

instance (Parameter za a, Parameter zb b) => Parameter (za,zb) (Either a b) where
    pokeParam (za,zb) (Left a :: Either a b) p = do
        pokeParam empty False p
        p <- return $  (p `advancePtr` 1)
        pokeParam za a p
    pokeParam (za,zb) (Right b :: Either a b) p = do
        pokeParam empty False p
        p <- return $  (p `advancePtr` (1 + numParams (undefined :: a) za))
        pokeParam zb b p
    peekParam (za,zb) p  = do
        b <- peekParam () p
        p <- return $  (p `advancePtr` 1)
        case b of
            False -> do
                a <- peekParam za p 
                return $ Left a
            True -> do
                let f :: Either a b -> a -> Either a b
                    f x _ = x
                un <- return undefined
                p <- return $ (p `advancePtr` numParams un za)
                a <- peekParam zb p 
                return $ f (Right a) un
    paramInfo (_ :: Either a b) (za,zb) = paramInfo (undefined :: Bool) empty . paramInfo a za . paramInfo b zb where
        a = undefined :: a
        b = undefined :: b
    numParams (_ :: Either a b) (za,zb) = 1 + numParams a za + numParams b zb  where
        a = undefined :: a
        b = undefined :: b

advancePtr (p :: Ptr a) n = p `plusPtr` (n * sizeOf (undefined :: a)) 

--instance (Parameter a, Parameter b) => Parameter (Either a b) where
--      pokeParam = pokeParam (Bool,a,b)