{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{- |
Generic implementation of a monad that collects constraints
over multiple stages.
It can be used to test solvers that allow for warm start
or for solvers that do not allow for warm start at all
(like GLPK's interior point solver).
-}
module Numeric.LinearProgramming.Monad (
   T,
   run,
   lift,
   ) where

import Numeric.LinearProgramming.Common

import qualified Data.Array.Comfort.Storable as Array
import qualified Data.Array.Comfort.Shape as Shape

import qualified Control.Monad.Trans.RWS as MRWS
import Control.Monad (when)
import Control.Applicative (Applicative)


newtype T sh a =
   Cons (MRWS.RWS
            (sh, Bounds (Shape.Index sh))
            ()
            (Constraints Double (Shape.Index sh))
            a)
      deriving (forall a b. a -> T sh b -> T sh a
forall a b. (a -> b) -> T sh a -> T sh b
forall sh a b. a -> T sh b -> T sh a
forall sh a b. (a -> b) -> T sh a -> T sh b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> T sh b -> T sh a
$c<$ :: forall sh a b. a -> T sh b -> T sh a
fmap :: forall a b. (a -> b) -> T sh a -> T sh b
$cfmap :: forall sh a b. (a -> b) -> T sh a -> T sh b
Functor, forall sh. Functor (T sh)
forall a. a -> T sh a
forall sh a. a -> T sh a
forall a b. T sh a -> T sh b -> T sh a
forall a b. T sh a -> T sh b -> T sh b
forall a b. T sh (a -> b) -> T sh a -> T sh b
forall sh a b. T sh a -> T sh b -> T sh a
forall sh a b. T sh a -> T sh b -> T sh b
forall sh a b. T sh (a -> b) -> T sh a -> T sh b
forall a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
forall sh a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. T sh a -> T sh b -> T sh a
$c<* :: forall sh a b. T sh a -> T sh b -> T sh a
*> :: forall a b. T sh a -> T sh b -> T sh b
$c*> :: forall sh a b. T sh a -> T sh b -> T sh b
liftA2 :: forall a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
$cliftA2 :: forall sh a b c. (a -> b -> c) -> T sh a -> T sh b -> T sh c
<*> :: forall a b. T sh (a -> b) -> T sh a -> T sh b
$c<*> :: forall sh a b. T sh (a -> b) -> T sh a -> T sh b
pure :: forall a. a -> T sh a
$cpure :: forall sh a. a -> T sh a
Applicative, forall sh. Applicative (T sh)
forall a. a -> T sh a
forall sh a. a -> T sh a
forall a b. T sh a -> T sh b -> T sh b
forall a b. T sh a -> (a -> T sh b) -> T sh b
forall sh a b. T sh a -> T sh b -> T sh b
forall sh a b. T sh a -> (a -> T sh b) -> T sh b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> T sh a
$creturn :: forall sh a. a -> T sh a
>> :: forall a b. T sh a -> T sh b -> T sh b
$c>> :: forall sh a b. T sh a -> T sh b -> T sh b
>>= :: forall a b. T sh a -> (a -> T sh b) -> T sh b
$c>>= :: forall sh a b. T sh a -> (a -> T sh b) -> T sh b
Monad)


run ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   sh -> Bounds ix -> T sh a -> a
run :: forall sh ix a.
(Indexed sh, Index sh ~ ix) =>
sh -> Bounds ix -> T sh a -> a
run sh
shape Bounds ix
bounds (Cons RWS (sh, Bounds (Index sh)) () (Constraints Double (Index sh)) a
act) =
   forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall r w s a. RWS r w s a -> r -> s -> (a, w)
MRWS.evalRWS RWS (sh, Bounds (Index sh)) () (Constraints Double (Index sh)) a
act (sh
shape, Bounds ix
bounds) []

lift ::
   (Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix) =>
   (Bounds ix -> Constraints Double ix -> (Direction, Objective sh) -> a) ->
   Constraints Double ix -> (Direction, Objective sh) -> T sh a
lift :: forall sh ix a.
(Eq sh, Indexed sh, Index sh ~ ix) =>
(Bounds ix
 -> Constraints Double ix -> (Direction, Objective sh) -> a)
-> Constraints Double ix -> (Direction, Objective sh) -> T sh a
lift Bounds ix
-> [Inequality [Term Double ix]] -> (Direction, Objective sh) -> a
solver [Inequality [Term Double ix]]
constrs dirObj :: (Direction, Objective sh)
dirObj@(Direction
_dir,Objective sh
obj) = forall sh a.
RWS (sh, Bounds (Index sh)) () (Constraints Double (Index sh)) a
-> T sh a
Cons forall a b. (a -> b) -> a -> b
$ do
   (sh
shape,Bounds ix
bounds) <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
MRWS.ask
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (sh
shape forall a. Eq a => a -> a -> Bool
/= forall sh a. Array sh a -> sh
Array.shape Objective sh
obj) forall a b. (a -> b) -> a -> b
$
      forall a. HasCallStack => [Char] -> a
error [Char]
"LinearProgramming.Monad.solve: objective shape mismatch"
   forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
MRWS.modify ([Inequality [Term Double ix]]
constrsforall a. [a] -> [a] -> [a]
++)
   [Inequality [Term Double ix]]
allConstrs <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
MRWS.get
   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bounds ix
-> [Inequality [Term Double ix]] -> (Direction, Objective sh) -> a
solver Bounds ix
bounds [Inequality [Term Double ix]]
allConstrs (Direction, Objective sh)
dirObj