```-- | Monadic binary search combinators.

{-# LANGUAGE ScopedTypeVariables #-}

import           Control.Applicative((<\$>))
import           Data.Sequence as Seq
import           Prelude hiding (init, pred)

-- | The generalized type for binary search functions.
type BinarySearchM m a b =
InitializerM m a b ->
CutterM m a b ->
PredicateM m a b ->
m (Seq (Range a b))

-- | 'BookEnd' comes in order [LEnd, REnd, LEnd, REnd ...], and
-- represents the ongoing state of the search results.
-- Two successive 'BookEnd' @LEnd x1 y1@, @REnd x2 y1@ represents a
-- claim that @pred x == y1@ for all @x@ such that @x1 <= x <= x2@ .
-- Like this:
--
-- > is (x^2 > 20000) ?
-- >
-- > LEnd    REnd  LEnd     REnd
-- > 0        100  200       300
-- > |_ False _|    |_ True  _|

data BookEnd a b
= REnd !a !b
| LEnd !a !b
deriving (Eq, Show)

-- | 'Range' @((x1,x2),y)@ denotes that @pred x == y@ for all
-- @x1 <= x <= x2@ .
type Range a b = ((a,a),b)

-- | 'PredicateM' @m a b@ calculates the predicate in the context @m@.
type PredicateM m a b = a -> m b

-- | 'InitializerM' generates the initial set of ranges.
type InitializerM m a b = PredicateM m a b -> m (Seq (BookEnd a b))

-- | 'CutterM' @p x1 x2@ decides if we should further investigate the
-- gap between @x1@ and @x2@. If so, it gives a new value @x3@ wrapped
-- in a 'Just'. 'CutterM' may optionally use the predicate.
type CutterM m a b = PredicateM m a b -> a -> a -> m (Maybe a)

-- | an initializer with the initial range specified.
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]

-- | an initializer that searches for the full bound.
initBoundedM :: (Monad m, Bounded a) => InitializerM m a b
initBoundedM = initConstM minBound maxBound

-- | a cutter for integral types.
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)

-- | The most generalized version of search.
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 -- merge the two regions
False ->  do
y1 <- drillDown a1 b1 a2 b2
y2 <- go seq2
return \$ y1 >< y2
_ -> skip

-- precondition : b1 /= b2
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
```