227 lines
6.9 KiB
Haskell
227 lines
6.9 KiB
Haskell
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
|
|
import Data.Set (Set)
|
|
|
|
type Coord = (Int, Int)
|
|
|
|
data Box = Box {
|
|
boxLocation :: Maybe Location,
|
|
boxType :: BoxType,
|
|
boxColor :: Attr,
|
|
boxBoring :: Bool
|
|
}
|
|
deriving (Show, Read, Eq)
|
|
|
|
boxWalls :: World -> Box -> Array Coord Bool
|
|
boxWalls world box =
|
|
case boxType box of
|
|
Original walls -> walls
|
|
Link c -> boxWalls world (worldBoxes world Map.! c)
|
|
Infinity c -> boxWalls world (worldBoxes world Map.! c)
|
|
Epsilon _ walls -> walls
|
|
|
|
data BoxType
|
|
= Original (Array Coord Bool)
|
|
| Link Char
|
|
| Infinity Char
|
|
| Epsilon Char (Array Coord Bool)
|
|
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,
|
|
worldHeight :: Int,
|
|
worldWidth :: Int
|
|
}
|
|
deriving (Show, Read, Eq)
|
|
|
|
winCondition :: World -> Bool
|
|
winCondition world =
|
|
Set.isSubsetOf (worldButtons world) coverage &&
|
|
Just (worldHome world) == boxLocation (worldBoxes world Map.! worldMe world)
|
|
where
|
|
coverage = Set.fromList $ mapMaybe boxLocation $ Map.elems (worldBoxes world)
|
|
|
|
|
|
boxSize :: World -> Box -> Int
|
|
boxSize world box = yhi-ylo+1
|
|
where
|
|
((ylo,_),(yhi,_)) = bounds (boxWalls world box)
|
|
|
|
move :: World -> (Int,Int) -> World
|
|
move world dir =
|
|
case myLocation world of
|
|
Nothing -> world
|
|
Just loc ->
|
|
case moveBlock world 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 (worldBoxes world Map.! 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 ->
|
|
Map Location (Int, Char, Maybe Location) ->
|
|
Location ->
|
|
Movement ->
|
|
Rational {- ^ offset -} ->
|
|
Maybe (Map Char (Maybe Location))
|
|
|
|
-- moving into 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 _ _
|
|
| Just (n,_,_) <- Map.lookup loc visited
|
|
= Just (Map.fromList [(c,l) | (a,c,l) <- Map.elems visited, a >= n])
|
|
|
|
moveBlock world 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
|
|
Nothing -> Just (Map.fromList ((name, Nothing) : [(c,l) | (_,c,l) <- Map.elems visited]))
|
|
Just (loc', offset') ->
|
|
do guard (not (isWall world loc'))
|
|
moveBlock' world visited loc loc' dir name box Set.empty offset'
|
|
|
|
moveBlock' ::
|
|
World ->
|
|
Map Location (Int, Char, Maybe Location) ->
|
|
Location ->
|
|
Location ->
|
|
Movement ->
|
|
Char ->
|
|
Box ->
|
|
Set Location ->
|
|
Rational {- ^ offset -} ->
|
|
Maybe (Map Char (Maybe Location))
|
|
moveBlock' world visited loc loc' dir name box enters offset =
|
|
msum [moveTo, moveInto, moveToEat]
|
|
where
|
|
moveTo =
|
|
do moveBlock world (addVisited name loc (Just loc') visited) loc' dir 0
|
|
|
|
moveInto =
|
|
do (n,b) <- boxAt world loc'
|
|
(locI, offset') <- enterLoc world n b dir offset
|
|
if Set.member locI enters then
|
|
moveEpsilon
|
|
else
|
|
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
|
|
|
|
moveEpsilon =
|
|
do epsilon <- findEpsilon world (locName loc')
|
|
let eBox = worldBoxes world Map.! epsilon
|
|
(locI, offset') <- enterLoc world epsilon eBox dir offset
|
|
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
|
|
|
|
moveToEat =
|
|
do let dir' = invert dir
|
|
(locE, _) <- enterLoc world name box dir' 0
|
|
(name', box') <- boxAt world loc'
|
|
moveBlock' world (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 go y x = Just
|
|
(Location name' y x,
|
|
fromIntegral(boxSize world box) * 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"
|
|
|
|
boxAt :: World -> Location -> Maybe (Char, Box)
|
|
boxAt world loc =
|
|
listToMaybe [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == Just loc]
|
|
|
|
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
|
|
|
|
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)
|
|
|
|
go visited (Location b y x) offset
|
|
| Just box <- Map.lookup b (worldBoxes world)
|
|
, Set.notMember b visited
|
|
, Just boxLoc <- boxLocation box
|
|
= go (Set.insert b visited) boxLoc
|
|
$ (offset + fromIntegral (abs dy*x+abs dx*y))
|
|
/ fromIntegral (boxSize world box)
|
|
|
|
go visited (Location b y x) offset
|
|
| Set.member b visited
|
|
, Just b' <- findInfinity world b
|
|
= go visited (Location b' y x) offset
|
|
|
|
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]
|