From e8972e94e5dc376d81c053e25f777031b5ae6d7e Mon Sep 17 00:00:00 2001 From: Matej Focko Date: Sun, 8 Nov 2020 16:14:08 +0100 Subject: [PATCH] Implement first version Signed-off-by: Matej Focko --- Karel.hs | 147 ++++++++++++++++++++++++++++++++++++++++++++++++++ SuperKarel.hs | 45 ++++++++++++++++ World.hs | 105 ++++++++++++++++++++++++++++++++++++ 3 files changed, 297 insertions(+) create mode 100644 Karel.hs create mode 100644 SuperKarel.hs create mode 100644 World.hs diff --git a/Karel.hs b/Karel.hs new file mode 100644 index 0000000..0983d9f --- /dev/null +++ b/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 diff --git a/SuperKarel.hs b/SuperKarel.hs new file mode 100644 index 0000000..4d20d9c --- /dev/null +++ b/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 diff --git a/World.hs b/World.hs new file mode 100644 index 0000000..0938a87 --- /dev/null +++ b/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