Major refactor

- Use internal modules for helper functions
- Clean up API
- Add `facing` to Karel and `notFacing` to SuperKarel
- Rename functions for creating world and Karel

Signed-off-by: Matej Focko <me@mfocko.xyz>

Internal/Karel.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Internal.Karel where
+
+import Internal.Types
+import Internal.World
+
+data Karel = Karel
+  { karelPosition :: Vector,
+    karelDirection :: Direction,
+    karelBeepers :: Int,
+    karelWorld :: World
+  }
+  deriving (Show, Eq)
+
+stepVector :: Direction -> Vector
+stepVector = \case
+  North -> (0, 1)
+  East -> (1, 0)
+  South -> (0, -1)
+  West -> (-1, 0)
+
+leftTurn :: Direction -> Direction
+leftTurn = \case
+  North -> West
+  West -> South
+  South -> East
+  East -> North
+
+changeBeepers :: Int -> Karel -> Karel
+changeBeepers db robot
+  | checkedCount <= 0 = error ("There are no beepers to " ++ msg)
+  | otherwise =
+    robot
+      { karelBeepers = inBag + db,
+        karelWorld = setBeepersAt position (atPosition - db) world
+      }
+  where
+    (position, world) = (karelPosition robot, karelWorld robot)
+    inBag = karelBeepers robot
+    atPosition = getBeepersAt position world
+    (checkedCount, msg) =
+      if db == 1 then (atPosition, "pick up") else (inBag, "put down")
+
+defaultKarel :: World -> Karel
+defaultKarel world =
+  Karel
+    { karelPosition = (1, 1),
+      karelDirection = East,
+      karelBeepers = 0,
+      karelWorld = world
+    }
+
+initialPosition :: Vector -> Karel -> Karel
+initialPosition pos robot
+  | not $ positionWithinWorld (karelWorld robot) pos = error "Invalid position"
+  | otherwise =
+    robot
+      { karelPosition = pos
+      }
+
+initialDirection :: Direction -> Karel -> Karel
+initialDirection dir robot =
+  robot
+    { karelDirection = dir
+    }
+
+initialBeepersInBag :: Int -> Karel -> Karel
+initialBeepersInBag beepers robot
+  | beepers < 0 = error "Invalid count of beepers"
+  | otherwise =
+    robot
+      { karelBeepers = beepers
+      }

Internal/Types.hs

@@ -0,0 +1,5 @@
+module Internal.Types where
+
+type Vector = (Int, Int)
+
+data Direction = North | East | South | West deriving (Show, Eq, Ord)

Internal/World.hs

@@ -0,0 +1,98 @@
+{-# 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
+
+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 pos newWalls (worldWalls w)}
+  where
+    (newPosition, newDirection) = switchDirectionToInternal pos dir
+    oldWalls = M.findWithDefault S.empty pos (worldWalls w)
+    newWalls = S.union oldWalls $ S.singleton dir
+
+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 pos (worldWalls w)}
+  | otherwise = w {worldWalls = M.insert pos newWalls (worldWalls w)}
+  where
+    (newPosition, newDirection) = switchDirectionToInternal pos dir
+    oldWalls = M.findWithDefault S.empty pos (worldWalls w)
+    newWalls = oldWalls S.\\ S.singleton dir
+
+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.!? pos of
+    Just wallsInPlace -> S.member dir wallsInPlace
+    Nothing -> False
+  where
+    (newPosition, newDirection) = switchDirectionToInternal pos dir

Karel.hs

