{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Math.Programming.Dsl where

import Data.Functor
import qualified Data.Text as T
import Math.Programming.LinExpr
import Math.Programming.Types
import Text.Printf

-- | Create an objective to be minimized.
minimize :: MonadLP v c o m => Expr v -> m o
minimize :: forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m o
minimize Expr v
objectiveExpr = do
  o
objective <- Expr v -> m o
forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m o
addObjective Expr v
objectiveExpr
  o -> Sense -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => o -> Sense -> m ()
setObjectiveSense o
objective Sense
Minimization
  o -> m o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
objective

-- | Create an objective to be maximized.
maximize :: MonadLP v c o m => Expr v -> m o
maximize :: forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m o
maximize Expr v
objectiveExpr = do
  o
objective <- Expr v -> m o
forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m o
addObjective Expr v
objectiveExpr
  o -> Sense -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => o -> Sense -> m ()
setObjectiveSense o
objective Sense
Maximization
  o -> m o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
objective

-- | Get the value of a linear expression in the current solution.
evalExpr :: MonadLP v c o m => Expr v -> m Double
evalExpr :: forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m Double
evalExpr Expr v
expr = (v -> m Double) -> Expr v -> m (LinExpr Double Double)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse v -> m Double
forall v c o (m :: * -> *). MonadLP v c o m => v -> m Double
getVariableValue Expr v
expr m (LinExpr Double Double)
-> (LinExpr Double Double -> Double) -> m Double
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> LinExpr Double Double -> Double
forall a. Num a => LinExpr a a -> a
eval

-- | Create a new free variable.
free :: MonadLP v c o m => m v
free :: forall v c o (m :: * -> *). MonadLP v c o m => m v
free = m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
`within` Bounds
Free

-- | Create a new non-negative variable.
nonNeg :: MonadLP v c o m => m v
nonNeg :: forall v c o (m :: * -> *). MonadLP v c o m => m v
nonNeg = m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
`within` Bounds
NonNegativeReals

-- | Create a new non-positive variable.
nonPos :: MonadLP v c o m => m v
nonPos :: forall v c o (m :: * -> *). MonadLP v c o m => m v
nonPos = m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
`within` Bounds
NonPositiveReals

-- | Create a new variable bounded between two values.
bounded :: MonadLP v c o m => Double -> Double -> m v
bounded :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Double -> Double -> m v
bounded Double
lo Double
hi = m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
within m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable (Double -> Double -> Bounds
Interval Double
lo Double
hi)

-- | Constrain a variable to take on certain values.
--
-- This function is designed to be used as an infix operator, e.g.
--
-- @
-- 'integer' \``within`\` 'Interval 3 7'
-- @
--
-- creates an integer variable that can take on values 3, 4, 5, 6, or
-- 7.
within :: MonadLP v c o m => m v -> Bounds -> m v
within :: forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
within m v
makeVar Bounds
bounds = do
  v
variable <- m v
makeVar
  v -> Bounds -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => v -> Bounds -> m ()
setVariableBounds v
variable Bounds
bounds
  v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
variable

-- | Create an integer-valued variable.
integer :: MonadIP v c o m => m v
integer :: forall v c o (m :: * -> *). MonadIP v c o m => m v
integer = m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable m v -> Domain -> m v
forall v c o (m :: * -> *). MonadIP v c o m => m v -> Domain -> m v
`asKind` Domain
Integer m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
`within` Bounds
Free

-- | Create a binary variable.
binary :: MonadIP v c o m => m v
binary :: forall v c o (m :: * -> *). MonadIP v c o m => m v
binary = m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable m v -> Domain -> m v
forall v c o (m :: * -> *). MonadIP v c o m => m v -> Domain -> m v
`asKind` Domain
Binary

-- | Create an integer-value variable that takes on non-negative values.
nonNegInteger :: MonadIP v c o m => m v
nonNegInteger :: forall v c o (m :: * -> *). MonadIP v c o m => m v
nonNegInteger = m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable m v -> Domain -> m v
forall v c o (m :: * -> *). MonadIP v c o m => m v -> Domain -> m v
`asKind` Domain
Integer m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
`within` Bounds
NonNegativeReals

-- | Create an integer-value variable that takes on non-positive values.
nonPosInteger :: MonadIP v c o m => m v
nonPosInteger :: forall v c o (m :: * -> *). MonadIP v c o m => m v
nonPosInteger = m v
forall v c o (m :: * -> *). MonadLP v c o m => m v
addVariable m v -> Domain -> m v
forall v c o (m :: * -> *). MonadIP v c o m => m v -> Domain -> m v
`asKind` Domain
Integer m v -> Bounds -> m v
forall v c o (m :: * -> *). MonadLP v c o m => m v -> Bounds -> m v
`within` Bounds
NonPositiveReals

-- | Set the type of a variable.
--
-- This function is designed to be used as an infix operator, e.g.
--
-- @
-- 'free' \``asKind`\` 'Binary'
-- @
asKind :: MonadIP v c o m => m v -> Domain -> m v
asKind :: forall v c o (m :: * -> *). MonadIP v c o m => m v -> Domain -> m v
asKind m v
make Domain
dom = do
  v
variable <- m v
make
  v -> Domain -> m ()
forall v c o (m :: * -> *). MonadIP v c o m => v -> Domain -> m ()
setVariableDomain v
variable Domain
dom
  v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
variable

-- | A less-than or equal-to constraint
(.<=.) :: MonadLP v c o m => Expr v -> Expr v -> m c
.<=. :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
(.<=.) Expr v
x Expr v
y = Inequality (Expr v) -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Inequality (Expr v) -> m c
addConstraint (Inequality (Expr v) -> m c) -> Inequality (Expr v) -> m c
forall a b. (a -> b) -> a -> b
$ Ordering -> Expr v -> Expr v -> Inequality (Expr v)
forall a. Ordering -> a -> a -> Inequality a
Inequality Ordering
LT Expr v
x Expr v
y

-- | A less-than or equal-to constraint with a numeric left-hand side
(<=.) :: MonadLP v c o m => Double -> Expr v -> m c
<=. :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Double -> Expr v -> m c
(<=.) Double
x Expr v
y = Double -> Expr v
forall a b. a -> LinExpr a b
con Double
x Expr v -> Expr v -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
.<=. Expr v
y

-- | A less-than or equal-to constraint with a numeric right-hand side
(.<=) :: MonadLP v c o m => Expr v -> Double -> m c
.<= :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Double -> m c
(.<=) Expr v
x Double
y = Expr v
x Expr v -> Expr v -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
.<=. Double -> Expr v
forall a b. a -> LinExpr a b
con Double
y

-- | A greater-than or equal-to constraint
(.>=.) :: MonadLP v c o m => Expr v -> Expr v -> m c
.>=. :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
(.>=.) Expr v
x Expr v
y = Inequality (Expr v) -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Inequality (Expr v) -> m c
addConstraint (Inequality (Expr v) -> m c) -> Inequality (Expr v) -> m c
forall a b. (a -> b) -> a -> b
$ Ordering -> Expr v -> Expr v -> Inequality (Expr v)
forall a. Ordering -> a -> a -> Inequality a
Inequality Ordering
GT Expr v
x Expr v
y

-- | A greater-than or equal-to constraint with a numeric left-hand side
(>=.) :: MonadLP v c o m => Double -> Expr v -> m c
>=. :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Double -> Expr v -> m c
(>=.) Double
x Expr v
y = Double -> Expr v
forall a b. a -> LinExpr a b
con Double
x Expr v -> Expr v -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
.>=. Expr v
y

-- | A greater-than or equal-to constraint with a numeric right-hand side
(.>=) :: MonadLP v c o m => Expr v -> Double -> m c
.>= :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Double -> m c
(.>=) Expr v
x Double
y = Expr v
x Expr v -> Expr v -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
.>=. Double -> Expr v
forall a b. a -> LinExpr a b
con Double
y

-- | An equality constraint
(.==.) :: MonadLP v c o m => Expr v -> Expr v -> m c
.==. :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
(.==.) Expr v
x Expr v
y = Inequality (Expr v) -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Inequality (Expr v) -> m c
addConstraint (Inequality (Expr v) -> m c) -> Inequality (Expr v) -> m c
forall a b. (a -> b) -> a -> b
$ Ordering -> Expr v -> Expr v -> Inequality (Expr v)
forall a. Ordering -> a -> a -> Inequality a
Inequality Ordering
EQ Expr v
x Expr v
y

-- | An equality constraint with a numeric left-hand side
(==.) :: MonadLP v c o m => Double -> Expr v -> m c
==. :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Double -> Expr v -> m c
(==.) Double
x Expr v
y = Double -> Expr v
forall a b. a -> LinExpr a b
con Double
x Expr v -> Expr v -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
.==. Expr v
y

-- | An equality constraint with a numeric right-hand side
(.==) :: MonadLP v c o m => Expr v -> Double -> m c
.== :: forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Double -> m c
(.==) Expr v
x Double
y = Expr v
x Expr v -> Expr v -> m c
forall v c o (m :: * -> *).
MonadLP v c o m =>
Expr v -> Expr v -> m c
.==. Double -> Expr v
forall a b. a -> LinExpr a b
con Double
y

infix 4 <=.

infix 4 .<=

infix 4 .<=.

infix 4 >=.

infix 4 .>=

infix 4 .>=.

infix 4 ==.

infix 4 .==

infix 4 .==.

formatExpr :: MonadLP v c o m => Expr v -> m T.Text
formatExpr :: forall v c o (m :: * -> *). MonadLP v c o m => Expr v -> m Text
formatExpr = (v -> m Text) -> Expr v -> m Text
forall (m :: * -> *) v.
Monad m =>
(v -> m Text) -> Expr v -> m Text
formatExpr' v -> m Text
forall v c o (m :: * -> *). MonadLP v c o m => v -> m Text
getVariableName

formatExpr' :: Monad m => (v -> m T.Text) -> Expr v -> m T.Text
formatExpr' :: forall (m :: * -> *) v.
Monad m =>
(v -> m Text) -> Expr v -> m Text
formatExpr' v -> m Text
nameOf (LinExpr [(Double, v)]
terms Double
coef) = do
  [(Double, Text)]
names <- ((Double, v) -> m (Double, Text))
-> [(Double, v)] -> m [(Double, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((v -> m Text) -> (Double, v) -> m (Double, Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse v -> m Text
nameOf) [(Double, v)]
terms
  let strTerms :: [Text]
strTerms = ((Double, Text) -> Text) -> [(Double, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack (String -> Text)
-> ((Double, Text) -> String) -> (Double, Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Text -> String) -> (Double, Text) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> Double -> Text -> String
forall r. PrintfType r => String -> r
printf String
"%f * %s")) [(Double, Text)]
names
  Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
" + " ([Text]
strTerms [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [String -> Text
T.pack (Double -> String
forall a. Show a => a -> String
show Double
coef)])

withVariableName :: MonadLP v c o m => m v -> T.Text -> m v
withVariableName :: forall v c o (m :: * -> *). MonadLP v c o m => m v -> Text -> m v
withVariableName m v
mv Text
name = do
  v
v <- m v
mv
  v -> Text -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => v -> Text -> m ()
setVariableName v
v Text
name
  v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v

withConstraintName :: MonadLP v c o m => m c -> T.Text -> m c
withConstraintName :: forall v c o (m :: * -> *). MonadLP v c o m => m c -> Text -> m c
withConstraintName m c
mc Text
name = do
  c
c <- m c
mc
  c -> Text -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => c -> Text -> m ()
setConstraintName c
c Text
name
  c -> m c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c

withObjectiveName :: MonadLP v c o m => m o -> T.Text -> m o
withObjectiveName :: forall v c o (m :: * -> *). MonadLP v c o m => m o -> Text -> m o
withObjectiveName m o
mo Text
name = do
  o
o <- m o
mo
  o -> Text -> m ()
forall v c o (m :: * -> *). MonadLP v c o m => o -> Text -> m ()
setObjectiveName o
o Text
name
  o -> m o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
o