module Optimize.Parameter where
import Foreign.Storable
import Foreign.Ptr
import Foreign.C.Types
import Data.Char
smallDouble :: Double
smallDouble = 1.0e-12
bigDouble = 1.0e6
data ParamInfo = ParamInfo {
limitLow :: !Double,
limitHigh :: !Double,
isIntegral :: !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
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
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
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 :: forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr (p :: Ptr a) n = p `plusPtr` (n * sizeOf (undefined :: a))