Permalink
Browse files

Adding Unified Cost Search algorithms

  • Loading branch information...
1 parent efa57ee commit c375b0f39a736bc14f3a083e30271b7e86cacc49 @roman committed Oct 15, 2011
Showing with 240 additions and 3 deletions.
  1. +0 −1 src/Lesson2/BFS/Types.hs
  2. +1 −1 src/Lesson2/Input.txt
  3. +29 −0 src/Lesson2/UCS.hs
  4. +70 −0 src/Lesson2/UCS/Enumerator.hs
  5. +40 −0 src/Lesson2/UCS/Parser.hs
  6. +97 −0 src/Lesson2/UCS/Types.hs
  7. +3 −1 src/Main.hs
View
@@ -45,7 +45,6 @@ instance Hashable a => Monoid (BasicGraph a) where
BasicGraph (n0 `mappend` n1)
(e0 `mappend` e1)
-
instance Hashable a => Hashable (BasicNode a) where
hash (BasicNode a) = 0 `hashWithSalt` a
View
@@ -1,6 +1,6 @@
Arad, Zerind, 75
Arad, Sibiu, 140
-Arad, Timisoara, 111
+Arad, Timisoara, 118
Zerind, Oradea, 71
Timisoara, Lugoj, 111
Oradea, Sibiu, 151
View
@@ -0,0 +1,29 @@
+module Lesson2.UCS (
+ main
+ , UCSGraph(..)
+ , UCSEdge(..)
+ , UCSNode(..)
+ ) where
+
+import Data.Attoparsec.Enumerator (iterParser)
+import Data.Enumerator (run_, ($$))
+import Data.Enumerator.Binary (enumFile)
+
+import Lesson2.Types
+import Lesson2.UCS.Enumerator
+import Lesson2.UCS.Parser
+import Lesson2.UCS.Types
+
+main :: IO ()
+main = do
+ graph <- run_ $
+ enumFile "src/Lesson2/Input.txt" $$ iterParser parseGraph
+ -- Set the initial State
+ let startNode = UCSNode (City "Arad")
+ -- Set the goal State
+ let goalNode = UCSNode (City "Bucharest")
+ -- Run basic UCS
+ result <- run_ $ enumUCS startNode graph $$ consumeTillNode goalNode
+ -- Print visit order
+ mapM_ print result
+
@@ -0,0 +1,70 @@
+module Lesson2.UCS.Enumerator where
+
+import Control.Monad.Trans (MonadIO, liftIO)
+import Data.Enumerator (
+ Stream(..)
+ , Step(..)
+ , Iteratee(..)
+ , Enumerator
+ , (>>==)
+ , returnI
+ , continue
+ , yield
+ )
+import Data.Hashable (Hashable(..))
+import Data.Ord (Ord(..), comparing)
+
+import qualified Data.Set as Set
+
+import Lesson2.UCS.Types
+
+-------------------------------------------------------------------------------
+
+newtype FrontierEntry a
+ = FE { fromFE :: (Integer, UCSNode a) }
+ deriving (Show, Eq, Ord)
+
+-------------------------------------------------------------------------------
+
+enumUCS :: (MonadIO m, Show a, Hashable a)
+ => UCSNode a
+ -> UCSGraph a
+ -> Enumerator (UCSNode a) m b
+enumUCS 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) ->
+ if source `Set.member` explored0
+ then runIteratee $ consumer (Chunks []) >>== go explored0 frontier1
+ else do
+ let explored = Set.insert source explored0
+ let frontier = Set.union frontier1 .
+ Set.fromList .
+ Prelude.map (\(c, n) -> FE (i + c, n)) .
+ Prelude.filter ((`Set.notMember` explored) .
+ snd) $
+ getNodeNeighbours source g
+ runIteratee $ consumer (Chunks [source]) >>== go explored frontier
+ Nothing -> return step
+
+-------------------------------------------------------------------------------
+
+consumeTillNode :: (Monad m, Hashable a)
+ => UCSNode a
+ -> Iteratee (UCSNode a) m [UCSNode 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
+ case bs of
+ [] -> return $ Continue $ go $ acc ++ as
+ (x:xs) -> return $ Yield (acc ++ as ++ [x]) (Chunks xs)
+
+-------------------------------------------------------------------------------
+
+
View
@@ -0,0 +1,40 @@
+module Lesson2.UCS.Parser where
+
+import Control.Applicative ((<$>), (<*>), (<*), (*>))
+import Data.Attoparsec.Char8
+import Data.ByteString.UTF8 (toString)
+import Data.Monoid (mconcat)
+
+import Lesson2.Types
+import Lesson2.UCS.Types
+
+tillComma = takeTill (== ',')
+tillEOL = takeTill (== '\n')
+comma = char ','
+eol = char '\n'
+
+parseCity =
+ entry <$> (skipSpace *>
+ tillComma <*
+ comma)
+ where
+ entry = UCSNode . City . toString
+
+parseCost =
+ skipSpace *> decimal <* tillEOL <* eol
+
+parseEntry :: Parser (UCSGraph City)
+parseEntry = do
+ a <- parseCity
+ b <- parseCity
+ c <- parseCost
+ return $ createGraph a b c
+ where
+ createGraph a b c =
+ appendEdge a b c .
+ appendNode a $
+ appendNode b emptyGraph
+
+parseGraph :: Parser (UCSGraph City)
+parseGraph = mconcat <$> many1 parseEntry
+
View
@@ -0,0 +1,97 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Lesson2.UCS.Types where
+
+import Data.Hashable (Hashable(..))
+import Data.Lens.Common (getL, modL)
+import Data.Lens.Template (makeLenses)
+import Data.List (foldl')
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..), comparing)
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-------------------------------------------------------------------------------
+
+data UCSGraph a
+ = UCSGraph {
+ _ucsGraphNodes :: Set (UCSNode a)
+ , _ucsGraphEdges :: Set (UCSEdge a)
+ }
+
+data UCSNode a
+ = UCSNode {
+ ucsNodeValue :: a
+ }
+
+data UCSEdge a
+ = UCSEdge {
+ ucsEdgeSource :: UCSNode a
+ , ucsEdgeSink :: UCSNode a
+ , ucsCost :: Integer
+ }
+
+makeLenses [''UCSGraph]
+
+-------------------------------------------------------------------------------
+
+instance Show a => Show (UCSNode a) where
+ show (UCSNode n) = show n
+
+instance Show a => Show (UCSEdge a) where
+ show (UCSEdge a b c) =
+ "(" ++ show a ++ ", " ++ show b ++ ") -> " ++ show c
+
+instance Hashable a => Monoid (UCSGraph a) where
+ mempty = emptyGraph
+ mappend (UCSGraph n0 e0) (UCSGraph n1 e1) =
+ UCSGraph (n0 `mappend` n1)
+ (e0 `mappend` e1)
+
+instance Hashable a => Hashable (UCSNode a) where
+ hash (UCSNode a) = 1 `hashWithSalt` a
+
+instance Hashable a => Hashable (UCSEdge a) where
+ hash (UCSEdge a b c) = foldl' hashWithSalt 2 [a, b] + hash c
+
+instance Hashable a => Eq (UCSNode a) where
+ a == b = hash a == hash b
+
+instance (Hashable a) => Ord (UCSNode a) where
+ compare = comparing hash
+
+instance Hashable a => Eq (UCSEdge a) where
+ a == b = hash a == hash b
+
+instance Hashable a => Ord (UCSEdge a) where
+ compare = comparing hash
+
+-------------------------------------------------------------------------------
+
+emptyGraph :: UCSGraph a
+emptyGraph = UCSGraph Set.empty Set.empty
+
+appendNode :: Hashable a => UCSNode a -> UCSGraph a -> UCSGraph a
+appendNode node = modL ucsGraphNodes (Set.insert node)
+
+appendEdge :: Hashable a
+ => UCSNode a
+ -> UCSNode a
+ -> Integer
+ -> UCSGraph a
+ -> UCSGraph a
+appendEdge a b cost = modL ucsGraphEdges (Set.union otherSet)
+ where
+ otherSet = Set.fromList [UCSEdge a b cost, UCSEdge b a cost]
+
+
+-------------------------------------------------------------------------------
+
+getNodeNeighbours :: Hashable a => UCSNode a -> UCSGraph a -> [(Integer, UCSNode a)]
+getNodeNeighbours n =
+ Set.fold getOtherNode [] .
+ getL ucsGraphEdges
+ where
+ getOtherNode e acc
+ | ucsEdgeSource e == n = (ucsCost e, ucsEdgeSink e) : acc
+ | otherwise = acc
+
View
@@ -1,6 +1,8 @@
module Main where
import qualified Lesson2.BFS
+import qualified Lesson2.UCS
main :: IO ()
-main = Lesson2.BFS.main
+--main = Lesson2.BFS.main
+main = Lesson2.UCS.main

0 comments on commit c375b0f

Please sign in to comment.