Permalink
Browse files

Abstracting the search in a new enumerator

  • Loading branch information...
roman committed Oct 18, 2011
1 parent fb6c6c7 commit 7d649d1c9baed19920ed48cdfe3ea7a1714a76ca
Showing with 127 additions and 36 deletions.
  1. +76 −0 src/Exploration/Enumerator.hs
  2. +17 −0 src/Exploration/Types.hs
  3. +11 −4 src/Lesson2/BFS.hs
  4. +14 −25 src/Lesson2/BFS/Enumerator.hs
  5. +3 −2 src/Lesson2/Enumerator.hs
  6. +2 −2 src/Lesson2/Types.hs
  7. +4 −3 src/Main.hs
@@ -0,0 +1,76 @@
+module Exploration.Enumerator (
+ enumNavigation
+ , removeVisited
+ , module Exploration.Types
+ ) where
+
+import Control.Monad (liftM)
+import Control.Monad.Trans (MonadIO)
+import Data.Set (Set)
+
+import qualified Data.Set as Set
+
+--------------------
+
+import Data.Enumerator hiding (map, mapM, repeat)
+
+import qualified Data.Enumerator.List as EL
+
+--------------------
+
+import Exploration.Types
+
+-------------------------------------------------------------------------------
+
+enumNavigation :: (Ord a, MonadIO m)
+ => (a -> m Integer)
+ -> (a -> m [a])
+ -> a
+ -> Enumerator (NavEvent a) m b
+enumNavigation costFn actionsFn zero =
+ go (Set.singleton (0, zero, Nothing))
+ Set.empty
+ where
+ go _ _ step@(Yield {}) = returnI step
+ go frontier0 visited0 step@(Continue consumer) = Iteratee $
+ case Set.minView frontier0 of
+ Nothing -> return step
+ Just ((cost, node, parent), frontier1)
+ | Set.member node visited0 -> do
+
+ let event = NavEvent node
+ parent
+ cost
+ True
+ visited0
+ frontier1
+
+ runIteratee $ consumer (Chunks [event]) >>==
+ go frontier1 visited0
+
+
+ | otherwise -> do
+
+ children0 <- actionsFn node
+ childrenCosts <- mapM (((+cost) `liftM`) . costFn)
+ children0
+ let children = Set.fromList $ zip3 childrenCosts
+ children0
+ (repeat (Just node))
+ let frontier = frontier0 `Set.union` children
+ let visited = Set.insert node visited0
+
+ let event = NavEvent node
+ parent
+ cost
+ False
+ visited
+ frontier
+
+ runIteratee $ consumer (Chunks [event]) >>==
+ go frontier visited
+
+
+removeVisited :: Monad m => Enumeratee (NavEvent a) (NavEvent a) m b
+removeVisited = EL.filter (not . nvAlreadyVisited)
+
View
@@ -0,0 +1,17 @@
+module Exploration.Types where
+
+import Data.Set (Set)
+
+-------------------------------------------------------------------------------
+
+data NavEvent a
+ = NavEvent {
+ nvVal :: a
+ , nvParent :: Maybe a
+ , nvCost :: Integer
+ , nvAlreadyVisited :: Bool
+ , nvVisited :: Set a
+ , nvFrontier :: Set (Integer, a, Maybe a)
+ }
+ deriving (Show, Ord, Eq)
+
View
@@ -11,11 +11,13 @@ module Lesson2.BFS
, main
) where
-import Control.Monad (mapM_)
+import Control.Monad (forM_)
import Data.Attoparsec.Enumerator (iterParser)
-import Data.Enumerator (run_, ($$))
+import Data.Enumerator (run_, ($$), (=$))
import Data.Enumerator.Binary (enumFile)
+import Data.Maybe (fromMaybe)
+import Exploration.Enumerator
import Lesson2.Enumerator
import Lesson2.Types
@@ -33,7 +35,12 @@ main = do
-- Set the goal State
let goalNode = Node (City "Bucharest")
-- Run basic BFS
- result <- run_ $ enumBFS startNode graph $$ consumeTillNode goalNode
+ result <- run_ $ enumBFS startNode graph $$ removeVisited =$ consumeTillNode goalNode
-- Print visit order
- mapM_ print result
+ forM_ result $ \event -> do
+ putStr $ "[cost: " ++ show (nvCost event) ++ "] "
+ putStr $ show $ fromMaybe (nvVal event) (nvParent event)
+ putStr " -> "
+ putStrLn $ show (nvVal event)
+
@@ -1,6 +1,12 @@
module Lesson2.BFS.Enumerator where
import Control.Monad.Trans (MonadIO, liftIO)
+import Data.Ord (Ord(..), comparing)
+
+import qualified Data.Set as Set
+
+--------------------
+
import Data.Enumerator (
Stream(..)
, Step(..)
@@ -12,38 +18,21 @@ import Data.Enumerator (
, yield
)
import Data.Hashable (Hashable(..))
-import Data.Ord (Ord(..), comparing)
-import qualified Data.Set as Set
+--------------------
+import Exploration.Enumerator
import Lesson2.Types
import Lesson2.BFS.Types
-------------------------------------------------------------------------------
-newtype FrontierEntry a
- = FE { fromFE :: (Int, Node a) }
- deriving (Show, Eq, Ord)
-
--------------------------------------------------------------------------------
-
-enumBFS :: (MonadIO m, Show a, Hashable a)
+enumBFS :: (MonadIO m, Hashable a)
=> Node a
-> BFSGraph a
- -> Enumerator (Node a) m b
-enumBFS source0 g =
- go Set.empty (Set.singleton $ FE (0, source0))
- where
- go _ _ step@(Yield {}) = returnI step
- go explored0 frontier0 step@(Continue consumer) = Iteratee $
- case Set.minView frontier0 of
- Just (FE (i, source), frontier1) -> do
- let explored = Set.insert source explored0
- let frontier = Set.union frontier1 .
- Set.fromList .
- Prelude.map (\(_, n) -> FE (i + 1, n)) .
- Prelude.filter ((`Set.notMember` explored) . snd) $
- getNodeNeighbours source g
- runIteratee $ consumer (Chunks [source]) >>== go explored frontier
- Nothing -> return step
+ -> Enumerator (NavEvent (Node a)) m b
+enumBFS source0 g =
+ enumNavigation (const $ return 1)
+ (return . (`getNodeNeighbours` g))
+ source0
@@ -9,17 +9,18 @@ import Data.Enumerator (
, yield
)
+import Exploration.Types
import Lesson2.Types
consumeTillNode :: (Monad m, Hashable a)
=> Node a
- -> Iteratee (Node a) m [Node a]
+ -> Iteratee (NavEvent (Node a)) m [NavEvent (Node a)]
consumeTillNode dest = continue $ go []
where
go acc EOF = yield [] EOF
go acc (Chunks []) = continue $ go acc
go acc (Chunks ns) = Iteratee $ do
- let (as, bs) = span (dest /=) ns
+ let (as, bs) = span ((dest /=) . nvVal) ns
case bs of
[] -> return $ Continue $ go $ acc ++ as
(x:xs) -> return $ Yield (acc ++ as ++ [x]) (Chunks xs)
View
@@ -77,12 +77,12 @@ appendNode node = modL graphNodes (Set.insert node)
getNodeNeighbours :: (Hashable a, EdgeLike e)
=> Node a
-> Graph e a
- -> [(Maybe Integer, Node a)]
+ -> [Node a]
getNodeNeighbours n =
Set.fold getOtherNode [] .
getL graphEdges
where
getOtherNode e acc
- | getEdgeSource e == n = (getEdgeCost e, getEdgeSink e) : acc
+ | getEdgeSource e == n = getEdgeSink e : acc
| otherwise = acc
View
@@ -1,8 +1,9 @@
module Main where
+import Exploration.Enumerator
import qualified Lesson2.BFS
-import qualified Lesson2.UCS
+--import qualified Lesson2.UCS
main :: IO ()
---main = Lesson2.BFS.main
-main = Lesson2.UCS.main
+main = Lesson2.BFS.main
+--main = Lesson2.UCS.main

0 comments on commit 7d649d1

Please sign in to comment.