{-# LANGUAGE Rank2Types #-}

-- |
-- Module      : Control.Monad.SearchTree
-- Copyright   : Sebastian Fischer
-- License     : BSD3
--
-- Maintainer  : Niels Bunkenburg (nbu@informatik.uni-kiel.de)
-- Stability   : experimental
-- Portability : portable
--
-- This Haskell library provides an implementation of the MonadPlus
-- type class that represents the search space as a tree whose
-- constructors represent mzero, return, and mplus.
--
-- Such a tree can be used to implement different search strategies,
-- e.g., by using a queue. It can also be used as a basis for parallel
-- search strategies that evaluate different parts of the search space
-- concurrently.
module Control.Monad.SearchTree ( SearchTree(..), Search, searchTree ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Fix

-- |
-- The type @SearchTree a@ represents non-deterministic computations
-- as a tree structure.
data SearchTree a = None | One a | Choice (SearchTree a) (SearchTree a)
 deriving Int -> SearchTree a -> ShowS
[SearchTree a] -> ShowS
SearchTree a -> String
(Int -> SearchTree a -> ShowS)
-> (SearchTree a -> String)
-> ([SearchTree a] -> ShowS)
-> Show (SearchTree a)
forall a. Show a => Int -> SearchTree a -> ShowS
forall a. Show a => [SearchTree a] -> ShowS
forall a. Show a => SearchTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SearchTree a] -> ShowS
$cshowList :: forall a. Show a => [SearchTree a] -> ShowS
show :: SearchTree a -> String
$cshow :: forall a. Show a => SearchTree a -> String
showsPrec :: Int -> SearchTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> SearchTree a -> ShowS
Show

instance Functor SearchTree where
  fmap :: (a -> b) -> SearchTree a -> SearchTree b
fmap a -> b
_ SearchTree a
None         = SearchTree b
forall a. SearchTree a
None
  fmap a -> b
f (One a
x)      = b -> SearchTree b
forall a. a -> SearchTree a
One (a -> b
f a
x)
  fmap a -> b
f (Choice SearchTree a
s SearchTree a
t) = SearchTree b -> SearchTree b -> SearchTree b
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice ((a -> b) -> SearchTree a -> SearchTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f SearchTree a
s) ((a -> b) -> SearchTree a -> SearchTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f SearchTree a
t)

instance Applicative SearchTree where
  pure :: a -> SearchTree a
pure  = a -> SearchTree a
forall a. a -> SearchTree a
One

  <*> :: SearchTree (a -> b) -> SearchTree a -> SearchTree b
(<*>) = SearchTree (a -> b) -> SearchTree a -> SearchTree b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Alternative SearchTree where
  empty :: SearchTree a
empty = SearchTree a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

  <|> :: SearchTree a -> SearchTree a -> SearchTree a
(<|>) = SearchTree a -> SearchTree a -> SearchTree a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Monad SearchTree where
  SearchTree a
None >>= :: SearchTree a -> (a -> SearchTree b) -> SearchTree b
>>= a -> SearchTree b
_       = SearchTree b
forall a. SearchTree a
None
  One a
x >>= a -> SearchTree b
f      = a -> SearchTree b
f a
x
  Choice SearchTree a
s SearchTree a
t >>= a -> SearchTree b
f = SearchTree b -> SearchTree b -> SearchTree b
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice (SearchTree a
s SearchTree a -> (a -> SearchTree b) -> SearchTree b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SearchTree b
f) (SearchTree a
t SearchTree a -> (a -> SearchTree b) -> SearchTree b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SearchTree b
f)

instance MonadFail SearchTree where
  fail :: String -> SearchTree a
fail String
_ = SearchTree a
forall a. SearchTree a
None

instance MonadPlus SearchTree where
  mzero :: SearchTree a
mzero = SearchTree a
forall a. SearchTree a
None

  mplus :: SearchTree a -> SearchTree a -> SearchTree a
mplus = SearchTree a -> SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice

instance MonadFix SearchTree where
  mfix :: (a -> SearchTree a) -> SearchTree a
mfix a -> SearchTree a
f = case (SearchTree a -> SearchTree a) -> SearchTree a
forall a. (a -> a) -> a
fix (a -> SearchTree a
f (a -> SearchTree a)
-> (SearchTree a -> a) -> SearchTree a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree a -> a
forall p. SearchTree p -> p
unOne) of
             SearchTree a
None       -> SearchTree a
forall a. SearchTree a
None
             One a
x      -> a -> SearchTree a
forall a. a -> SearchTree a
One a
x
             Choice SearchTree a
_ SearchTree a
_ -> SearchTree a -> SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a -> SearchTree a
Choice ((a -> SearchTree a) -> SearchTree a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a
leftChoice (SearchTree a -> SearchTree a)
-> (a -> SearchTree a) -> a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SearchTree a
f)) ((a -> SearchTree a) -> SearchTree a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (SearchTree a -> SearchTree a
forall a. SearchTree a -> SearchTree a
rightChoice (SearchTree a -> SearchTree a)
-> (a -> SearchTree a) -> a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SearchTree a
f))
    where
      unOne :: SearchTree p -> p
