104 lines
3.5 KiB
Haskell
104 lines
3.5 KiB
Haskell
{-# 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
|