From 2a30414ac8e0bfd7b54a50a5bc11a78a9258a63c Mon Sep 17 00:00:00 2001
From: Matej Focko <me@mfocko.xyz>
Date: Sun, 15 Nov 2020 17:21:37 +0100
Subject: [PATCH] Refactor handling of walls

Fixes #2

Signed-off-by: Matej Focko <me@mfocko.xyz>
---
 Internal/World.hs | 50 ++++++++++++++++++++++++++---------------------
 1 file changed, 28 insertions(+), 22 deletions(-)

diff --git a/Internal/World.hs b/Internal/World.hs
index 08bb6d1..674c6b7 100644
--- a/Internal/World.hs
+++ b/Internal/World.hs
@@ -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