module Numeric.Search.Combinator.Monadic where
import Control.Applicative((<$>))
import Data.Sequence as Seq
import Prelude hiding (init, pred)
type BinarySearchM m a b =
InitializerM m a b ->
CutterM m a b ->
PredicateM m a b ->
m (Seq (Range a b))
data BookEnd a b
= REnd !a !b
| LEnd !a !b
deriving (Eq, Show)
type Range a b = ((a,a),b)
type PredicateM m a b = a -> m b
type InitializerM m a b = PredicateM m a b -> m (Seq (BookEnd a b))
type CutterM m a b = PredicateM m a b -> a -> a -> m (Maybe a)
initConstM :: (Monad m) => a -> a -> InitializerM m a b
initConstM x1 x2 pred = do
y1 <- pred x1
y2 <- pred x2
return $ Seq.fromList [LEnd x1 y1, REnd x1 y1,LEnd x2 y2, REnd x2 y2]
initBoundedM :: (Monad m, Bounded a) => InitializerM m a b
initBoundedM = initConstM minBound maxBound
cutIntegralM :: (Monad m, Integral a) => CutterM m a b
cutIntegralM _ x1 x2
| x1+1 >= x2 = return Nothing
| otherwise = return $ Just ((x1+1)`div`2 + x2 `div`2)
searchWithM :: forall m a b. (Functor m, Monad m, Eq b) => BinarySearchM m a b
searchWithM init cut pred = do
seq0 <- init pred
finalize <$> go seq0
where
go :: Seq (BookEnd a b) -> m (Seq (BookEnd a b))
go seq0 = case viewl seq0 of
EmptyL -> return seq0
(x1 :< seq1) -> do
let skip = (x1 <|) <$> go seq1
case viewl seq1 of
EmptyL -> skip
(x2 :< seq2) -> case (x1,x2) of
(REnd a1 b1, LEnd a2 b2) -> case b1==b2 of
True -> go seq2
False -> do
y1 <- drillDown a1 b1 a2 b2
y2 <- go seq2
return $ y1 >< y2
_ -> skip
drillDown :: a -> b -> a -> b -> m (Seq (BookEnd a b))
drillDown x1 y1 x2 y2 = do
mc <- cut pred x1 x2
case mc of
Nothing -> return $ Seq.fromList [REnd x1 y1, LEnd x2 y2]
Just x3 -> do
y3 <- pred x3
case () of
_ | y3==y1 -> drillDown x3 y3 x2 y2
_ | y3==y2 -> drillDown x1 y1 x3 y3
_ -> do
y1 <- drillDown x1 y1 x3 y3
y2 <- drillDown x3 y3 x2 y2
return $ y1 >< y2
finalize :: Seq (BookEnd a b) -> Seq (Range a b)
finalize seqE = case viewl seqE of
EmptyL -> Seq.empty
(x1 :< seqE1) -> case viewl seqE1 of
EmptyL -> finalize seqE1
(x2 :< seqE2) -> case (x1,x2) of
(LEnd x1 y1, REnd x2 y2) | y1==y2 -> ((x1,x2), y1) <| finalize seqE2
_ -> finalize seqE1