LP.hs

{-# 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)