haskell-karel/Internal/World.hs

105 lines
3.5 KiB
Haskell
Raw Normal View History

{-# LANGUAGE LambdaCase #-}
module Internal.World
( World(..),
worldWithDimensions,
getBeepersAt,
setBeepersAt,
hasWallAt,
addWallAt,
removeWallAt,
positionWithinWorld,
)
where
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Internal.Types
data World = World
{ worldDimensions :: Vector,
worldWalls :: M.Map Vector (S.Set Direction),
worldBeepers :: M.Map Vector Int
}
deriving (Show, Eq)
worldWithDimensions :: Vector -> World
worldWithDimensions (width, height)
| width <= 0 || height <= 0 = error "Cannot have world with zero or negative dimension"
| otherwise =
World
{ worldDimensions = (width, height),
worldWalls = M.empty,
worldBeepers = M.empty
}
positionWithinWorld :: World -> Vector -> Bool
positionWithinWorld w (x, y) = valid_x && valid_y
where
(world_width, world_height) = worldDimensions w
valid_x = x > 0 && x <= world_width
valid_y = y > 0 && y <= world_height
setBeepersAt :: Vector -> Int -> World -> World
setBeepersAt pos count w
| not $ positionWithinWorld w pos = error "Invalid position"
| count < 0 = error "Invalid count of worldBeepers"
| count == 0 = w {worldBeepers = M.delete pos old_beepers}
| otherwise = w {worldBeepers = M.insert pos count old_beepers}
where
old_beepers = worldBeepers w
getBeepersAt :: Vector -> World -> Int
getBeepersAt pos w
| not $ positionWithinWorld w pos = error "Invalid position"
| otherwise = M.findWithDefault 0 pos (worldBeepers w)
switchDirectionToInternal :: Vector -> Direction -> (Vector, Direction)
switchDirectionToInternal (x, y) = \case
West -> ((x - 1, y), East)
South -> ((x, y - 1), North)
dir -> ((x, y), dir)
isOnEdge :: Vector -> Vector -> Direction -> Bool
isOnEdge (width, height) (x, y) dir = horizontally || vertically
where
horizontally = x == width && dir == East
vertically = y == height && dir == North
getWalls :: Vector -> M.Map Vector (S.Set Direction) -> S.Set Direction
getWalls = M.findWithDefault S.empty
genericWallAt :: (Vector -> Direction -> World -> a) -> (World -> a) -> a -> Vector -> Direction -> World -> a
genericWallAt action edgeValue errorValue pos dir world
| not $ positionWithinWorld world pos = errorValue
| isOnEdge (worldDimensions world) position direction = edgeValue world
| otherwise = action position direction world
where (position, direction) = switchDirectionToInternal pos dir
addWallAt :: Vector -> Direction -> World -> World
addWallAt = genericWallAt addWall id (error "Invalid position")
where
addWall position direction world =
world {worldWalls = M.insert position newWalls walls}
where
walls = worldWalls world
newWalls = S.union (getWalls position walls) $ S.singleton direction
removeWallAt :: Vector -> Direction -> World -> World
removeWallAt = genericWallAt removeWall id (error "Invalid position")
where
removeWall position direction world
| S.null newWalls = world {worldWalls = M.delete position walls}
| otherwise = world {worldWalls = M.insert position newWalls walls}
where
walls = worldWalls world
newWalls = getWalls position walls S.\\ S.singleton direction
hasWallAt :: Vector -> Direction -> World -> Bool
hasWallAt = genericWallAt hasWall (const True) False
where
hasWall position direction world =
case worldWalls world M.!? position of
Just wallsInPlace -> S.member direction wallsInPlace
Nothing -> False