pathfindingcore (empty) → 1.1
raw patch · 11 files changed
+670/−0 lines, 11 filesdep +HUnitdep +arraydep +basesetup-changed
Dependencies added: HUnit, array, base, pathfindingcore, split, test-framework, test-framework-hunit
Files
- LICENSE.txt +25/−0
- Setup.hs +2/−0
- pathfindingcore.cabal +41/−0
- src/PathFindingCore/PathingMap.hs +79/−0
- src/PathFindingCore/PathingMap/Coordinate.hs +17/−0
- src/PathFindingCore/PathingMap/Direction.hs +10/−0
- src/PathFindingCore/PathingMap/Interpreter.hs +69/−0
- src/PathFindingCore/PathingMap/Terrain.hs +56/−0
- src/PathFindingCore/Status.hs +10/−0
- src/PathFindingTest/TestSet.hs +351/−0
- test/Main.hs +10/−0
+ LICENSE.txt view
@@ -0,0 +1,25 @@+PathFinding Project - PathFindingCore-Haskell Module+Copyright (c) 2014, Jason Bertsche+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of Jason Bertsche nor the+ names of project contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL JASON BERTSCHE BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pathfindingcore.cabal view
@@ -0,0 +1,41 @@+Name: pathfindingcore+Version: 1.1+Cabal-version: >=1.16.0+License: BSD3+License-File: LICENSE.txt+Author: Jason Bertsche+Maintainer: jason.bertsche@gmail.com+Homepage: http://github.com/TheBizzle+Category: Demo+Synopsis: A toy pathfinding library+Description: A toy pathfinding library+Build-type: Simple++source-repository head+ type: git+ location: git@github.com:TheBizzle/PathFindingCore-Haskell.git++library+ hs-source-dirs: src+ exposed-modules: PathFindingCore.PathingMap, PathFindingCore.Status, PathFindingCore.PathingMap.Coordinate, PathFindingCore.PathingMap.Direction, PathFindingCore.PathingMap.Terrain, PathFindingCore.PathingMap.Interpreter, PathFindingTest.TestSet+ default-language: Haskell2010+ build-depends:+ array >= 0.4,+ base >= 4.6 && < 5,+ split >= 0.2+ GHC-Options:+ -Wall+ -fno-warn-name-shadowing++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends:+ array >= 0.4,+ base >= 4.6 && < 5,+ HUnit >= 1.2,+ pathfindingcore >= 1.1,+ test-framework >= 0.8,+ test-framework-hunit >= 0.3
+ src/PathFindingCore/PathingMap.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleInstances #-}+module PathFindingCore.PathingMap(findDirection, getTerrain, insertPath, markAsGoal, neighborsOf, PrintablePathingGrid(..), step) where++import Control.Arrow((>>>))+import Data.Array.IArray((!), (//), assocs, bounds)+import Data.Foldable(fold)+import Data.List(sortBy)+import Data.List.Split(chunksOf)+import Data.Maybe(fromMaybe)+import Text.Printf(printf)++import PathFindingCore.PathingMap.Coordinate(Coordinate(..))+import PathFindingCore.PathingMap.Direction(Direction(East, North, South, West), directions)+import PathFindingCore.PathingMap.Interpreter(PathingGrid)+import PathFindingCore.PathingMap.Terrain(isPassable, Terrain(Goal, Path, Query, Self), terrainToChar)++data PrintablePathingGrid+ = PPG {+ pathingGrid :: PathingGrid+ }++a |> f = f a++getTerrain :: Coordinate -> PathingGrid -> Maybe Terrain+getTerrain coord@(Coord x y) grid = if isInBounds then Just $ grid ! coord else Nothing+ where+ (Coord x1 y1, Coord x2 y2) = bounds grid+ isInBounds = and [x >= x1, x <= x2, y >= y1, y <= y2]++neighborsOf :: Coordinate -> PathingGrid -> [Coordinate]+neighborsOf coordinate grid = directions |> ((fmap $ findNeighborCoord coordinate) >>> (filter canTravelTo))+ where+ canTravelTo = (flip getTerrain) grid >>> (fmap isPassable) >>> (fromMaybe False)++step :: Coordinate -> Coordinate -> PathingGrid -> PathingGrid+step prev new grid = grid // [(prev, Query), (new, Self)]++markAsGoal :: Coordinate -> PathingGrid -> PathingGrid+markAsGoal coord grid = grid // [(coord, Goal)]++insertPath :: [Coordinate] -> PathingGrid -> PathingGrid+insertPath coords grid = grid // (fmap f coords)+ where+ f coord = (coord, Path)++findNeighborCoord :: Coordinate -> Direction -> Coordinate+findNeighborCoord (Coord x y) North = Coord x (y + 1)+findNeighborCoord (Coord x y) South = Coord x (y - 1)+findNeighborCoord (Coord x y) East = Coord (x + 1) y+findNeighborCoord (Coord x y) West = Coord (x - 1) y++findDirection :: Coordinate -> Coordinate -> Direction+findDirection startCoord@(Coord x1 y1) endCoord@(Coord x2 y2)+ | y2 == y1 + 1 = North+ | y2 == y1 - 1 = South+ | x2 == x1 + 1 = East+ | x2 == x1 - 1 = West+ | otherwise = error $ printf "Cannot find direction to non-adjacent coordinates (start: %s, end: %s)" (show startCoord) (show endCoord)++instance Show PrintablePathingGrid where+ show (PPG grid) = fold lines+ where+ maxX = grid |> (bounds >>> snd >>> x >>> (+1))+ str = grid |> (assocs >>> (sortBy sillySort) >>> (fmap $ snd >>> terrainToChar))+ lines = str |> ((chunksOf maxX) >>> reverse >>> (makeLinesPretty maxX))++makeLinesPretty :: Int -> [String] -> [String]+makeLinesPretty maxX lines = concat [[topB], linesB, [botB]]+ where+ linesB = fmap (\x -> "|" ++ x ++ "|\n") lines+ border = replicate maxX '-'+ topB = concat ["+", border, "+", "\n"]+ botB = concat ["+", border, "+"]++sillySort :: (Coordinate, Terrain) -> (Coordinate, Terrain) -> Ordering+sillySort (Coord x1 y1, _) (Coord x2 y2, _) =+ if y1 < y2 then LT else if y1 > y2 then GT+ else if x1 < x2 then LT else if x1 > x2 then GT+ else EQ
+ src/PathFindingCore/PathingMap/Coordinate.hs view
@@ -0,0 +1,17 @@+module PathFindingCore.PathingMap.Coordinate where++import Data.Ix++data Coordinate+ = Coord { x :: Int, y :: Int } deriving (Eq, Ix, Ord, Show)++data Breadcrumb+ = Crumb { to :: Coordinate, from :: Breadcrumb }+ | Source { source :: Coordinate } deriving (Eq, Show)++breadcrumbsToList :: Breadcrumb -> [Coordinate]+breadcrumbsToList (Source s) = [s]+breadcrumbsToList x = reverse $ helper x+ where+ helper src@(Source _) = breadcrumbsToList src+ helper (Crumb to from) = to : (helper from)
+ src/PathFindingCore/PathingMap/Direction.hs view
@@ -0,0 +1,10 @@+module PathFindingCore.PathingMap.Direction where++data Direction+ = North+ | East+ | South+ | West deriving (Eq, Show)++directions :: [Direction]+directions = [North, East, South, West]
+ src/PathFindingCore/PathingMap/Interpreter.hs view
@@ -0,0 +1,69 @@+module PathFindingCore.PathingMap.Interpreter(fromMapString, PathingGrid, PathingMapString(..), PathingMapData(..)) where++import Control.Arrow((>>>))+import Data.Array.IArray(Array, assocs, listArray)+import Data.Foldable(fold)+import Data.List(isSuffixOf)+import Data.List.Split(splitOn)++import PathFindingCore.PathingMap.Coordinate(Coordinate(Coord))+import PathFindingCore.PathingMap.Terrain(charToTerrain, Terrain(Goal, Self))++type PathingGrid = Array Coordinate Terrain++data PathingMapString+ = PathingMapString {+ str :: String,+ delim :: String+ } deriving (Eq)++data PathingMapData+ = PathingMapData {+ start :: Coordinate,+ goal :: Coordinate,+ grid :: PathingGrid+ } deriving (Eq, Show)++a |> f = f a++fromMapString :: PathingMapString -> PathingMapData+fromMapString (PathingMapString "" _) = error "Cannot build map from empty string"+fromMapString (PathingMapString str delim) = PathingMapData start goal grid+ where+ grid = str |> ((dropDelim delim) >>> (splitOn delim) >>> strListToGrid)+ (start, goal) = findStartAndGoal grid+ dropDelim d s = if (isSuffixOf d s) then s |> (reverse >>> (drop $ length d) >>> reverse) else s++-- The need for `rotateClockwise` likely seems bizarre, at first glance. To frame the reason for its necessity:+-- We start with rows of strings (strs[a][b] => a: 0 = top row, b: 0 = leftmost character) and we need to transform+-- it such that it follows normal Cartesian coordinate rules (strs[a][b] => a: 0 = leftmost character, b: 0 = bottom+-- row) --JAB (8/13/14)+strListToGrid :: [String] -> PathingGrid+strListToGrid strList = listArray (Coord 0 0, endCoord) terrains+ where+ str = fold $ rotateClockwise strList+ terrains = fmap charToTerrain str+ length' = length >>> (subtract 1)+ xLength = strList |> (last >>> length')+ yLength = strList |> (length')+ endCoord = Coord xLength yLength++findStartAndGoal :: PathingGrid -> (Coordinate, Coordinate)+findStartAndGoal arr = analyzeResult $ foldr findBest (Nothing, Nothing) (assocs arr)+ where+ findBest (coord, Self) (_, g) = (Just coord, g)+ findBest (coord, Goal) (s, _) = (s, Just coord)+ findBest _ (s, g) = (s, g)+ analyzeResult (Nothing, _ ) = error "No start in given grid."+ analyzeResult (_, Nothing) = error "No goal in given grid."+ analyzeResult (Just start, Just goal) = (start, goal)++rotateClockwise :: [[t]] -> [[t]]+rotateClockwise ts = reverse (helper ts [])+ where+ helper xs acc | isUseless xs = acc+ helper xs acc = xs |> ((fmap unsnap) >>> unzip >>> (recurse acc))+ isUseless = concat >>> null+ unsnap (x : xs) = (x, xs)+ unsnap [] = error "Impossible condition achieved"+ recurse acc (row, remainder) = helper remainder $ (reverse row) : acc
+ src/PathFindingCore/PathingMap/Terrain.hs view
@@ -0,0 +1,56 @@+module PathFindingCore.PathingMap.Terrain where++import Control.Applicative(pure)+import Control.Arrow((>>>))++data Terrain+ = Ant+ | Empty+ | Food+ | Goal+ | Mound+ | Path+ | Query+ | Self+ | Wall+ | Water deriving (Eq)++isPassable :: Terrain -> Bool+isPassable Ant = True+isPassable Empty = True+isPassable Food = True+isPassable Goal = True+isPassable Mound = True+isPassable Path = False+isPassable Query = False+isPassable Self = False+isPassable Wall = False+isPassable Water = False++charToTerrain :: Char -> Terrain+charToTerrain 'a' = Ant+charToTerrain ' ' = Empty+charToTerrain 'f' = Food+charToTerrain 'G' = Goal+charToTerrain 'O' = Mound+charToTerrain 'x' = Path+charToTerrain '.' = Query+charToTerrain '*' = Self+charToTerrain 'D' = Wall+charToTerrain '%' = Water+charToTerrain x = error $ "Cannot convert '" ++ (show x) ++ "' to a terrain"++terrainToChar :: Terrain -> Char+terrainToChar Ant = 'a'+terrainToChar Empty = ' '+terrainToChar Food = 'f'+terrainToChar Goal = 'G'+terrainToChar Mound = 'O'+terrainToChar Path = 'x'+terrainToChar Query = '.'+terrainToChar Self = '*'+terrainToChar Wall = 'D'+terrainToChar Water = '%'++instance Show Terrain where+ show = terrainToChar >>> pure
+ src/PathFindingCore/Status.hs view
@@ -0,0 +1,10 @@+module PathFindingCore.Status where++data Status+ = Failure+ | Success+ | Continue++data RunResult+ = FailedRun+ | SuccessfulRun
+ src/PathFindingTest/TestSet.hs view
@@ -0,0 +1,351 @@+module PathFindingTest.TestSet(PathingMapTest(..), tests) where++import PathFindingCore.PathingMap.Interpreter(PathingMapString(..))++data PathingMapTest = PathingMapTest { dist :: Maybe Double, pathingMapStr :: PathingMapString }++tests :: [PathingMapTest]+tests = [testMap1, testMap2, testMap3, testMap4, testMap5, testMap6, testMap7, testMap8, testMap9, testMap10+ ,testMap11, testMap12, testMap13, testMap14, testMap15, testMap16, testMap17, testMap18, testMap19, testMap20+ ,testMap21, testMap22, testMap23, testMap24, testMap25, testMap26, testMap27, testMap28, testMap29, testMap30+ ,testMap31, testMap32, testMap33, testMap34, testMap35, testMap36, testMap37, testMap38, testMap39+ ]++pms :: String -> String -> PathingMapString+pms = flip PathingMapString++testMap1 :: PathingMapTest+testMap1 = PathingMapTest (Just 14) $ pms "akjshdkjashldjaksdhljakds" "* G"++testMap2 :: PathingMapTest+testMap2 = PathingMapTest (Just 2) $ pms "asdf" " *asdf\+ \G asdf"++testMap3 :: PathingMapTest+testMap3 = PathingMapTest Nothing $ pms "|" " % *|\+ \OG% %|\+ \%% |"++testMap4 :: PathingMapTest+testMap4 = PathingMapTest (Just 6) $ pms "|" " % *|\+ \OG% %|\+ \% |"++testMap5 :: PathingMapTest+testMap5 = PathingMapTest (Just 39) $ pms "|" " |\+ \ * |\+ \ |\+ \ |\+ \%%%%%%%%%% |\+ \ GD |\+ \D DDDDDDDD |\+ \ D D D |\+ \ DD D |\+ \ D DDDD |\+ \DDDDD D |\+ \ DDDD D |\+ \ |\+ \ |\+ \ "++testMap6 :: PathingMapTest+testMap6 = PathingMapTest (Just 61) $ pms "|" " |\+ \ * |\+ \ O%%%%%|\+ \ |\+ \%%%%%%%%%%%%%% |\+ \ GD |\+ \D DDDDDDDD %%%%|\+ \ D D D |\+ \ DD D%%%% |\+ \ D DDDD |\+ \DDDDD D |\+ \ DDDD D |\+ \ % % |\+ \ % % |\+ \ "++testMap7 :: PathingMapTest+testMap7 = PathingMapTest Nothing $ pms "|" "*DG"++testMap8 :: PathingMapTest+testMap8 = PathingMapTest (Just 14) $ pms "|" "G *"++testMap9 :: PathingMapTest+testMap9 = PathingMapTest (Just 14) $ pms "|" "*|\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \G"++testMap10 :: PathingMapTest+testMap10 = PathingMapTest (Just 14) $ pms "|" "G|\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \*"++testMap11 :: PathingMapTest+testMap11 = PathingMapTest (Just 7) $ pms "|" " * G"++testMap12 :: PathingMapTest+testMap12 = PathingMapTest (Just 8) $ pms "|" " |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \*|\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \ |\+ \G"++testMap13 :: PathingMapTest+testMap13 = PathingMapTest (Just 14) $ pms "|" "* G|\+ \ |\+ \ |\+ \ |\+ \ "++testMap14 :: PathingMapTest+testMap14 = PathingMapTest (Just 14) $ pms "|" "G *|\+ \ |\+ \ |\+ \ |\+ \ "++testMap15 :: PathingMapTest+testMap15 = PathingMapTest (Just 14) $ pms "|" " |\+ \ |\+ \ |\+ \ |\+ \* G"++testMap16 :: PathingMapTest+testMap16 = PathingMapTest (Just 14) $ pms "|" " |\+ \ |\+ \ |\+ \ |\+ \G *"++testMap17 :: PathingMapTest+testMap17 = PathingMapTest (Just 14) $ pms "|" " |\+ \ |\+ \* G|\+ \ |\+ \ "++testMap18 :: PathingMapTest+testMap18 = PathingMapTest (Just 4) $ pms "|" "* |\+ \ |\+ \ |\+ \ |\+ \G "++testMap19 :: PathingMapTest+testMap19 = PathingMapTest (Just 4) $ pms "|" "G |\+ \ |\+ \ |\+ \ |\+ \* "++testMap20 :: PathingMapTest+testMap20 = PathingMapTest (Just 4) $ pms "|" " *|\+ \ |\+ \ |\+ \ |\+ \ G"++testMap21 :: PathingMapTest+testMap21 = PathingMapTest (Just 4) $ pms "|" " G|\+ \ |\+ \ |\+ \ |\+ \ *"++testMap22 :: PathingMapTest+testMap22 = PathingMapTest (Just 4) $ pms "|" " * |\+ \ |\+ \ |\+ \ |\+ \ G "++testMap23 :: PathingMapTest+testMap23 = PathingMapTest (Just 4) $ pms "|" " G |\+ \ |\+ \ |\+ \ |\+ \ * "++testMap24 :: PathingMapTest+testMap24 = PathingMapTest (Just 18) $ pms "|" " G|\+ \ |\+ \ |\+ \ |\+ \* "++testMap25 :: PathingMapTest+testMap25 = PathingMapTest (Just 18) $ pms "|" "G |\+ \ |\+ \ |\+ \ |\+ \ *"++testMap26 :: PathingMapTest+testMap26 = PathingMapTest (Just 9) $ pms "|" "G |\+ \ |\+ \ * |\+ \ |\+ \ "++testMap27 :: PathingMapTest+testMap27 = PathingMapTest (Just 20) $ pms "|" "GD DD D |\+ \ DD D D D |\+ \ D D |\+ \ D D D |\+ \ D D D *"++testMap28 :: PathingMapTest+testMap28 = PathingMapTest (Just 4) $ pms "|" " G|\+ \ D |\+ \ D |\+ \ D |\+ \ D*"++testMap29 :: PathingMapTest+testMap29 = PathingMapTest (Just 32) $ pms "|" "G |\+ \ |\+ \ |\+ \DDDDDDDDDDDDDD |\+ \* "++testMap30 :: PathingMapTest+testMap30 = PathingMapTest (Just 15) $ pms "|" " D |\+ \ D |\+ \ D*D |\+ \ DDD |\+ \G "++testMap31 :: PathingMapTest+testMap31 = PathingMapTest (Just 13) $ pms "|" " |\+ \ D D |\+ \ D*D |\+ \ DDD |\+ \G "++testMap32 :: PathingMapTest+testMap32 = PathingMapTest (Just 13) $ pms "|" " D |\+ \ D D |\+ \ D*D |\+ \ DDD |\+ \G "++testMap33 :: PathingMapTest+testMap33 = PathingMapTest (Just 9) $ pms "|" " D |\+ \ D |\+ \ D*D |\+ \ D D |\+ \G "++testMap34 :: PathingMapTest+testMap34 = PathingMapTest (Just 9) $ pms "|" " D |\+ \ D |\+ \ *D |\+ \ DDD |\+ \G "++testMap35 :: PathingMapTest+testMap35 = PathingMapTest Nothing $ pms "|" " |\+ \ DDD |\+ \ D*D |\+ \ DDD |\+ \G "++testMap36 :: PathingMapTest+testMap36 = PathingMapTest Nothing $ pms "|" " |\+ \ |\+ \ |\+ \ DDDDDDDDDDDDD |\+ \ D D D D |\+ \ D D D |\+ \ D D D |\+ \ D D D |\+ \ D * D |\+ \ D DD |\+ \ D D D |\+ \ DD D D D |\+ \ DDDDDDDDDDDDD |\+ \ |\+ \ G |\+ \ |\+ \ "++testMap37 :: PathingMapTest+testMap37 = PathingMapTest Nothing $ pms "|" " |\+ \ DDD |\+ \ DGD |\+ \ DDD |\+ \* "++testMap38 :: PathingMapTest+testMap38 = PathingMapTest Nothing $ pms "|" " |\+ \ |\+ \ |\+ \ DDDDDDDDDDDDD |\+ \ D D D D |\+ \ D D D |\+ \ D D D |\+ \ D D D |\+ \ D G D |\+ \ D DD |\+ \ D D D |\+ \ DD D D D |\+ \ DDDDDDDDDDDDD |\+ \ |\+ \ * |\+ \ |\+ \ "++testMap39 :: PathingMapTest+testMap39 = PathingMapTest Nothing $ pms "|" " |\+ \ * |\+ \ DDDDDDDDDDDDDDDDDDDDDDDDDDDDDD|\+ \ DDDDDDDDDDDDDDDDDDDDDDDDDDDDDD|\+ \ DD D D |\+ \ DD D f DDDDDDDDDDDDDDDD |\+ \ DD f D DD D |\+ \ DD D fffDD D |\+ \ DD G DD D |\+ \ DD D DDD DDDDDDDDDDDDD |\+ \ DD D D DD DD |\+ \ DDDDDDDDDDDDDDDDDDDDDDDDDDDDDD DDDDDDDDDDDDD |\+ \ DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD D D D D |\+ \ D D D D D D D D |\+ \DDDDDDDDDDDDDDDDDDDDDDDDD D D D D |\+ \DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD|\+ \ DDDDDDDDDDDDDDDDDDDDDD"
+ test/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified BreadcrumbTests as Breadcrumb+import qualified InstanceTests as Instances+import qualified InterpreterTests as IT+import qualified PathingMapTests as PMT++import Test.Framework.Runners.Console(defaultMain)++main = defaultMain $ [IT.tests, PMT.tests, Breadcrumb.tests, Instances.tests]