unOne (One p
x) = p
x
      unOne SearchTree p
_       = String -> p
forall a. HasCallStack => String -> a
error String
"mfix SearchTree: not One"
      leftChoice :: SearchTree a -> SearchTree a
leftChoice (Choice SearchTree a
s SearchTree a
_) = SearchTree a
s
      leftChoice SearchTree a
_            = String -> SearchTree a
forall a. HasCallStack => String -> a
error String
"mfix SearchTree: not Choice"
      rightChoice :: SearchTree a -> SearchTree a
rightChoice (Choice SearchTree a
_ SearchTree a
t) = SearchTree a
t
      rightChoice SearchTree a
_            = String -> SearchTree a
forall a. HasCallStack => String -> a
error String
"mfix SearchTree: not Choice"

-- |
-- Another search monad based on continuations that produce search
-- trees.
newtype Search a = Search
  { -- | Passes a continuation to a monadic search action.
    Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search :: forall r. (a -> SearchTree r) -> SearchTree r
  }

-- | Computes the @SearchTree@ representation of a @Search@ action.
searchTree :: Search a -> SearchTree a
searchTree :: Search a -> SearchTree a
searchTree Search a
a = Search a -> (a -> SearchTree a) -> SearchTree a
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a a -> SearchTree a
forall a. a -> SearchTree a
One

instance Functor Search where
  fmap :: (a -> b) -> Search a -> Search b
fmap a -> b
f Search a
a = (forall r. (b -> SearchTree r) -> SearchTree r) -> Search b
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\b -> SearchTree r
k -> Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a (b -> SearchTree r
k (b -> SearchTree r) -> (a -> b) -> a -> SearchTree r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Applicative Search where
  pure :: a -> Search a
pure a
x = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search ((a -> SearchTree r) -> a -> SearchTree r
forall a b. (a -> b) -> a -> b
$ a
x)

  <*> :: Search (a -> b) -> Search a -> Search b
(<*>) = Search (a -> b) -> Search a -> Search b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Alternative Search where
  empty :: Search a
empty = Search a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

  <|> :: Search a -> Search a -> Search a
(<|>) = Search a -> Search a -> Search a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Monad Search where
  Search a
a >>= :: Search a -> (a -> Search b) -> Search b
>>= a -> Search b
f = (forall r. (b -> SearchTree r) -> SearchTree r) -> Search b
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\b -> SearchTree r
k -> Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a (\a
x -> Search b -> (b -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search (a -> Search b
f a
x) b -> SearchTree r
k))

instance MonadFail Search where
  fail :: String -> Search a
fail String
_ = Search a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance MonadPlus Search where
  mzero :: Search a
mzero       = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (SearchTree r -> (a -> SearchTree r) -> SearchTree r
forall a b. a -> b -> a
const SearchTree r
forall (m :: * -> *) a. MonadPlus m => m a
mzero)

  Search a
a mplus :: Search a -> Search a -> Search a
`mplus` Search a
b = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\a -> SearchTree r
k -> Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a a -> SearchTree r
k SearchTree r -> SearchTree r -> SearchTree r
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Search a -> (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
b a -> SearchTree r
k)

instance MonadFix Search where
  mfix :: (a -> Search a) -> Search a
mfix a -> Search a
f = (forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
forall a.
(forall r. (a -> SearchTree r) -> SearchTree r) -> Search a
Search (\a -> SearchTree r
k -> (a -> SearchTree a) -> SearchTree a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Search a -> SearchTree a
forall a. Search a -> SearchTree a
searchTree (Search a -> SearchTree a) -> (a -> Search a) -> a -> SearchTree a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Search a
f) SearchTree a -> (a -> SearchTree r) -> SearchTree r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SearchTree r
k)