haskell-karel/Internal/Karel.hs

167 lines
4.6 KiB
Haskell
Raw Normal View History

{-# LANGUAGE LambdaCase #-}
module Internal.Karel where
import Text.Printf
import Internal.Types
import Internal.World
data Karel = Karel
{ karelPosition :: Vector,
karelDirection :: Direction,
karelBeepers :: Int,
karelWorld :: World
}
deriving (Eq)
xor :: Bool -> Bool -> Bool
xor True a = not a
xor False a = a
getHeader :: Karel -> String
getHeader karel = unlines [
printf " %8s %s %s %s" "POSITION" "FACING" "BEEP-BAG" "BEEP-POS",
printf "(%3d, %3d) %6s %8d %8d" x y dir bag pos,
" Y +" <> replicate (4 * width - 1) '-' <> "+"
]
where
(x, y) = karelPosition karel
dir = show $ karelDirection karel
bag = karelBeepers karel
pos = getBeepersAt (x, y) $ karelWorld karel
(width, _) = worldDimensions $ karelWorld karel
getFooter :: Karel -> String
getFooter karel = unlines [
" +" <> replicate (4 * width - 1) '-' <> "+",
" " <> foldl1 (<>) [ printf " %-2d " column | column <- [1..width] ] <> " X"
]
where
(width, _) = worldDimensions $ karelWorld karel
mapDirection :: Karel -> String
mapDirection karel = case karelDirection karel of
North -> " ^ "
East -> " > "
South -> " v "
West -> " < "
mapCell :: Karel -> Int -> Int -> String
mapCell karel x y
| karelPosition karel == (x, y) = mapDirection karel
| beepersAt > 0 = printf " %-2d" beepersAt
| otherwise = " . "
where beepersAt = getBeepersAt (x, y) $ karelWorld karel
mapWall :: Karel -> Int -> Int -> String
mapWall karel x y = leftPart <> rightPart
where
world = karelWorld karel
(northWall:eastWall:westWall:_) = map (\d -> hasWallAt (x, y) d world) [North, East, West]
(northWallOnLeft:northWallOnRight:_) = map (\d -> hasWallAt (x + d, y) North world) [-1, 1]
(eastWallAbove:westWallAbove:_) = map (\d -> hasWallAt (x, y + 1) d world) [East, West]
verticalWall = eastWall && eastWallAbove
wallEnds = northWall && not northWallOnRight
wallStarts = northWall && x > 1 && not northWallOnLeft
leftPart
| wallStarts && not (westWall || westWallAbove) = "+-"
| northWall = "--"
| otherwise = " "
rightPart
| northWall && wallEnds && verticalWall = "-|"
| wallEnds || (northWall && eastWallAbove) = "-+"
| northWall = "--"
| (verticalWall && northWallOnRight) || (eastWall `xor` eastWallAbove) = " +"
| verticalWall = " |"
| otherwise = " "
getRow :: Karel -> Int -> String
getRow karel row
| row == height = line
| otherwise = horizontalWalls <> "\n" <> line
where
world = karelWorld karel
(width, height) = worldDimensions world
horizontalWalls = " |" <> foldl1 (<>) [
mapWall karel column row
| column <- [1..width]
]
line = printf "%2d |" row <> foldl1 (<>) [
position <> wall
| column <- [1..width],
let wall = if hasWallAt (column, row) East world then "|" else " ",
let position = mapCell karel column row
]
getMap :: Karel -> String
getMap karel = unlines [
getRow karel row
| row <- reverse [1..height]
]
where (_, height) = worldDimensions $ karelWorld karel
instance Show Karel where
show karel = getHeader karel <> getMap karel <> getFooter karel
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
}