parabox/app/Model.hs

module Model where

import Data.Array
import Data.Map (Map)
import Data.Map qualified as Map
import Graphics.Vty
import Control.Monad
import Data.Maybe
import Data.Set qualified as Set

type Coord = (Int, Int)

data Box = Box {
  boxLocation :: Location,
  boxWalls    :: Array Coord Bool,
  boxColor    :: Attr
}
   deriving (Show, Read, Eq)

data Location = Location Char Int Int
  deriving (Read, Show, Ord, Eq)

data World = World {
  worldBoxes :: Map Char Box,
  worldMe :: Char
}
  deriving (Show, Read, Eq)

makeWalls :: [String] -> Array Coord Bool
makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
  where
    h = length rows
    w = length (head rows)
    (xlo,xhi) = mkRange w
    (ylo,yhi) = mkRange h

mkRange :: Int -> (Int,Int)
mkRange n = (- (n-1)`div`2, n`div`2)

boxSize :: Box -> Int
boxSize box = yhi-ylo+1
  where
    ((ylo,_),(yhi,_)) = bounds (boxWalls box)


solid :: Int -> Array Coord Bool
solid n = makeWalls (replicate n (replicate n 'x'))

-- Move an object
-- 1. remove it from the world
-- 2. compute where it would move to
-- 3. a. that spot is empty
--    b. try to move that object forward
--    c. try to move that object backward into me

move :: World -> (Int,Int) -> World
move world dir =
  case moveBlock world Map.empty (myLocation world) dir of
    Nothing -> world
    Just changes ->
      let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in
      world { worldBoxes = fmap f (worldBoxes world)}

myLocation :: World -> Location
myLocation world =
  boxLocation (worldBoxes world Map.! worldMe world)

isWall :: Location -> World -> Bool
isWall (Location n y x) world =
  case Map.lookup n (worldBoxes world) of
    Nothing -> True
    Just box -> boxWalls box ! (y,x)

type Movement = (Int, Int)

moveBlock ::
  World ->
  Map Location (Int, Location) ->
  Location ->
  Movement ->
  Maybe (Map Location Location)

-- moving into a wall, not possible
moveBlock world _ loc _
  | isWall loc world = Nothing

-- move introduced a loop, trim off the tail and report success
moveBlock _ visited loc _
  | Just (n,_) <- Map.lookup loc visited
  = Just (fmap snd (Map.filter (\(a,_)->a >= n) visited))

moveBlock world visited loc dir =
  case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == loc] of
    -- moving an empty space, so we're done
    [] -> Just (fmap snd visited)

    -- moving a box
    (name,box):_ ->
     do loc' <- nextLoc world loc dir
        guard (not (isWall loc' world))
        moveBlock' world visited loc loc' dir name box

moveBlock' ::
    World -> 
    Map Location (Int, Location) -> 
    Location -> 
    Location -> 
    Movement -> 
    Char -> 
    Box -> 
    Maybe (Map Location Location)
moveBlock' world visited loc loc' dir name box =
        msum [moveTo, moveInto, moveToEat]
      where
        moveTo =
         do moveBlock world (addVisited loc loc' visited) loc' dir

        moveInto =
         do (n,b) <- boxAt world loc'
            let locI = enterLoc n b dir
            moveBlock' world visited loc locI dir name box -- beware epsilon!
        
        moveToEat =
         do let dir' = invert dir
            let locE = enterLoc name box dir'
            (name', box') <- boxAt world loc' 
            moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box' 

enterLoc :: Char -> Box -> Movement -> Location
enterLoc name box dir =
  case dir of
    (-1, 0) -> Location name yhi (midpoint xlo xhi)
    ( 1, 0) -> Location name ylo (midpoint xlo xhi)
    ( 0,-1) -> Location name (midpoint ylo yhi) xhi
    ( 0, 1) -> Location name (midpoint ylo yhi) xlo
    _ -> error "enterLoc: bad direction"
  where
    ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)

boxAt :: World -> Location -> Maybe (Char, Box)
boxAt world loc =
  listToMaybe  [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc]

invert :: Movement -> Movement
invert (dy,dx) = (-dy, -dx)

midpoint :: Int -> Int -> Int
midpoint lo hi = (hi+lo)`div`2

addVisited ::
    Location {- ^ start -} ->
    Location {- ^ end   -} ->
    Map Location (Int, Location) ->
    Map Location (Int, Location)
addVisited k v m = Map.insert k (Map.size m, v) m

nextLoc :: World -> Location -> (Int, Int) -> Maybe Location
nextLoc world loc (dy, dx) = go Set.empty loc
  where
    
  go _ (Location b y x)
    | Just box <- Map.lookup b (worldBoxes world)
    , inRange (bounds (boxWalls box)) (y+dy, x+dx)
    = Just (Location b (y+dy) (x+dx))
  
  go visited (Location b _ _)
    | Just box <- Map.lookup b (worldBoxes world)
    , Set.notMember b visited
    = go (Set.insert b visited) (boxLocation box)

  go _ _ = Nothing