module Control.Monad.BoundedDFS (
MonadCost(..)
, UnboundedDFS(..)
, BoundedDFS(..)
, runBoundedDFS
, evalBoundedDFS
, execBoundedDFS
, BranchAndBound(..)
, runBranchAndBound
, evalBranchAndBound
, execBranchAndBound
) where
import Control.Monad
import Control.Monad.State
import Control.Monad.Reader
class Monad m => MonadCost c m | m -> c where
updateCost :: (c -> c) -> m ()
newtype UnboundedDFS c a = UnboundedDFS { runUnboundedDFS :: Maybe a }
deriving( Monad )
instance MonadCost c (UnboundedDFS c) where
updateCost _ = return ()
instance MonadPlus (UnboundedDFS c) where
mzero = UnboundedDFS $ mzero
(UnboundedDFS m1) `mplus` (UnboundedDFS m2) = UnboundedDFS $ m1 `mplus` m2
newtype BoundedDFS c a = BoundedDFS { unBoundedDFS :: ReaderT (c -> Bool) (StateT c Maybe) a }
deriving( Monad )
instance MonadCost c (BoundedDFS c) where
updateCost f = BoundedDFS $ do
cond <- ask
b <- get
let b' = f b
guard (cond b')
put b'
instance MonadPlus (BoundedDFS c) where
mzero = BoundedDFS mzero
m `mplus` _ = m
runBoundedDFS :: BoundedDFS c a -> (c -> Bool) -> c -> Maybe (a, c)
runBoundedDFS m cond = runStateT (runReaderT (unBoundedDFS m) cond)
evalBoundedDFS :: BoundedDFS c a -> (c -> Bool) -> c -> Maybe a
evalBoundedDFS m cond = fmap fst . runBoundedDFS m cond
execBoundedDFS :: BoundedDFS c a -> (c -> Bool) -> c -> Maybe c
execBoundedDFS m cond = fmap snd . runBoundedDFS m cond
newtype BranchAndBound c a =
BranchAndBound {
unBranchAndBound :: ReaderT (c -> Bool) (StateT c Maybe) a
}
deriving( Monad )
runBranchAndBound :: Cost c => BranchAndBound c a -> c -> Maybe (a, c)
runBranchAndBound m bound
| zeroCost `lessEqCost` bound =
runStateT (runReaderT (unBranchAndBound m) (`lessEqCost` bound)) zeroCost
| otherwise = mzero
evalBranchAndBound :: Cost c => BranchAndBound c a -> c -> Maybe a
evalBranchAndBound m = fmap fst . runBranchAndBound m
execBranchAndBound :: Cost c => BranchAndBound c a -> c -> Maybe c
execBranchAndBound m = fmap snd . runBranchAndBound m
instance MonadCost c (BranchAndBound c) where
updateCost f = BranchAndBound $ do
cond <- ask
b <- get
let b' = f b
guard (cond b')
put b'
class Eq c => Cost c where
zeroCost :: c
addCosts :: c -> c -> c
subtractCosts :: c -> c -> c
lessCost :: c -> c -> Bool
lessEqCost :: c -> c -> Bool
lessCost c1 c2 = lessEqCost c1 c2 && c1 /= c2
lessEqCost c1 c2 = lessCost c1 c2 || c1 == c2
instance (Ord a, Num a) => Cost (Maybe a) where
zeroCost = return 0
addCosts = liftM2 (+)
subtractCosts Nothing Nothing = error "Cost (Maybe a): subtractCosts: cannot subtract infinity from infinity"
subtractCosts Nothing _ = Nothing
subtractCosts (Just x) (Just y) = Just (x y)
subtractCosts _ Nothing = error "Cost (Maybe a): subtractCosts: cannot subtract infinity"
lessCost Nothing Nothing = error "Cost (Maybe a): lessCost: cannot compare infinity with infinity"
lessCost _ Nothing = True
lessCost (Just x) (Just y) = x < y
lessCost _ _ = error "Cost (Maybe a): lessCost: does this make sense?"
lessEqCost Nothing Nothing = error "Cost (Maybe a): lessEqCost: cannot compare infinity with infinity"
lessEqCost _ Nothing = True
lessEqCost (Just x) (Just y) = x <= y
lessEqCost _ _ = error "Cost (Maybe a): lessEqcost: does this make sense?"
instance Cost c => MonadPlus (BranchAndBound c) where
mzero = BranchAndBound $ mzero
m1 `mplus` m2 = BranchAndBound $
(do
used <- get
x1 <- unBranchAndBound m1
m1Used <- get
(local (const (`lessCost` (m1Used `subtractCosts` used))) $ do
put zeroCost
x2 <- unBranchAndBound m2
modify (used `addCosts`)
return x2
`mplus`
return x1)
`mplus`
unBranchAndBound m2)