mfocko/haskell-karel
1
0
Fork 0
Code Issues 1 Pull requests Projects Releases Wiki Activity

Major refactor

Browse source 
- 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>
This commit is contained in:
Matej Focko 2020-11-08 19:18:42 +01:00
parent e8972e94e5
commit 170a64ef77
No known key found for this signature in database
GPG key ID: DE0CF444096A468D
6 changed files with 208 additions and 207 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

74
Internal/Karel.hs Normal file
View file

@ -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
}

5
Internal/Types.hs Normal file
View file

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

98
Internal/World.hs Normal file
View file

@ -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

124
Karel.hs
View file

@ -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

9
SuperKarel.hs
View file

@ -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

105
World.hs
View file

@ -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