Implement first version

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

Karel.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Karel
+  ( -- data types
+    Vector,
+    Direction (..),
+    Karel (..),
+    -- public interface
+    step,
+    turnLeft,
+    pickBeeper,
+    putBeeper,
+    frontIsClear,
+    beepersPresent,
+    facingNorth,
+    beepersInBag,
+    -- for creating world
+    worldWithDimensions,
+    setBeepersAt,
+    addWallAt,
+    removeWallAt,
+    -- for creating Karel
+    defaultRobot,
+    positionOfRobot,
+    directionOfRobot,
+    beepersOfRobot,
+  )
+where
+
+import World
+  ( Direction (..),
+    Vector,
+    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"
+  | otherwise =
+    robot
+      { position = (x + dx, y + dy)
+      }
+  where
+    position' = position robot
+    direction' = direction robot
+    (x, y) = position'
+    (dx, dy) = stepVector direction'
+
+turnLeft :: Karel -> Karel
+turnLeft robot =
+  robot
+    { direction = leftTurn $ direction robot
+    }
+
+pickBeeper :: Karel -> Karel
+pickBeeper robot
+  | 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
+  | 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)
+
+beepersPresent :: Karel -> Bool
+beepersPresent robot = (> 0) $ getBeepersAt (position robot) (world robot)
+
+facingNorth :: Karel -> Bool
+facingNorth = (== North) . direction
+
+beepersInBag :: Karel -> Bool
+beepersInBag = (> 0) . beepers

SuperKarel.hs

@@ -0,0 +1,45 @@
+module SuperKarel where
+
+import Karel
+
+frontIsBlocked :: Karel -> Bool
+frontIsBlocked = not . frontIsClear
+
+leftIsClear :: Karel -> Bool
+leftIsClear = frontIsClear . turnLeft
+
+leftIsBlocked :: Karel -> Bool
+leftIsBlocked = not . leftIsClear
+
+rightIsClear :: Karel -> Bool
+rightIsClear = frontIsClear . turnLeft . turnLeft . turnLeft
+
+rightIsBlocked :: Karel -> Bool
+rightIsBlocked = not . rightIsClear
+
+noBeepersPresent :: Karel -> Bool
+noBeepersPresent = not . beepersPresent
+
+notFacingNorth :: Karel -> Bool
+notFacingNorth = not . facingNorth
+
+facingSouth :: Karel -> Bool
+facingSouth = (== South) . direction
+
+notFacingSouth :: Karel -> Bool
+notFacingSouth = not . facingSouth
+
+facingEast :: Karel -> Bool
+facingEast = (== East) . direction
+
+notFacingEast :: Karel -> Bool
+notFacingEast = not . facingEast
+
+facingWest :: Karel -> Bool
+facingWest = (== West) . direction
+
+notFacingWest :: Karel -> Bool
+notFacingWest = not . facingWest
+
+noBeepersInBag :: Karel -> Bool
+noBeepersInBag = not . beepersInBag

World.hs

@@ -0,0 +1,105 @@
+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