{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.LP( -- Variable(..)
Constraint(..)
,Constraints(..)
,Algebra(..)
,Optimization(..)
,(<:)
,(=:)
,(>:)
,sum
,sumc
,forall
,I.Type(..)
,MixedIntegerProblem(..)
,LinearProblem(..)
,I.MIPSolution(..)
,I.LPSolution(..)
,simplify
,buildConstraint
,buildConstraints
,buildObjective
) where
import Data.Monoid
import Data.List (intercalate)
import qualified Prelude as P
import qualified Data.HashMap.Strict as M
import qualified Prelude as P
import Prelude hiding ((*), sum)
import qualified Data.Internal as I
import Data.Hashable
import GHC.Generics
import Unsafe.Coerce (unsafeCoerce)
data Algebra x = Constant Double
| Double :* x
| LinearCombination [Algebra x]
infixr 1 :<
data Constraint x = Algebra x :< Algebra x
| Algebra x := Algebra x
| Algebra x :> Algebra x
deriving (Show)
data Constraints x = Constraints [Constraint x]
deriving (Show)
instance Monoid (Constraints a) where
(Constraints xs) `mappend` (Constraints ys) = Constraints $ xs ++ ys
mempty = Constraints []
instance (Eq x, Hashable x, Show x) => Show (Algebra x) where
show (Constant d) = show d
show (d :* x) = show d <> show x
show l = intercalate " + " $ map show xs
where LinearCombination xs = simplify l
instance Num (Algebra x) where
fromInteger i = Constant $ fromIntegral i
(LinearCombination xs) + (LinearCombination ys) = LinearCombination $ xs ++ ys
a1 + (LinearCombination xs) = LinearCombination (a1:xs)
(LinearCombination xs) + a2 = LinearCombination (xs++[a2])
(Constant a) + (Constant b) = Constant (a+b)
a + b = LinearCombination [a,b]
negate (Constant d) = Constant $ negate d
negate (d :* v) = (negate d) :* v
negate (LinearCombination xs) = LinearCombination $ map negate xs
data Optimization x = Maximize (Algebra x)
| Minimize (Algebra x)
deriving (Show)
sum :: [a] -> (a -> Algebra x) -> Algebra x
sum xs f = P.sum $ map f xs
forall = flip map
sumc xs f = Constant $ P.sum $ map f xs
simplify :: (Eq a, Hashable a) => Algebra a -> Algebra a
simplify a@(Constant d) = a
simplify a@(0 :* x) = Constant 0
simplify a@(d :* x) = a
simplify i@(LinearCombination xs) = const + (LinearCombination $ map (\(v,c) -> c :* v) $ M.toList $
foldr (\(v,c) m -> M.insertWith (+) v c m) M.empty $ getVars i)
where const = Constant $ getConstant i
getConstant (Constant c) = c
getConstant (d :* v) = 0
getConstant (LinearCombination xs) = P.sum $ map getConstant xs
getVars :: Algebra x -> [(x,Double)]
getVars (d :* v) = [(v,d)]
getVars (Constant d) = []
getVars (LinearCombination xs) = map aux $ filter (\u -> case u of
d :* v -> True
_ -> False) xs
where aux (d :* v) = (v,d)
buildConstraint :: forall x. (Hashable x, Eq x) => Constraint x -> I.Bound [I.Variable x]
buildConstraint constr = case constr of
(_ :< _ ) -> lhs I.:< rhs
(_ := _ ) -> lhs I.:= rhs
(_ :> _ ) -> lhs I.:> rhs
where
v = simplify (ol + (negate or) )
vars :: [(x,Double)] = getVars v
lhs :: [I.Variable x] = map (\(v,d) -> d I.:# v) vars
rhs = negate $ getConstant v
ol = case constr of
(a :< _) -> a
(a := _) -> a
(a :> _) -> a
or = case constr of
(_ :< b) -> b
(_ := b) -> b
(_ :> b) -> b
buildConstraints :: (Eq x, Hashable x) => Constraints x -> I.Constraints x
buildConstraints (Constraints constrs) = I.Constraints $ map buildConstraint constrs
buildObjective :: forall x. (Eq x, Hashable x) => Optimization x -> I.Optimization x
buildObjective inp = case inp of
Minimize _ -> I.Minimize obj
Maximize _ -> I.Maximize obj
where
v = simplify (o)
vars :: [(x,Double)] = getVars v
obj :: [I.Variable x] = map (\(v,d) -> d I.:# v) vars
o = case inp of
Minimize vs -> vs
Maximize vs -> vs
data LinearProblem a = LP (Optimization a) (Constraints a) [(a, Maybe Double, Maybe Double)]
-- deriving Show
data MixedIntegerProblem a = MILP (Optimization a) (Constraints a) [(a, Maybe Double, Maybe Double)]
[(a,I.Type)]
-- deriving Show
-- class Algabraic a b | a -> b where
-- liftAlg :: a -> Algebra b
--
-- (+:) :: forall a b c. (Algabraic a, Algabraic b) => a -> b -> Algebra c
-- a +: b = (liftAlg a :: Algebra c) + (liftAlg b :: Algebra c)
--
data Var = X
| Y
deriving (Eq, Show)
instance Generic Var
--
-- instance forall b. Algabraic Double b where
-- liftAlg d = (Constant d :: Algebra b)
--
-- -- instance Algabraic (Algebra x) where
-- -- liftAlg a = unsafeCoerce a
--
-- test1 = (1 :* X) :< 3.0
--
class Constrainable a b c | a b -> c where
(<:) :: a -> b -> c
(>:) :: a -> b -> c
(=:) :: a -> b -> c
instance (Real a, Num a) => Constrainable (Algebra x) (a) (Constraint x) where
lhs <: rhs = lhs :< (Constant $ realToFrac rhs)
lhs >: rhs = lhs :> (Constant $ realToFrac rhs)
lhs =: rhs = lhs := (Constant $ realToFrac rhs)
instance (Real a, Num a) => Constrainable a (Algebra x) (Constraint x) where
lhs <: rhs = (Constant $ realToFrac lhs) :< rhs
lhs >: rhs = (Constant $ realToFrac lhs) :> rhs
lhs =: rhs = (Constant $ realToFrac lhs) := rhs
class Mult a b c | a b -> c where
(*) :: a -> b -> c
instance Mult Double Double Double where
a * b = a P.* b
-- instance Mult a Double (Algebra a) where
-- v * b = b :* v
instance Mult (Algebra a) Double (Algebra a) where
(Constant c) * b = Constant (b P.* c)
(c :* x) * b = (c P.* b) :* x
(LinearCombination xs) * b = LinearCombination $ map (*b) xs
test = 1 :* X <: (3.0 :: Double)