diff --git a/Internal/Karel.hs b/Internal/Karel.hs new file mode 100644 index 0000000..cc5b4b7 --- /dev/null +++ b/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 + } diff --git a/Internal/Types.hs b/Internal/Types.hs new file mode 100644 index 0000000..a8091a7 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/Internal/World.hs b/Internal/World.hs new file mode 100644 index 0000000..5e37973 --- /dev/null +++ b/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 diff --git a/Karel.hs b/Karel.hs index 0983d9f..a99373f 100644 --- a/Karel.hs +++ b/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, - positionOfRobot, - directionOfRobot, - beepersOfRobot, + defaultKarel, + initialPosition, + initialDirection, + initialBeepersInBag, ) 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 +import Internal.Karel +import Internal.Types +import Internal.World 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 - direction' = direction robot + position' = karelPosition 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 - | 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) +pickBeeper = changeBeepers 1 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) +putBeeper = changeBeepers (-1) 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 diff --git a/SuperKarel.hs b/SuperKarel.hs index 4d20d9c..b83f4ab 100644 --- a/SuperKarel.hs +++ b/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 diff --git a/World.hs b/World.hs deleted file mode 100644 index 0938a87..0000000 --- a/World.hs +++ /dev/null @@ -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