parabox/app/Model.hs

252 lines
8.1 KiB
Haskell
Raw Normal View History

2022-12-02 10:54:31 -08:00
module Model where
2022-12-08 09:34:27 -08:00
import Data.Array.Unboxed
2022-12-02 10:54:31 -08:00
import Data.Map (Map)
import Data.Map qualified as Map
2022-12-08 09:34:27 -08:00
import Graphics.Vty ( Attr )
import Control.Monad ( guard, msum )
import Data.Maybe ( listToMaybe, mapMaybe, maybeToList )
2022-12-02 10:54:31 -08:00
import Data.Set qualified as Set
2022-12-02 20:53:45 -08:00
import Data.Set (Set)
2022-12-08 09:34:27 -08:00
import GHC.Stack (HasCallStack)
2022-12-02 10:54:31 -08:00
type Coord = (Int, Int)
data Box = Box {
boxLocation :: Maybe Location,
2022-12-02 15:28:05 -08:00
boxType :: BoxType,
2022-12-03 13:33:02 -08:00
boxColor :: Attr,
boxBoring :: Bool
2022-12-02 10:54:31 -08:00
}
deriving (Show, Read, Eq)
2022-12-08 09:34:27 -08:00
-- | 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
2022-12-02 15:28:05 -08:00
boxWalls world box =
case boxType box of
2022-12-08 09:34:27 -08:00
Original walls -> walls
Link c -> boxWalls world (boxIx world c)
Infinity c -> boxWalls world (boxIx world c)
2022-12-04 15:59:22 -08:00
Epsilon _ walls -> walls
2022-12-02 15:28:05 -08:00
data BoxType
2022-12-08 09:34:27 -08:00
= Original (UArray Coord Bool) -- ^ plain box
| Link Char -- ^ entrance clone
| Infinity Char -- ^ infinite exit
| Epsilon Char (UArray Coord Bool) -- ^ infinite enter
2022-12-02 15:28:05 -08:00
deriving (Show, Read, Eq)
2022-12-04 15:59:22 -08:00
data Location = Location { locName :: Char, locY :: Int, locX :: Int }
2022-12-02 10:54:31 -08:00
deriving (Read, Show, Ord, Eq)
data World = World {
2022-12-08 09:34:27 -08:00
worldBoxes :: Map Char Box,
worldMe :: Char,
worldButtons :: Set Location,
worldHome :: Location,
worldSize :: (Int, Int)
2022-12-02 10:54:31 -08:00
}
deriving (Show, Read, Eq)
2022-12-02 21:33:44 -08:00
winCondition :: World -> Bool
winCondition world =
Set.isSubsetOf (worldButtons world) coverage &&
2022-12-07 17:31:07 -08:00
Just (worldHome world) == boxLocation (boxIx world (worldMe world))
2022-12-02 21:33:44 -08:00
where
2022-12-07 17:31:07 -08:00
coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world)))
2022-12-02 21:33:44 -08:00
2022-12-02 10:54:31 -08:00
move :: World -> (Int,Int) -> World
move world dir =
case myLocation world of
2022-12-02 10:54:31 -08:00
Nothing -> world
Just loc ->
2022-12-08 09:34:27 -08:00
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
2022-12-07 17:31:07 -08:00
myLocation world = boxLocation (boxIx world (worldMe world))
2022-12-02 10:54:31 -08:00
2022-12-02 15:28:05 -08:00
isWall :: World -> Location -> Bool
isWall world (Location n y x) =
2022-12-02 10:54:31 -08:00
case Map.lookup n (worldBoxes world) of
Nothing -> True
2022-12-02 15:28:05 -08:00
Just box -> boxWalls world box ! (y,x)
2022-12-02 10:54:31 -08:00
type Movement = (Int, Int)
moveBlock ::
World ->
2022-12-08 09:34:27 -08:00
Map Location (Char, Box) ->
Map Location (Int, Char, Maybe Location) ->
2022-12-02 10:54:31 -08:00
Location ->
Movement ->
2022-12-02 18:49:26 -08:00
Rational {- ^ offset -} ->
Maybe (Map Char (Maybe Location))
2022-12-02 10:54:31 -08:00
-- moving into a wall, not possible
2022-12-08 09:34:27 -08:00
moveBlock world _ _ loc _ _
2022-12-02 15:28:05 -08:00
| isWall world loc = Nothing
2022-12-02 10:54:31 -08:00
-- move introduced a loop, trim off the tail and report success
2022-12-08 09:34:27 -08:00
moveBlock _ _ visited loc _ _
| Just (n,_,_) <- Map.lookup loc visited
= Just (Map.fromList [(c,l) | (a,c,l) <- Map.elems visited, a >= n])
2022-12-02 10:54:31 -08:00
2022-12-08 09:34:27 -08:00
moveBlock world locMap visited loc dir offset =
case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == Just loc] of
2022-12-02 10:54:31 -08:00
-- moving an empty space, so we're done
[] -> Just (Map.fromList [(c,l) | (_,c,l) <- Map.elems visited])
2022-12-02 10:54:31 -08:00
-- moving a box
(name,box):_ ->
case nextLoc world dir loc offset of
2022-12-08 09:34:27 -08:00
-- block is exiting into the void; finish the move
Nothing -> Just (Map.fromList ((name, Nothing) : [(c,l) | (_,c,l) <- Map.elems visited]))
2022-12-08 09:34:27 -08:00
Just (loc', offset') ->
do guard (not (isWall world loc'))
2022-12-08 09:34:27 -08:00
moveBlock' world locMap visited loc loc' dir name box Set.empty offset'
2022-12-02 10:54:31 -08:00
2022-12-02 11:48:03 -08:00
moveBlock' ::
World ->
2022-12-08 09:34:27 -08:00
Map Location (Char, Box) ->
Map Location (Int, Char, Maybe Location) ->
Location ->
Location ->
Movement ->
Char ->
2022-12-02 18:49:26 -08:00
Box ->
2022-12-04 15:59:22 -08:00
Set Location ->
2022-12-02 18:49:26 -08:00
Rational {- ^ offset -} ->
Maybe (Map Char (Maybe Location))
2022-12-08 09:34:27 -08:00
moveBlock' world locMap visited loc loc' dir name box enters offset =
2022-12-02 11:48:03 -08:00
msum [moveTo, moveInto, moveToEat]
2022-12-02 10:54:31 -08:00
where
2022-12-02 11:48:03 -08:00
moveTo =
2022-12-08 09:34:27 -08:00
do moveBlock world locMap (addVisited name loc (Just loc') visited) loc' dir 0
2022-12-02 10:54:31 -08:00
2022-12-02 11:48:03 -08:00
moveInto =
2022-12-08 09:34:27 -08:00
do (n,b) <- Map.lookup loc' locMap
2022-12-04 15:59:22 -08:00
(locI, offset') <- enterLoc world n b dir offset
if Set.member locI enters then
2024-12-07 19:17:50 -08:00
do epsilon <- findEpsilon world (locName locI)
moveEpsilon epsilon
2022-12-04 15:59:22 -08:00
else
2022-12-08 09:34:27 -08:00
moveBlock' world locMap visited loc locI dir name box (Set.insert locI enters) offset'
2022-12-04 15:59:22 -08:00
2024-12-07 19:17:50 -08:00
moveEpsilon epsilon =
do let eBox = boxIx world epsilon
(locI, offset') <- enterLoc world epsilon eBox dir offset
2022-12-08 09:34:27 -08:00
moveBlock' world locMap visited loc locI dir name box (Set.insert locI enters) offset'
2022-12-02 11:48:03 -08:00
moveToEat =
2022-12-02 10:54:31 -08:00
do let dir' = invert dir
2022-12-04 15:59:22 -08:00
(locE, _) <- enterLoc world name box dir' 0
2022-12-08 09:34:27 -08:00
(name', box') <- Map.lookup loc' locMap
moveBlock' world locMap (addVisited name loc (Just loc') visited) loc' locE dir' name' box' Set.empty 0
2022-12-02 10:54:31 -08:00
2022-12-04 15:59:22 -08:00
enterLoc :: World -> Char -> Box -> Movement -> Rational -> Maybe (Location, Rational)
2022-12-02 18:49:26 -08:00
enterLoc world name box dir@(dy,dx) offset =
2022-12-04 15:59:22 -08:00
do name' <-
case boxType box of
Link c -> Just c
Original{} -> Just name
Infinity{} -> Nothing
Epsilon {} -> Just name
2022-12-08 09:34:27 -08:00
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
2022-12-04 15:59:22 -08:00
(Location name' y x,
2022-12-08 09:34:27 -08:00
fromIntegral faceSize * offset
2024-05-22 14:16:46 -07:00
- fromIntegral (abs dy *x + abs dx*y))
2022-12-04 15:59:22 -08:00
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
2022-12-02 18:49:26 -08:00
2022-12-04 15:59:22 -08:00
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"
2022-12-02 10:54:31 -08:00
2022-12-08 09:34:27 -08:00
boxIx :: HasCallStack => World -> Char -> Box
boxIx world name =
case Map.lookup name (worldBoxes world) of
Nothing -> error ("No such box: " ++ [name])
Just box -> box
2022-12-07 17:31:07 -08:00
2022-12-02 11:48:03 -08:00
invert :: Movement -> Movement
2022-12-02 10:54:31 -08:00
invert (dy,dx) = (-dy, -dx)
2022-12-02 18:49:26 -08:00
midpoint :: Int -> Int -> Rational -> Int
midpoint lo hi offset = round (offset * fromIntegral (hi-lo+1))
2022-12-02 10:54:31 -08:00
2022-12-02 11:48:03 -08:00
addVisited ::
Char {- ^ name -} ->
2022-12-02 11:48:03 -08:00
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
2022-12-02 10:54:31 -08:00
2022-12-02 18:49:26 -08:00
nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rational)
nextLoc world (dy, dx) = go Set.empty
2022-12-02 10:54:31 -08:00
where
2022-12-02 18:49:26 -08:00
2022-12-08 18:58:07 -08:00
-- Step fits within current box, success
2022-12-02 18:49:26 -08:00
go _ (Location b y x) offset
2022-12-02 10:54:31 -08:00
| Just box <- Map.lookup b (worldBoxes world)
2022-12-02 15:28:05 -08:00
, inRange (bounds (boxWalls world box)) (y+dy, x+dx)
2022-12-02 18:49:26 -08:00
= Just (Location b (y+dy) (x+dx), offset)
2022-12-08 18:58:07 -08:00
-- Step takes us off the edge of the box, exit to parent
2022-12-02 18:49:26 -08:00
go visited (Location b y x) offset
2022-12-02 10:54:31 -08:00
| Just box <- Map.lookup b (worldBoxes world)
, Set.notMember b visited
, Just boxLoc <- boxLocation box
2022-12-08 09:34:27 -08:00
, let (bh,bw) = boxSize world box
, let faceSize = abs dy * bw + abs dx * bh
= go (Set.insert b visited) boxLoc
2022-12-02 18:49:26 -08:00
$ (offset + fromIntegral (abs dy*x+abs dx*y))
2022-12-08 09:34:27 -08:00
/ fromIntegral faceSize
2022-12-02 10:54:31 -08:00
2022-12-08 18:58:07 -08:00
-- exiting has cycled, exit from next infinity box
2022-12-04 15:59:22 -08:00
go visited (Location b y x) offset
| Set.member b visited
, Just b' <- findInfinity world b
= go visited (Location b' y x) offset
2022-12-08 18:58:07 -08:00
-- infinity boxes exhausted, exit to void
2022-12-02 18:49:26 -08:00
go _ _ _ = Nothing
2022-12-02 10:54:31 -08:00
2022-12-04 15:59:22 -08:00
findInfinity :: World -> Char -> Maybe Char
findInfinity world b =
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
, Infinity i <- [boxType box], i == b]
2022-12-04 15:59:22 -08:00
findEpsilon :: World -> Char -> Maybe Char
findEpsilon world b =
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
, Epsilon i _ <- [boxType box], i == b]
2022-12-08 09:34:27 -08:00
worldLocations :: World -> Map Location (Char, Box)
worldLocations world =
Map.fromList
[(loc, (n,box))
| (n, box) <- Map.assocs (worldBoxes world)
, loc <- maybeToList (boxLocation box)]