253 lines
8.3 KiB
Haskell
253 lines
8.3 KiB
Haskell
module Model where
|
|
|
|
import Data.Array.Unboxed
|
|
import Data.Map (Map)
|
|
import Data.Map qualified as Map
|
|
import Graphics.Vty ( Attr )
|
|
import Control.Monad ( guard, msum )
|
|
import Data.Maybe ( listToMaybe, mapMaybe, maybeToList )
|
|
import Data.Set qualified as Set
|
|
import Data.Set (Set)
|
|
import GHC.Stack (HasCallStack)
|
|
|
|
type Coord = (Int, Int)
|
|
|
|
data Box = Box {
|
|
boxLocation :: Maybe Location,
|
|
boxType :: BoxType,
|
|
boxColor :: Attr,
|
|
boxBoring :: Bool
|
|
}
|
|
deriving (Show, Read, Eq)
|
|
|
|
-- | Compute the height and width of a box.
|
|
boxSize :: World -> Box -> (Int, Int)
|
|
boxSize world box = (yhi-ylo+1, xhi-xlo+1)
|
|
where
|
|
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
|
|
|
|
-- | Find the array corresponding to the walls of a box.
|
|
boxWalls :: World -> Box -> UArray Coord Bool
|
|
boxWalls world box =
|
|
case boxType box of
|
|
Original walls -> walls
|
|
Link c -> boxWalls world (boxIx world c)
|
|
Infinity c -> boxWalls world (boxIx world c)
|
|
Epsilon _ walls -> walls
|
|
|
|
data BoxType
|
|
= Original (UArray Coord Bool) -- ^ plain box
|
|
| Link Char -- ^ entrance clone
|
|
| Infinity Char -- ^ infinite exit
|
|
| Epsilon Char (UArray Coord Bool) -- ^ infinite enter
|
|
deriving (Show, Read, Eq)
|
|
|
|
data Location = Location { locName :: Char, locY :: Int, locX :: Int }
|
|
deriving (Read, Show, Ord, Eq)
|
|
|
|
data World = World {
|
|
worldBoxes :: Map Char Box,
|
|
worldMe :: Char,
|
|
worldButtons :: Set Location,
|
|
worldHome :: Location,
|
|
worldSize :: (Int, Int)
|
|
}
|
|
deriving (Show, Read, Eq)
|
|
|
|
winCondition :: World -> Bool
|
|
winCondition world =
|
|
Set.isSubsetOf (worldButtons world) coverage &&
|
|
Just (worldHome world) == boxLocation (boxIx world (worldMe world))
|
|
where
|
|
coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world)))
|
|
|
|
move :: World -> (Int,Int) -> World
|
|
move world dir =
|
|
case myLocation world of
|
|
Nothing -> world
|
|
Just loc ->
|
|
let locMap = worldLocations world in
|
|
case moveBlock world locMap Map.empty loc dir 0 of
|
|
Nothing -> world
|
|
Just changes ->
|
|
let f box change = box { boxLocation = change } in
|
|
world { worldBoxes = Map.mergeWithKey (\_ a b -> Just (f a b)) id (const Map.empty) (worldBoxes world) changes}
|
|
|
|
myLocation :: World -> Maybe Location
|
|
myLocation world = boxLocation (boxIx world (worldMe world))
|
|
|
|
isWall :: World -> Location -> Bool
|
|
isWall world (Location n y x) =
|
|
case Map.lookup n (worldBoxes world) of
|
|
Nothing -> True
|
|
Just box -> boxWalls world box ! (y,x)
|
|
|
|
type Movement = (Int, Int)
|
|
|
|
moveBlock ::
|
|
World {- ^ world -} ->
|
|
Map Location (Char, Box) {- ^ location cache -} ->
|
|
Map Location (Int, Char, Maybe Location) {- ^ accumulated changes -} ->
|
|
Location {- ^ source location -} ->
|
|
Movement {- ^ movement direction -} ->
|
|
Rational {- ^ offset -} ->
|
|
Maybe (Map Char (Maybe Location))
|
|
|
|
-- moving a wall, not possible
|
|
moveBlock world _ _ loc _ _
|
|
| isWall world loc = Nothing
|
|
|
|
-- move introduced a loop, trim off the tail and report success
|
|
moveBlock _ _ visited loc _ _
|
|
-- XXX: ensure update is consistent to support flipped levels
|
|
| Just (n,_,_) <- Map.lookup loc visited
|
|
= Just (Map.fromList [(c,l) | (a,c,l) <- Map.elems visited, a >= n])
|
|
|
|
moveBlock world locMap visited loc dir offset =
|
|
case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == Just loc] of
|
|
-- moving an empty space, so we're done
|
|
[] -> Just (Map.fromList [(c,l) | (_,c,l) <- Map.elems visited])
|
|
|
|
-- moving a box
|
|
(name,box):_ ->
|
|
case nextLoc world dir loc offset of
|
|
-- block is exiting into the void; finish the move
|
|
Nothing -> Just (Map.fromList ((name, Nothing) : [(c,l) | (_,c,l) <- Map.elems visited]))
|
|
|
|
Just (loc', offset') ->
|
|
do guard (not (isWall world loc'))
|
|
moveBlock' world locMap visited loc loc' dir name box Set.empty offset'
|
|
|
|
moveBlock' ::
|
|
World ->
|
|
Map Location (Char, Box) ->
|
|
Map Location (Int, Char, Maybe Location) ->
|
|
Location ->
|
|
Location ->
|
|
Movement ->
|
|
Char ->
|
|
Box ->
|
|
Set Char ->
|
|
Rational {- ^ offset -} ->
|
|
Maybe (Map Char (Maybe Location))
|
|
moveBlock' world locMap visited loc loc' dir name box enters offset =
|
|
msum [moveTo, moveInto, moveToEat]
|
|
where
|
|
moveTo =
|
|
do moveBlock world locMap (addVisited name loc (Just loc') visited) loc' dir 0
|
|
|
|
moveInto =
|
|
do (n,b) <- Map.lookup loc' locMap
|
|
(locI, offset') <- enterLoc world n b dir offset
|
|
if Set.member (locName loc') enters then
|
|
do epsilon <- findEpsilon world (locName loc')
|
|
moveEpsilon epsilon
|
|
else
|
|
moveBlock' world locMap visited loc locI dir name box (Set.insert (locName loc') enters) offset'
|
|
|
|
moveEpsilon epsilon =
|
|
do let eBox = boxIx world epsilon
|
|
(locI, offset') <- enterLoc world epsilon eBox dir offset
|
|
moveBlock' world locMap visited loc locI dir name box enters offset'
|
|
|
|
moveToEat =
|
|
do let dir' = invert dir
|
|
(locE, _) <- enterLoc world name box dir' 0
|
|
(name', box') <- Map.lookup loc' locMap
|
|
moveBlock' world locMap (addVisited name loc (Just loc') visited) loc' locE dir' name' box' Set.empty 0
|
|
|
|
enterLoc :: World -> Char -> Box -> Movement -> Rational -> Maybe (Location, Rational)
|
|
enterLoc world name box dir@(dy,dx) offset =
|
|
do name' <-
|
|
case boxType box of
|
|
Link c -> Just c
|
|
Original{} -> Just name
|
|
Infinity{} -> Nothing
|
|
Epsilon {} -> Just name
|
|
|
|
let (bh, bw) = boxSize world box
|
|
|
|
-- moving on y axis crosses width face and vice versa
|
|
faceSize = abs dy * bw + abs dx * bh
|
|
|
|
go y x = Just
|
|
(Location name' y x,
|
|
fromIntegral faceSize * offset
|
|
- fromIntegral (abs dy *x + abs dx*y))
|
|
|
|
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
|
|
|
|
case dir of
|
|
(-1, 0) -> go yhi (midpoint xlo xhi offset)
|
|
( 1, 0) -> go ylo (midpoint xlo xhi offset)
|
|
( 0,-1) -> go (midpoint ylo yhi offset) xhi
|
|
( 0, 1) -> go (midpoint ylo yhi offset) xlo
|
|
_ -> error "enterLoc: bad direction"
|
|
|
|
boxIx :: HasCallStack => World -> Char -> Box
|
|
boxIx world name =
|
|
case Map.lookup name (worldBoxes world) of
|
|
Nothing -> error ("No such box: " ++ [name])
|
|
Just box -> box
|
|
|
|
invert :: Movement -> Movement
|
|
invert (dy,dx) = (-dy, -dx)
|
|
|
|
midpoint :: Int -> Int -> Rational -> Int
|
|
midpoint lo hi offset = round (offset * fromIntegral (hi-lo+1))
|
|
|
|
addVisited ::
|
|
Char {- ^ name -} ->
|
|
Location {- ^ start -} ->
|
|
Maybe Location {- ^ end -} ->
|
|
Map Location (Int, Char, Maybe Location) ->
|
|
Map Location (Int, Char, Maybe Location)
|
|
addVisited name k v m = Map.insert k (Map.size m, name, v) m
|
|
|
|
nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rational)
|
|
nextLoc world (dy, dx) = go Set.empty
|
|
where
|
|
|
|
-- Step fits within current box, success
|
|
go _ (Location b y x) offset
|
|
| Just box <- Map.lookup b (worldBoxes world)
|
|
, inRange (bounds (boxWalls world box)) (y+dy, x+dx)
|
|
= Just (Location b (y+dy) (x+dx), offset)
|
|
|
|
-- Step takes us off the edge of the box, exit to parent
|
|
go visited (Location b y x) offset
|
|
| Just box <- Map.lookup b (worldBoxes world)
|
|
, Set.notMember b visited
|
|
, Just boxLoc <- boxLocation box
|
|
, let (bh,bw) = boxSize world box
|
|
, let faceSize = abs dy * bw + abs dx * bh
|
|
= go (Set.insert b visited) boxLoc
|
|
$ (offset + fromIntegral (abs dy*x+abs dx*y))
|
|
/ fromIntegral faceSize
|
|
|
|
-- exiting has cycled, exit from next infinity box
|
|
go visited (Location b y x) offset
|
|
| Set.member b visited
|
|
, Just b' <- findInfinity world b
|
|
= go visited (Location b' y x) offset
|
|
|
|
-- infinity boxes exhausted, exit to void
|
|
go _ _ _ = Nothing
|
|
|
|
findInfinity :: World -> Char -> Maybe Char
|
|
findInfinity world b =
|
|
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
|
|
, Infinity i <- [boxType box], i == b]
|
|
|
|
findEpsilon :: World -> Char -> Maybe Char
|
|
findEpsilon world b =
|
|
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
|
|
, Epsilon i _ <- [boxType box], i == b]
|
|
|
|
worldLocations :: World -> Map Location (Char, Box)
|
|
worldLocations world =
|
|
Map.fromList
|
|
[(loc, (n,box))
|
|
| (n, box) <- Map.assocs (worldBoxes world)
|
|
, loc <- maybeToList (boxLocation box)]
|