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

parent 69533775
......@@ -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
......
......@@ -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 $
......
{-# 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
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
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment