Browse files

Add generic search algorithm. Specializes to A* and flood fill, at le…

…ast.
  • Loading branch information...
1 parent 6953377 commit 2d6e8451b1fb3d5f2e32c7ec969110995ea59a4c @clanehin committed Jan 15, 2014
View
3 Roguestar/Lib/Graph/Tests.hs
@@ -3,11 +3,8 @@ module Roguestar.Lib.Graph.Tests
equestria, picard, twilight, zathras)
where
-import qualified Roguestar.Lib.Data.ReferenceTypes as References
-import Roguestar.Lib.Graph.Graph
import Roguestar.Lib.Graph.Classes
import Roguestar.Lib.Graph.TestExampleEntities
-import qualified Data.Set as Set
import Test.HUnit
testcases :: Test
View
10 Roguestar/Lib/UnitTests.hs
@@ -21,6 +21,7 @@ import qualified Roguestar.Lib.Graph.Tests as GraphTests
import qualified Roguestar.Lib.Core.Tests as CoreTests
import qualified Roguestar.Lib.Core2.Tests as Core2Tests
import qualified Roguestar.Lib.Utility.HierarchicalDatabase as HDatabaseTests
+import qualified Roguestar.Lib.Utility.SearchTests as SearchTests
runTests :: IO (T.Text,Bool)
runTests =
@@ -38,9 +39,9 @@ pathOf (HUnit.State { HUnit.path = p }) = List.concat $ List.map (nodeToString)
captureTestResults :: HUnit.Test -> IO (HUnit.Counts, T.Text)
captureTestResults test =
do (counts, test_result) <- HUnit.performTest report_start report_problem report_problem (TestResult []) test
- return (counts, T.concat $ List.intersperse "\n\n" $ List.reverse $ test_result_text test_result)
- where report_start state test_result = return $ test_result { test_result_text = (T.pack $ "\n" ++ pathOf state) : test_result_text test_result }
- report_problem msg state test_result = return $ test_result { test_result_text = (T.pack $ pathOf state ++ ": " ++ msg) : test_result_text test_result }
+ return (counts, T.concat $ List.intersperse "\n" $ List.reverse $ test_result_text test_result)
+ where report_start state test_result = return $ test_result { test_result_text = (T.pack $ pathOf state) : test_result_text test_result }
+ report_problem msg state test_result = return $ test_result { test_result_text = (T.pack $ "\n" ++ pathOf state ++ ": " ++ msg ++ "\n") : test_result_text test_result }
-- Generate N random planes and run tests against them.
runWithRandomPlanes :: Int -> String -> (PlaneRef -> DB HUnit.Assertion) -> HUnit.Test
@@ -65,7 +66,8 @@ testcases = HUnit.TestLabel "root" $ HUnit.TestList [
HUnit.TestLabel "Roguestar.Lib.Graph" $ GraphTests.testcases,
HUnit.TestLabel "Roguestar.Lib.Core2" $ Core2Tests.testcases,
HUnit.TestLabel "Roguestar.Lib.Core" $ CoreTests.testcases,
- HUnit.TestLabel "Roguestar.Lib.Utility.HierarchicalDatabase" $ HDatabaseTests.testcases]
+ HUnit.TestLabel "Roguestar.Lib.Utility.HierarchicalDatabase" $ HDatabaseTests.testcases,
+ HUnit.TestLabel "Roguestar.Lib.Utility.SearchTests" $ SearchTests.testcases]
testSessionAliveBeforeTimeout :: HUnit.Test
testSessionAliveBeforeTimeout = HUnit.TestCase $
View
101 Roguestar/Lib/Utility/Search.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}
+module Roguestar.Lib.Utility.Search
+ (Searchable(..),
+ Graph, Cost, Priority, Acceptance, Path, Paths,
+ searchableChessboard,
+ floodfillChessboard,
+ startingAt,
+ search)
+ where
+
+import qualified Data.Map as Map
+import Data.List as List
+
+data Searchable a = Searchable {
+ searchable_graph :: Graph a,
+ searchable_cost :: Cost a,
+ searchable_heuristic :: Priority a,
+ searchable_acceptance :: Acceptance a }
+
+chessboard :: Searchable (Integer,Integer)
+chessboard = Searchable {
+ searchable_graph = \(x,y) -> [(x-1,y-1), (x,y-1), (x+1,y-1),
+ (x-1,y) , (x+1,y),
+ (x-1,y+1), (x,y+1), (x+1,y+1)],
+ searchable_cost = \(x1,y1) (x2,y2) -> max (abs (x1-x2)) (abs (y1-y2)),
+ searchable_heuristic = error "chessboard: undefined searchable_heuristic",
+ searchable_acceptance = error "chessboard: undefined searchable_acceptance" }
+
+searchableChessboard :: (Integer,Integer) -> Searchable (Integer,Integer)
+searchableChessboard (goal_x,goal_y) = chessboard {
+ searchable_heuristic = \(cost,(x,y):_) -> cost + max (abs (goal_x-x)) (abs (goal_y-y)),
+ searchable_acceptance = \m -> Map.member (goal_x,goal_y) m }
+
+floodfillChessboard :: ((Integer,Integer) -> Bool) -> Searchable (Integer,Integer)
+floodfillChessboard f = chessboard {
+ searchable_graph = filter f . (searchable_graph chessboard),
+ searchable_heuristic = \(cost,_) -> cost,
+ searchable_acceptance = const False }
+
+-- |
+-- Specifies a Graph by providing the set of nodes connected to any given node.
+--
+type Graph a = a -> [a]
+
+-- |
+-- Specifies the cost of moving from one node to another.
+--
+type Cost a = a -> a -> Integer
+
+-- |
+-- Specifies the priority with which nodes should be expanded during the search.
+-- Lower means higher priority.
+-- The parameter is the path to the node and the cost of that path.
+--
+type Priority a = Path a -> Integer
+
+-- |
+-- Specifies whether or not the listed set satisfies the goal of the search.
+-- The search will end when this function evaluates to True.
+--
+type Acceptance a = Paths a -> Bool
+
+-- |
+-- Specifies a path to a specific node, paired with its cost.
+-- The head of the list is the node itself, tracing back to the origin.
+--
+type Path a = (Integer,[a])
+type Paths a = Map.Map a (Path a)
+
+data Queue a = Queue {
+ search_queue :: [Path a],
+ best_paths :: Paths a }
+
+startingAt :: (Ord a) => a -> Queue a
+startingAt a = Queue [initial_path] (Map.singleton a initial_path)
+ where initial_path = (0,[a])
+
+search :: forall a. (Ord a) => Searchable a -> Queue a -> Paths a
+search _ queue | null (search_queue queue) = best_paths queue
+search searchable queue | searchable_acceptance searchable (best_paths queue) = best_paths queue
+search searchable queue = search searchable $ Queue new_search_queue new_paths
+ where path_to_here :: Path a
+ path_to_here@(_,here:_) = head $ search_queue queue
+ paths_from_here :: [Path a]
+ paths_from_here = filter (\x -> isImprovement x (best_paths queue)) $ map (expand searchable path_to_here) $ searchable_graph searchable here
+ new_search_queue :: [Path a]
+ new_search_queue = foldr List.insert (tail $ search_queue queue) paths_from_here
+ new_paths :: Paths a
+ new_paths = foldr addPath (best_paths queue) paths_from_here
+
+expand :: Searchable a -> Path a -> a -> Path a
+expand searchable (cost_so_far,path_so_far) a =
+ (cost_so_far + searchable_cost searchable a (head path_so_far), a:path_so_far)
+
+isImprovement :: (Ord a) => Path a -> Paths a -> Bool
+isImprovement (new_cost,new_steps) paths | (Just (old_cost,_)) <- Map.lookup (head new_steps) paths = old_cost > new_cost
+isImprovement _ _ | otherwise = True
+
+addPath :: (Ord a) => Path a -> Paths a -> Paths a
+addPath new@(_,new_steps) paths | isImprovement new paths = Map.insert (head new_steps) new paths
+addPath _ paths | otherwise = paths
View
28 Roguestar/Lib/Utility/SearchTests.hs
@@ -0,0 +1,28 @@
+module Roguestar.Lib.Utility.SearchTests
+ (testcases)
+ where
+
+import Roguestar.Lib.Utility.Search
+import qualified Test.HUnit as HUnit
+import qualified Data.Map as Map
+
+testcases :: HUnit.Test
+testcases = HUnit.TestList [testSimpleShortestPath,
+ testFloodFillWithinBounds,
+ testFloodFillOutOfBounds]
+
+expected :: Maybe (Path (Integer,Integer))
+expected = Just (5,[(5,5),(4,4),(3,3),(2,2),(1,1),(0,0)])
+
+testSimpleShortestPath :: HUnit.Test
+testSimpleShortestPath = HUnit.TestCase $ HUnit.assertEqual "testSimpleShortestPath" expected $ Map.lookup (5,5) result
+ where result = search (searchableChessboard (5,5)) (startingAt (0,0))
+
+example_chessboard_flood_fill :: Paths (Integer,Integer)
+example_chessboard_flood_fill = search (floodfillChessboard $ \(x,y) -> abs x < 10 && abs y < 10) (startingAt (0,0))
+
+testFloodFillWithinBounds :: HUnit.Test
+testFloodFillWithinBounds = HUnit.TestCase $ HUnit.assertEqual "testFloodFillWithinBounds" expected $ Map.lookup (5,5) example_chessboard_flood_fill
+
+testFloodFillOutOfBounds :: HUnit.Test
+testFloodFillOutOfBounds = HUnit.TestCase $ HUnit.assertEqual "testFloodFillOutOfBounds" Nothing $ Map.lookup (12,12) example_chessboard_flood_fill
View
9 roguestar.cabal
@@ -37,7 +37,9 @@ executable roguestar-server
ghc-options: -threaded -fno-warn-type-defaults
other-modules:
Roguestar.Lib.HTML.Mustache,
- Roguestar.Lib.Core2.Tests
+ Roguestar.Lib.Core2.Tests,
+ Roguestar.Lib.Utility.Search,
+ Roguestar.Lib.Utility.SearchTests
library
hs-source-dirs: .
@@ -49,6 +51,7 @@ library
hslogger >=1.1.0,
bytestring >=0.9.1.5,
parallel >=2.2.0.1,
+ PSQueue,
stm >=2.1.1.2,
data-memocombinators >=0.4.0,
MonadRandom >=0.1.4,
@@ -116,7 +119,9 @@ library
Roguestar.Lib.Data.VisibilityData,
Roguestar.Lib.HTML.Mustache,
Roguestar.Lib.Core2.Tests,
- Roguestar.Lib.Core2.Location
+ Roguestar.Lib.Core2.Location,
+ Roguestar.Lib.Utility.Search,
+ Roguestar.Lib.Utility.SearchTests
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
if impl(ghc >= 7.0)

0 comments on commit 2d6e845

Please sign in to comment.