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

getWalls :: Vector -> M.Map Vector (S.Set Direction) -> S.Set Direction
getWalls = M.findWithDefault S.empty

genericWallAt :: (Vector -> Direction -> World -> a) -> (World -> a) -> a -> Vector -> Direction -> World -> a
genericWallAt action edgeValue errorValue pos dir world
  | not $ positionWithinWorld world pos = errorValue
  | isOnEdge (worldDimensions world) position direction = edgeValue world
  | otherwise = action position direction world
  where (position, direction) = switchDirectionToInternal pos dir

addWallAt :: Vector -> Direction -> World -> World
addWallAt = genericWallAt addWall id (error "Invalid position")
  where
    addWall position direction world =
        world {worldWalls = M.insert position newWalls walls}
      where
        walls = worldWalls world
        newWalls = S.union (getWalls position walls) $ S.singleton direction

removeWallAt :: Vector -> Direction -> World -> World
removeWallAt = genericWallAt removeWall id (error "Invalid position")
  where
    removeWall position direction world
      | S.null newWalls = world {worldWalls = M.delete position walls}
      | otherwise = world {worldWalls = M.insert position newWalls walls}
      where
        walls = worldWalls world
        newWalls = getWalls position walls S.\\ S.singleton direction

hasWallAt :: Vector -> Direction -> World -> Bool
hasWallAt = genericWallAt hasWall (const True) False
  where
    hasWall position direction world =
      case worldWalls world M.!? position of
        Just wallsInPlace -> S.member direction wallsInPlace
        Nothing -> False