163 lines
4.8 KiB
Haskell
163 lines
4.8 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module AI.Vacuum.Grid where
|
|
|
|
import qualified Data.Map as M
|
|
import qualified Data.List as L
|
|
import Data.Maybe (fromJust)
|
|
import Data.Ix (range)
|
|
import Control.Monad (forM_)
|
|
import Data.Lens.Common
|
|
import Data.Lens.Template
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
import Debug.Trace (putTraceMsg)
|
|
|
|
trace :: String -> a -> a
|
|
trace string expr = unsafePerformIO $ do
|
|
putTraceMsg string
|
|
return expr
|
|
|
|
data Direction = North | East | South | West deriving (Eq, Show, Enum, Bounded)
|
|
data CellType = Empty | Furniture | Dirt | Home deriving (Eq, Show, Ord)
|
|
type Point = (Int, Int)
|
|
type Path = [Point]
|
|
data Cell = Cell { _point :: Point, _cellType :: CellType } deriving (Eq, Show)
|
|
type Grid = M.Map Point Cell
|
|
|
|
makeLenses [''Cell]
|
|
|
|
class (Enum a, Eq a, Bounded a) => WrappedBoundedEnum a where
|
|
next :: a -> a
|
|
prev :: a -> a
|
|
|
|
next x = if (maxBound == x) then minBound else succ x
|
|
prev x = if (minBound == x) then maxBound else pred x
|
|
|
|
instance WrappedBoundedEnum Direction
|
|
|
|
right :: Direction -> Direction
|
|
right = next
|
|
|
|
left :: Direction -> Direction
|
|
left = prev
|
|
|
|
forwardPoint :: Point -> Direction -> Point
|
|
forwardPoint (x, y) North = (x, y - 1)
|
|
forwardPoint (x, y) East = (x + 1, y)
|
|
forwardPoint (x, y) South = (x, y + 1)
|
|
forwardPoint (x, y) West = (x - 1, y)
|
|
|
|
backwardPoint :: Point -> Direction -> Point
|
|
backwardPoint (x, y) North = (x, y + 1)
|
|
backwardPoint (x, y) East = (x - 1, y)
|
|
backwardPoint (x, y) South = (x, y - 1)
|
|
backwardPoint (x, y) West = (x + 1, y)
|
|
|
|
rightPoint :: Point -> Direction -> Point
|
|
rightPoint (x, y) North = (x + 1, y)
|
|
rightPoint (x, y) East = (x, y + 1)
|
|
rightPoint (x, y) South = (x - 1, y)
|
|
rightPoint (x, y) West = (x, y - 1)
|
|
|
|
leftPoint :: Point -> Direction -> Point
|
|
leftPoint (x, y) North = (x -1, y)
|
|
leftPoint (x, y) East = (x, y - 1)
|
|
leftPoint (x, y) South = (x + 1, y)
|
|
leftPoint (x, y) West = (x, y + 1)
|
|
|
|
orientation :: Point -> Point -> (Maybe Direction, Maybe Direction)
|
|
orientation from@(x1, y1) to@(x2, y2)
|
|
| from == to = (Nothing, Nothing)
|
|
| y1 == y2 && x2 > x1 = (Just East, Nothing)
|
|
| y1 == y2 && x2 < x1 = (Just West, Nothing)
|
|
| x1 == x2 && y2 > y1 = (Nothing, Just South)
|
|
| x1 == x2 && y2 < y1 = (Nothing, Just North)
|
|
| y2 < y1 && x2 > x1 = (Just East, Just North)
|
|
| y2 < y1 && x2 < x1 = (Just West, Just North)
|
|
| y2 > y1 && x2 > x1 = (Just East, Just South)
|
|
| y2 > y1 && x2 < x1 = (Just West, Just South)
|
|
|
|
horzPath :: Point -> Point -> [Point]
|
|
horzPath p1@(x1, y1) p2@(x2, _)
|
|
| x1 <= x2 = map (\x -> (x, y1)) $ range (x1, x2)
|
|
| otherwise = reverse . map (\x -> (x, y1)) $ range (x2, x1)
|
|
|
|
vertPath :: Point -> Point -> [Point]
|
|
vertPath p1@(x1, y1) p2@(_, y2)
|
|
| y1 <= y2 = map (\y -> (x1, y)) $ range (y1, y2)
|
|
| otherwise = reverse . map (\y -> (x1, y)) $ range (y2, y1)
|
|
|
|
manhattanPaths :: Point -> Point -> [[Point]]
|
|
manhattanPaths p1@(x1,y1) p2@(x2,y2)
|
|
| p1 == p2 = []
|
|
| otherwise = [L.nub (hp1 ++ vp1), L.nub (vp2 ++ hp2)]
|
|
where
|
|
hp1 = horzPath p1 p2
|
|
vp1 = vertPath (last hp1) p2
|
|
vp2 = vertPath p1 p2
|
|
hp2 = horzPath (last vp2) p2
|
|
|
|
cornerPoints :: Point -> Int -> [Point]
|
|
cornerPoints (x,y) distance =
|
|
[(x + distance, y + distance),
|
|
(x - distance, y + distance),
|
|
(x - distance, y - distance),
|
|
(x + distance, y - distance)]
|
|
|
|
borderingPoints :: Point -> Int -> [Point]
|
|
borderingPoints point distance =
|
|
L.nub . concat
|
|
. map (\(p1@(_,y1), p2@(_,y2)) ->
|
|
if y1 == y2 then horzPath p1 p2 else vertPath p1 p2)
|
|
. pairs . take 5 . cycle $ cornerPoints point distance
|
|
|
|
lookupCell :: Point -> Grid -> Maybe Cell
|
|
lookupCell = M.lookup
|
|
|
|
forwardCell :: Cell -> Direction -> Grid -> Maybe Cell
|
|
forwardCell (Cell point _) = lookupCell . (forwardPoint point)
|
|
|
|
rightCell :: Cell -> Direction -> Grid -> Maybe Cell
|
|
rightCell (Cell point _) = lookupCell . (rightPoint point)
|
|
|
|
leftCell :: Cell -> Direction -> Grid -> Maybe Cell
|
|
leftCell (Cell point _) = lookupCell . (leftPoint point)
|
|
|
|
gridFromCellList :: [Cell] -> Grid
|
|
gridFromCellList = foldl (\m cell@(Cell p _) -> M.insert p cell m) M.empty
|
|
|
|
freqMap :: (Ord a) => [a] -> [(a, Int)]
|
|
freqMap = M.toList . foldl (\m t -> M.insertWith (+) t 1 m) M.empty
|
|
|
|
pairs :: [a] -> [(a,a)]
|
|
pairs [] = []
|
|
pairs [_] = []
|
|
pairs (x1 : x2 : xs) = (x1, x2) : pairs (x2 : xs)
|
|
|
|
gridWidth :: Grid -> Int
|
|
gridWidth = (+ 1) . maximum . map fst . M.keys
|
|
|
|
gridHeight :: Grid -> Int
|
|
gridHeight = (+ 1) . maximum . map snd . M.keys
|
|
|
|
gridStats :: Grid -> [(CellType, Int)]
|
|
gridStats = freqMap . map (cellType ^$) . M.elems
|
|
|
|
showCell :: Cell -> String
|
|
showCell cell =
|
|
case cell^.cellType of
|
|
Dirt -> "X "
|
|
Empty -> "O "
|
|
Furniture -> "F "
|
|
Home -> "H "
|
|
|
|
printGrid :: Grid -> IO ()
|
|
printGrid grid = do
|
|
let width = gridWidth grid
|
|
let height = gridHeight grid
|
|
|
|
forM_ (range (0, height - 1)) $ \y -> do
|
|
forM_ (range (0, width - 1)) $ \x ->
|
|
putStr . showCell . fromJust . lookupCell (x,y) $ grid
|
|
putStrLn ""
|