@@ -1,10 +1,8 @@
-{-# LANGUAGE LambdaCase #-}
-
 module Karel
   ( -- data types
     Vector,
     Direction (..),
-    Karel (..),
+    Karel,
     -- public interface
     step,
     turnLeft,
@@ -12,6 +10,7 @@ module Karel
     putBeeper,
     frontIsClear,
     beepersPresent,
+    facing,
     facingNorth,
     beepersInBag,
     -- for creating world
@@ -20,128 +19,55 @@ module Karel
     addWallAt,
     removeWallAt,
     -- for creating Karel
-    defaultRobot,
+    defaultKarel,
-    positionOfRobot,
+    initialPosition,
-    directionOfRobot,
+    initialDirection,
-    beepersOfRobot,
+    initialBeepersInBag,
   )
 where
 
-import World
+import Internal.Karel
-  ( Direction (..),
+import Internal.Types
-    Vector,
+import Internal.World
-    World,
-    addWallAt,
-    getBeepersAt,
-    hasWallAt,
-    positionWithinWorld,
-    removeWallAt,
-    setBeepersAt,
-    worldWithDimensions,
-  )
-
-data Karel = Karel
-  { position :: Vector,
-    direction :: Direction,
-    beepers :: Int,
-    world :: World
-  }
-  deriving (Show, Eq)
-
-defaultRobot :: World -> Karel
-defaultRobot itsWorld =
-  Karel
-    { position = (1, 1),
-      direction = East,
-      beepers = 0,
-      world = itsWorld
-    }
-
-positionOfRobot :: Vector -> Karel -> Karel
-positionOfRobot robot_position robot
-  | not $ positionWithinWorld (world robot) robot_position = error "Invalid position"
-  | otherwise =
-    robot
-      { position = robot_position
-      }
-
-directionOfRobot :: Direction -> Karel -> Karel
-directionOfRobot robot_direction robot =
-  robot
-    { direction = robot_direction
-    }
-
-beepersOfRobot :: Int -> Karel -> Karel
-beepersOfRobot robot_beepers robot
-  | robot_beepers < 0 = error "Invalid count of beepers"
-  | otherwise =
-    robot
-      { beepers = robot_beepers
-      }
-
-stepVector :: Direction -> Vector
-stepVector = \case
-  North -> (0, 1)
-  East -> (1, 0)
-  South -> (0, -1)
-  West -> (-1, 0)
-
-leftTurn :: Direction -> Direction
-leftTurn = \case
-  North -> West
-  West -> South
-  South -> East
-  East -> North
 
 step :: Karel -> Karel
 step robot
-  | hasWallAt position' direction' (world robot) = error "Cannot pass through the wall"
+  | hasWallAt position' direction' (karelWorld robot) = error "Cannot pass through the wall"
   | otherwise =
     robot
-      { position = (x + dx, y + dy)
+      { karelPosition = (x + dx, y + dy)
       }
   where
-    position' = position robot
+    position' = karelPosition robot
-    direction' = direction robot
+    direction' = karelDirection robot
     (x, y) = position'
     (dx, dy) = stepVector direction'
 
 turnLeft :: Karel -> Karel
 turnLeft robot =
   robot
-    { direction = leftTurn $ direction robot
+    { karelDirection = leftTurn $ karelDirection robot
     }
 
 pickBeeper :: Karel -> Karel
-pickBeeper robot
+pickBeeper = changeBeepers 1
-  | beepersAtPosition <= 0 = error "There are no beepers to pick up"
-  | otherwise =
-    robot
-      { beepers = beepers robot + 1,
-        world = setBeepersAt (position robot) (beepersAtPosition - 1) (world robot)
-      }
-  where
-    beepersAtPosition = getBeepersAt (position robot) (world robot)
 
 putBeeper :: Karel -> Karel
-putBeeper robot
+putBeeper = changeBeepers (-1)
-  | beepers robot <= 0 = error "There are no beepers to put down"
-  | otherwise =
-    robot
-      { beepers = beepers robot - 1,
-        world = setBeepersAt (position robot) (beepersAtPosition + 1) (world robot)
-      }
-  where
-    beepersAtPosition = getBeepersAt (position robot) (world robot)
 
 frontIsClear :: Karel -> Bool
-frontIsClear robot = not $ hasWallAt (position robot) (direction robot) (world robot)
+frontIsClear robot = not $ hasWallAt pos dir wrld
+  where
+    (pos, dir, wrld) = (karelPosition robot, karelDirection robot, karelWorld robot)
 
 beepersPresent :: Karel -> Bool
-beepersPresent robot = (> 0) $ getBeepersAt (position robot) (world robot)
+beepersPresent robot = (> 0) $ getBeepersAt (karelPosition robot) (karelWorld robot)
+
+facing :: Direction -> Karel -> Bool
+facing dir = (== dir) . karelDirection
 
 facingNorth :: Karel -> Bool
-facingNorth = (== North) . direction
+facingNorth = facing North
 
 beepersInBag :: Karel -> Bool
-beepersInBag = (> 0) . beepers
+beepersInBag = (> 0) . karelBeepers

SuperKarel.hs

@@ -20,23 +20,26 @@ rightIsBlocked = not . rightIsClear
 noBeepersPresent :: Karel -> Bool
 noBeepersPresent = not . beepersPresent
 
+notFacing :: Direction -> Karel -> Bool
+notFacing dir = not . facing dir
+
 notFacingNorth :: Karel -> Bool
 notFacingNorth = not . facingNorth
 
 facingSouth :: Karel -> Bool
-facingSouth = (== South) . direction
+facingSouth = facing South
 
 notFacingSouth :: Karel -> Bool
 notFacingSouth = not . facingSouth
 
 facingEast :: Karel -> Bool
-facingEast = (== East) . direction
+facingEast = facing East
 
 notFacingEast :: Karel -> Bool
 notFacingEast = not . facingEast
 
 facingWest :: Karel -> Bool
-facingWest = (== West) . direction
+facingWest = facing West
 
 notFacingWest :: Karel -> Bool
 notFacingWest = not . facingWest

World.hs

@@ -1,105 +0,0 @@
-module World
-  ( World,
-    Direction (..),
-    Vector,
-    worldWithDimensions,
-    getBeepersAt,
-    setBeepersAt,
-    hasWallAt,
-    addWallAt,
-    removeWallAt,
-    positionWithinWorld,
-  )
-where
-
-import qualified Data.Map.Strict as M
-import qualified Data.Set as S
-
-type Vector = (Int, Int)
-
-data Direction = North | East | South | West deriving (Show, Eq, Ord)
-
-data World = World
-  { dimensions :: Vector,
-    walls :: M.Map Vector (S.Set Direction),
-    beepers :: 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
-      { dimensions = (width, height),
-        walls = M.empty,
-        beepers = M.empty
-      }
-
-positionWithinWorld :: World -> Vector -> Bool
-positionWithinWorld world (x, y) = valid_x && valid_y
-  where
-    (world_width, world_height) = dimensions world
-    valid_x = x > 0 && x <= world_width
-    valid_y = y > 0 && y <= world_height
-
-setBeepersAt :: Vector -> Int -> World -> World
-setBeepersAt position count world
-  | not $ positionWithinWorld world position = error "Invalid position"
-  | count < 0 = error "Invalid count of beepers"
-  | count == 0 = world {beepers = M.delete position old_beepers}
-  | otherwise = world {beepers = M.insert position count old_beepers}
-  where
-    old_beepers = beepers world
-
-getBeepersAt :: Vector -> World -> Int
-getBeepersAt position world
-  | not $ positionWithinWorld world position = error "Invalid position"
-  | otherwise = M.findWithDefault 0 position (beepers world)
-
-switchDirectionToInternal :: Vector -> Direction -> (Vector, Direction)
-switchDirectionToInternal position direction
-  | direction == West = ((x - 1, y), East)
-  | direction == South = ((x, y - 1), North)
-  | otherwise = (position, direction)
-  where
-    (x, y) = position
-
-isOnEdge :: Vector -> Vector -> Direction -> Bool
-isOnEdge world_dimensions position direction = horizontally || vertically
-  where
-    (width, height) = world_dimensions
-    (x, y) = position
-    horizontally = x == width && direction == East
-    vertically = y == height && direction == North
-
-addWallAt :: Vector -> Direction -> World -> World
-addWallAt position direction world
-  | not $ positionWithinWorld world newPosition = error "Invalid position"
-  | isOnEdge (dimensions world) newPosition newDirection = world
-  | otherwise = world {walls = M.insert position newWalls (walls world)}
-  where
-    (newPosition, newDirection) = switchDirectionToInternal position direction
-    oldWalls = M.findWithDefault S.empty position (walls world)
-    newWalls = S.union oldWalls $ S.singleton direction
-
-removeWallAt :: Vector -> Direction -> World -> World
-removeWallAt position direction world
-  | not $ positionWithinWorld world newPosition = error "Invalid position"
-  | isOnEdge (dimensions world) newPosition newDirection = world
-  | S.null newWalls = world {walls = M.delete position (walls world)}
-  | otherwise = world {walls = M.insert position newWalls (walls world)}
-  where
-    (newPosition, newDirection) = switchDirectionToInternal position direction
-    oldWalls = M.findWithDefault S.empty position (walls world)
-    newWalls = oldWalls S.\\ S.singleton direction
-
-hasWallAt :: Vector -> Direction -> World -> Bool
-hasWallAt position direction world
-  | not $ positionWithinWorld world newPosition = False
-  | isOnEdge (dimensions world) newPosition newDirection = True
-  | otherwise = case walls world M.!? position of
-    Just wallsInPlace -> S.member direction wallsInPlace
-    Nothing -> False
-  where
-    (newPosition, newDirection) = switchDirectionToInternal position direction