From 2dbf578d33eedea3e632a02a4112d383806e4d0a Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Thu, 8 Dec 2022 09:34:27 -0800 Subject: [PATCH] cleaner model --- app/Model.hs | 109 ++++++++++++++++++++++++++------------------ app/Parser.hs | 6 +-- app/Rendering.hs | 37 ++++++++------- levels/player18.txt | 64 ++++++++------------------ 4 files changed, 103 insertions(+), 113 deletions(-) diff --git a/app/Model.hs b/app/Model.hs index e47e76a..09e8c21 100644 --- a/app/Model.hs +++ b/app/Model.hs @@ -1,13 +1,14 @@ module Model where -import Data.Array +import Data.Array.Unboxed import Data.Map (Map) import Data.Map qualified as Map -import Graphics.Vty -import Control.Monad -import Data.Maybe +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) @@ -19,31 +20,37 @@ data Box = Box { } deriving (Show, Read, Eq) -boxWalls :: World -> Box -> Array Coord Bool +-- | 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) + Original walls -> walls + Link c -> boxWalls world (boxIx world c) + Infinity c -> boxWalls world (boxIx world c) Epsilon _ walls -> walls data BoxType - = Original (Array Coord Bool) - | Link Char - | Infinity Char - | Epsilon Char (Array Coord Bool) + = 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, - worldHeight :: Int, - worldWidth :: Int + worldBoxes :: Map Char Box, + worldMe :: Char, + worldButtons :: Set Location, + worldHome :: Location, + worldSize :: (Int, Int) } deriving (Show, Read, Eq) @@ -54,18 +61,13 @@ winCondition 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 + 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 @@ -84,6 +86,7 @@ type Movement = (Int, Int) moveBlock :: World -> + Map Location (Char, Box) -> Map Location (Int, Char, Maybe Location) -> Location -> Movement -> @@ -91,15 +94,15 @@ moveBlock :: Maybe (Map Char (Maybe Location)) -- moving into a wall, not possible -moveBlock world _ loc _ _ +moveBlock world _ _ loc _ _ | isWall world loc = Nothing -- move introduced a loop, trim off the tail and report success -moveBlock _ visited loc _ _ +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 = +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]) @@ -107,13 +110,16 @@ moveBlock world visited loc dir offset = -- 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 visited loc loc' dir name box Set.empty offset' + 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 -> @@ -123,31 +129,31 @@ moveBlock' :: Set Location -> Rational {- ^ offset -} -> Maybe (Map Char (Maybe Location)) -moveBlock' world visited loc loc' dir name box enters offset = +moveBlock' world locMap 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 + do moveBlock world locMap (addVisited name loc (Just loc') visited) loc' dir 0 moveInto = - do (n,b) <- boxAt world loc' + do (n,b) <- Map.lookup loc' locMap (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' + moveBlock' world locMap visited loc locI dir name box (Set.insert locI enters) offset' moveEpsilon = do epsilon <- findEpsilon world (locName loc') let eBox = boxIx world epsilon (locI, offset') <- enterLoc world epsilon eBox dir offset - moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset' + moveBlock' world locMap 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 + (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 = @@ -158,9 +164,14 @@ enterLoc world name box dir@(dy,dx) offset = Infinity{} -> Nothing Epsilon {} -> Just name - let go y x = Just + 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(boxSize world box) * offset + fromIntegral faceSize * offset - fromIntegral ((abs dy *x + abs dx*y))) ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) @@ -172,12 +183,11 @@ enterLoc world name box dir@(dy,dx) offset = ( 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] - -boxIx :: World -> Char -> Box -boxIx world name = worldBoxes world Map.! name +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) @@ -206,9 +216,11 @@ nextLoc world (dy, dx) = go Set.empty | 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 (boxSize world box) + / fromIntegral faceSize go visited (Location b y x) offset | Set.member b visited @@ -226,3 +238,10 @@ 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)] diff --git a/app/Parser.hs b/app/Parser.hs index e0db775..90019a4 100644 --- a/app/Parser.hs +++ b/app/Parser.hs @@ -2,7 +2,7 @@ module Parser (parse) where import Control.Applicative import Control.Monad -import Data.Array (Array, listArray) +import Data.Array.Unboxed (UArray, listArray) import Data.Map qualified as Map import Data.Set qualified as Set import Graphics.Vty.Attributes @@ -21,7 +21,7 @@ parse str = p (Set.fromList (Map.findWithDefault [] '-' m)) (head (m Map.! '=')) - h w + (h, w) parseHeader :: ReadP (Char,Int,Int) parseHeader = @@ -107,7 +107,7 @@ parseColor = "green" -> pure (withForeColor defAttr green) _ -> empty -walls :: [String] -> Array Coord Bool +walls :: [String] -> UArray Coord Bool walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows)) where width = length (head rows) diff --git a/app/Rendering.hs b/app/Rendering.hs index ad03620..1dd0a80 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -1,6 +1,6 @@ module Rendering where -import Data.Array +import Data.Array.Unboxed import Data.Maybe import Data.Map (Map) import Data.Map qualified as Map @@ -8,7 +8,7 @@ import Data.Set qualified as Set import Data.List (intersperse, group) import Graphics.Vty -import BigFont +import BigFont ( bigText ) import Model border :: Int @@ -39,14 +39,13 @@ home a h w = vertCat $ replicate (h-2) (string a ('║' : replicate (w-2) '░' ++ "║")) ++ [string a ('╚' : replicate (w-2) '═' ++ "╝")] -renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Int -> Image +renderCell :: World -> Map Location (Char, Box) -> Char -> Box -> Int -> Int -> Int -> Int -> Image renderCell world locMap name box y x h w | boxWalls world box ! (y,x) = unit (boxColor box) h w wallChar - | Just n <- Map.lookup (Location name' y x) locMap - , let box' = boxIx world n - = if h < boxSize world box' + | Just (n, box') <- Map.lookup (Location name' y x) locMap + = if h < fst (boxSize world box') then unit (boxColor box') h w n else renderBox world locMap box' n h w @@ -79,7 +78,7 @@ contentName world name box = Link c -> c Infinity c -> contentName world c (boxIx world c) -renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image +renderBox :: World -> Map Location (Char, Box) -> Box -> Char -> Int -> Int -> Image renderBox world locMap box name boxh boxw = vertCat [ horizCat [ @@ -112,17 +111,16 @@ render flat world = picForLayers $ (if flat then renderFlat locMap world else []) ++ [drawNestedWorld locMap world] where - locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world) - , loc <- maybeToList (boxLocation box)] + locMap = worldLocations world -renderFlat :: Map Location Char -> World -> [Image] +renderFlat :: Map Location (Char, Box) -> World -> [Image] renderFlat locMap world = [ pad offset 0 0 0 baseImage , pad offset 0 0 0 $ drawBox borderAttr (imageHeight baseImage) (imageWidth baseImage) ] where borderAttr = defAttr `withForeColor` white `withBackColor` black - offset = max 0 ( (worldWidth world + 2*(2*border)+2 - imageWidth baseImage) `div` 2) + offset = max 0 ( (snd (worldSize world) + 2*(2*border)+2 - imageWidth baseImage) `div` 2) baseImage = pad 2 1 2 1 $ horizCat $ @@ -131,7 +129,7 @@ renderFlat locMap world = | (n,b) <- Map.assocs (worldBoxes world) , not (boxBoring b)] -drawNestedWorld :: Map Location Char -> World -> Image +drawNestedWorld :: Map Location (Char, Box) -> World -> Image drawNestedWorld locMap world = cropTop (h + 2*border) $ cropLeft (w + 4*border) $ @@ -163,8 +161,7 @@ drawNestedWorld locMap world = ] where infinityImage = makeInfinity h w - h = worldHeight world - w = worldWidth world + (h, w) = worldSize world makeInfinity :: Int -> Int -> Image makeInfinity h w = result @@ -186,7 +183,9 @@ makeInfinity h w = result result = foldr mkCol row colGaps mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest -stackedLoc :: World -> Map Location Char -> Location -> Maybe Location +-- | Covert a location on a block that might overflow into a location +-- following block exits. +stackedLoc :: World -> Map Location (Char, Box) -> Location -> Maybe Location stackedLoc world locMap = go Set.empty where go visited loc@(Location b y x) @@ -212,7 +211,7 @@ overflow (lo,hi) x | otherwise = 0 fixup :: World -> - Map Location Char -> + Map Location (Char, Box) -> Int -> Int -> Int -> @@ -222,12 +221,12 @@ fixup :: World -> fixup world locMap dy dx py px loc = case Map.lookup loc locMap of Nothing -> loc - Just name -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px) + Just (name, box) -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px) where - ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (boxIx world name)) + ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) fixup1 :: Int -> Int -> Int -> Int -> Int -fixup1 _ _ 0 i = i +fixup1 lo hi 0 i = min hi (max lo i) fixup1 _ hi (-1) _ = hi fixup1 lo _ 1 _ = lo fixup1 _ _ _ _ = error "fixup1: bad delta" diff --git a/levels/player18.txt b/levels/player18.txt index 5f09321..e2bdf96 100644 --- a/levels/player18.txt +++ b/levels/player18.txt @@ -1,51 +1,23 @@ -player u +player u height 98 width 196 block c yellow interesting -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓ ▓▓ -▓▓ c 1 ▓▓ -▓▓ u -▓▓ 2 3 ▓▓ -▓▓ ▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓▓▓▓▓▓▓ +▓ ▓ +▓ c 1 ▓ +▓ u +▓ 2 3 ▓ +▓ ▓ +▓▓▓▓▓▓▓ block u magenta interesting -▓▓▓▓ ▓▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓ -▓▓ -▓▓ ▓▓ -▓▓= ▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓▓▓ ▓▓▓ +▓▓▓ ▓▓▓ +▓▓▓ ▓▓▓ +▓ -▓ +▓ ▓ +▓= ▓ +▓▓▓▓▓▓▓ block 1 blue boring -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓ block 2 blue boring -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓ ▓▓▓▓ -▓▓▓▓▓ ▓▓▓ -▓▓▓▓ ▓▓▓▓ -▓▓▓ ▓▓▓▓▓ -▓▓▓ ▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓ block 3 blue boring -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓ ▓▓▓ -▓▓▓▓▓ ▓▓▓ -▓▓▓▓ ▓▓▓ -▓▓▓▓▓ ▓▓▓ -▓▓▓ ▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