haskell-karel/Internal/World.hs

{-# 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 newPosition newWalls (worldWalls w)}
  where
    (newPosition, newDirection) = switchDirectionToInternal pos dir
    oldWalls = M.findWithDefault S.empty newPosition (worldWalls w)
    newWalls = S.union oldWalls $ S.singleton newDirection

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 newPosition (worldWalls w)}
  | otherwise = w {worldWalls = M.insert newPosition newWalls (worldWalls w)}
  where
    (newPosition, newDirection) = switchDirectionToInternal pos dir
    oldWalls = M.findWithDefault S.empty newPosition (worldWalls w)
    newWalls = oldWalls S.\\ S.singleton newDirection

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.!? newPosition of
    Just wallsInPlace -> S.member newDirection wallsInPlace
    Nothing -> False
  where
    (newPosition, newDirection) = switchDirectionToInternal pos dir