mfocko/haskell-karel
1
0
Fork 0
Code Issues 1 Pull requests Projects Releases Wiki Activity

Refactor handling of walls

Browse source 
Fixes #2

Signed-off-by: Matej Focko <me@mfocko.xyz>
This commit is contained in:
Matej Focko 2020-11-15 17:21:37 +01:00
parent c8e84da990
commit 2a30414ac8
No known key found for this signature in database
GPG key ID: DE0CF444096A468D
1 changed files with 28 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
Internal/World.hs
View file

@ -66,33 +66,39 @@ isOnEdge (width, height) (x, y) dir = horizontally || vertically
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 pos dir w
| not $ positionWithinWorld w newPosition = error "Invalid position"
| isOnEdge (worldDimensions w) newPosition newDirection = w
| otherwise = w {worldWalls = M.insert newPosition newWalls (worldWalls w)}
addWallAt = genericWallAt addWall id (error "Invalid position")
where
(newPosition, newDirection) = switchDirectionToInternal pos dir
oldWalls = M.findWithDefault S.empty newPosition (worldWalls w)
newWalls = S.union oldWalls $ S.singleton newDirection
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 pos dir w
| not $ positionWithinWorld w newPosition = error "Invalid position"
| isOnEdge (worldDimensions w) newPosition newDirection = w
| S.null newWalls = w {worldWalls = M.delete newPosition (worldWalls w)}
| otherwise = w {worldWalls = M.insert newPosition newWalls (worldWalls w)}
removeWallAt = genericWallAt removeWall id (error "Invalid position")
where
(newPosition, newDirection) = switchDirectionToInternal pos dir
oldWalls = M.findWithDefault S.empty newPosition (worldWalls w)
newWalls = oldWalls S.\\ S.singleton newDirection
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 pos dir w
| not $ positionWithinWorld w newPosition = False
| isOnEdge (worldDimensions w) newPosition newDirection = True
| otherwise = case worldWalls w M.!? newPosition of
Just wallsInPlace -> S.member newDirection wallsInPlace
Nothing -> False
hasWallAt = genericWallAt hasWall (const True) False
where
(newPosition, newDirection) = switchDirectionToInternal pos dir
hasWall position direction world =
case worldWalls world M.!? position of
Just wallsInPlace -> S.member direction wallsInPlace
Nothing -> False