diff --git a/Control/Monad/Levels.hs b/Control/Monad/Levels.hs --- a/Control/Monad/Levels.hs +++ b/Control/Monad/Levels.hs @@ -12,99 +12,68 @@ -- implement breadth-first search. -- -- The implementation is inspired by Mike Spivey and Silvija Seres: --- cf. Chapter 9 of the book 'The Fun of Programming'. +-- cf. Chapter 9 of the book 'The Fun of Programming'. The +-- implementation of iterative deepening depth-first is, however, +-- significantly simpler thanks to the use of a continuation monad. -- -- Warning: @Levels@ is only a monad when the results of the -- enumeration functions are interpreted as a multiset, i.e., a valid -- transformation according to the monad laws may change the order of -- the results. -module Control.Monad.Levels ( +module Control.Monad.Levels ( bfs, idfs, idfsBy ) where - Levels, levels, breadthFirstSearch, +import Data.Monoid +import Data.FMList - DepthBound, iterLevels, iterativeDeepening, - diagonals - - ) where - -import Control.Monad +-- | The function @bfs@ enumerates the results of a +-- non-deterministic computation in breadth-first order. +bfs :: FMList a -> [a] +bfs a = runLevels (unFM a yield) + where yield x = Levels [singleton x] --- | -- Non-Deterministic computations of type @Levels a@ can be searched -- level-wise. -newtype Levels a = Levels { - - -- | - -- The function @levels@ yields the results of a non-deterministic - -- computation grouped in levels. - levels :: [[a]] - - } - --- | --- The function @breadthFirstSearch@ enumerates the results of a --- non-deterministic computation in breadth-first order. -breadthFirstSearch :: Levels a -> [a] -breadthFirstSearch = concat . levels - -instance Monad Levels - where - return x = Levels [[x]] - - Levels x >>= f = Levels (x `bind` (levels . f)) - - fail _ = Levels [] - -bind :: [[a]] -> (a -> [[b]]) -> [[b]] -bind x f = map concat (diagonals (map (foldr zipConc [] . map f) x)) - -instance MonadPlus Levels - where - mzero = Levels [] - - Levels xs `mplus` Levels ys = Levels ([] : zipConc xs ys) +newtype Levels a = Levels { levels :: [FMList a] } --- | --- The type @DepthBound@ represents computations with a bounded --- depth. It's monad instances implements iterative deepening. -newtype DepthBound a = DepthBound { (!) :: Int -> [(a,Int)] } +-- Concatenates levels amd yields result as list. +runLevels :: Levels a -> [a] +runLevels = toList . foldr append empty . levels -instance Monad DepthBound - where - return x = DepthBound (\d -> [(x,d)]) - a >>= f = DepthBound (\d -> [ y | (x,d') <- a!d, y <- f x!d' ]) - fail _ = DepthBound (const []) +instance Monoid (Levels a) where + mempty = Levels [] + a `mappend` b = Levels (empty : merge (levels a) (levels b)) -instance MonadPlus DepthBound - where - mzero = DepthBound (const []) - a `mplus` b = DepthBound (\d -> do guard (d>0) - let d' = d-1 - (a!d') `mplus` (b!d')) +-- like 'zipWith append' without cutting the longer list +merge :: [FMList a] -> [FMList a] -> [FMList a] +merge [] ys = ys +merge xs [] = xs +merge (x:xs) (y:ys) = append x y : merge xs ys --- | --- The function @iterLevels@ computes the levels of a depth bound --- computation using iterative deepening. -iterLevels :: DepthBound a -> Levels a -iterLevels a = Levels [[ x | (x,0) <- a!d ] | d <- [0..]] +-- | The function @idfs@ computes the levels of a depth bound +-- computation using iterative deepening depth-first search. Unlike +-- breadth-first search it runs in constant space but usually takes a +-- bit longer, depending on how the depth limit is increased. Don't +-- use this algorithm if you know that there is only a finite number +-- of results because it will continue trying larger depth limits +-- without recognizing that there are no more solutions. +idfs :: FMList a -> [a] +idfs = idfsBy 100 --- | --- The function @iterativeDeepening@ enumerates the results of a --- non-deterministic computations using iterative deepening. -iterativeDeepening :: DepthBound a -> [a] -iterativeDeepening = concat . levels . iterLevels +-- | The function @idfsBy@ computes the levels of a depth bound +-- computation using iterative deepening depth-first search +-- incrementing the depth limit between searches using the given +-- number of steps. +idfsBy :: Int -> FMList a -> [a] +idfsBy n a = toList $ foldr append empty [ unFM a yield ! d | d <- [0,n..] ] + where yield x = DepthBound (\d -> if d [[a]] -diagonals [] = [] -diagonals (xs:xss) = zipConc [[x] | x <- xs] ([] : diagonals xss) +-- The type @DepthBound@ represents computations with a bounded depth +-- to iterative deepening search. +newtype DepthBound a = DepthBound { (!) :: Int -> FMList a } -zipConc :: [[a]] -> [[a]] -> [[a]] -zipConc [] yss = yss -zipConc xss [] = xss -zipConc (xs:xss) (ys:yss) = (xs++ys) : zipConc xss yss +instance Monoid (DepthBound a) where + mempty = DepthBound (const empty) + a `mappend` b = DepthBound (\d -> if d==0 then empty + else append (a!(d-1)) (b!(d-1))) diff --git a/level-monad.cabal b/level-monad.cabal --- a/level-monad.cabal +++ b/level-monad.cabal @@ -1,17 +1,17 @@ Name: level-monad -Version: 0.3.1 +Version: 0.4 Cabal-Version: >= 1.6 Synopsis: Non-Determinism Monad for Level-Wise Search Description: This Haskell library provides an implementation of the MonadPlus type class that enumerates the levels of the search space using breadth-first search or iterativ - deepening. + deepening depth-first search. Category: Control, Monads License: PublicDomain License-File: LICENSE Author: Sebastian Fischer Maintainer: sebf@informatik.uni-kiel.de -Bug-Reports: mailto:sebf@informatik.uni-kiel.de +Bug-Reports: http://github.com/sebfisch/level-monad/issues Homepage: http://github.com/sebfisch/level-monad Build-Type: Simple Stability: experimental @@ -19,9 +19,9 @@ Extra-Source-Files: README Library - Build-Depends: base + Build-Depends: base >= 3 && < 5, fmlist Exposed-Modules: Control.Monad.Levels - Ghc-Options: -Wall + Ghc-Options: -Wall -fno-full-laziness Source-Repository head type: git