{-# 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

-- |
-- 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 :: forall a b. (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 :: forall a. a -> SearchTree a
pure  = a -> SearchTree a
forall (m :: * -> *) a. Monad m => a -> m a
return

  <*> :: forall a b. 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 :: forall a. SearchTree a
empty = SearchTree a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

  <|> :: forall a. 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
  return :: forall a. a -> SearchTree a
return           = a -> SearchTree a
forall a. a -> SearchTree a
One

  SearchTree a
None >>= :: forall a b. 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 :: forall a. String -> SearchTree a
fail String
_ = SearchTree a
forall a. SearchTree a
None

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

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

-- |
-- Another search monad based on continuations that produce search
-- trees.
newtype Search a = Search
  { -- | Passes a continuation to a monadic search action.
    forall a. 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 :: forall a. Search a -> SearchTree a
searchTree Search a
a = Search a -> forall r. (a -> SearchTree r) -> SearchTree r
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 :: forall a b. (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 -> forall r. (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 :: forall a. a -> Search a
pure  = a -> Search a
forall (m :: * -> *) a. Monad m => a -> m a
return

  <*> :: forall a b. 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 :: forall a. Search a
empty = Search a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

  <|> :: forall a. 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
  return :: forall a. a -> Search a
return 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
a >>= :: forall a b. 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 -> forall r. (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
a (\a
x -> Search b -> forall r. (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 :: forall a. String -> Search a
fail String
_ = Search a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance MonadPlus Search where
  mzero :: forall a. 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 :: forall a. 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 -> forall r. (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 -> forall r. (a -> SearchTree r) -> SearchTree r
forall a. Search a -> forall r. (a -> SearchTree r) -> SearchTree r
search Search a
b a -> SearchTree r
k)