From a67bbea3cb88534475cad79310519216d0d92b46 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 7 Dec 2022 17:31:07 -0800 Subject: [PATCH] big ? --- app/BigFont.hs | 6 +++ app/Model.hs | 16 +++--- app/Parser.hs | 27 +++++----- app/Rendering.hs | 125 +++++++++++++++++++++++++++----------------- levels/player19.txt | 18 +++---- 5 files changed, 111 insertions(+), 81 deletions(-) diff --git a/app/BigFont.hs b/app/BigFont.hs index e13a811..44a6326 100644 --- a/app/BigFont.hs +++ b/app/BigFont.hs @@ -19,6 +19,12 @@ letters = Map.fromList ," " ," " ," "]), + ('?', + ["██████ " + ," ██" + ," ▄███ " + ," ▀▀ " + ," ██ "]), ('A', [" █████ " ,"██ ██" diff --git a/app/Model.hs b/app/Model.hs index 42358eb..e47e76a 100644 --- a/app/Model.hs +++ b/app/Model.hs @@ -23,8 +23,8 @@ 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) + Link c -> boxWalls world (boxIx world c) + Infinity c -> boxWalls world (boxIx world c) Epsilon _ walls -> walls data BoxType @@ -50,9 +50,9 @@ data World = World { winCondition :: World -> Bool winCondition world = Set.isSubsetOf (worldButtons world) coverage && - Just (worldHome world) == boxLocation (worldBoxes world Map.! worldMe world) + Just (worldHome world) == boxLocation (boxIx world (worldMe world)) where - coverage = Set.fromList $ mapMaybe boxLocation $ Map.elems (worldBoxes world) + coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world))) boxSize :: World -> Box -> Int @@ -72,8 +72,7 @@ move world dir = 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) +myLocation world = boxLocation (boxIx world (worldMe world)) isWall :: World -> Location -> Bool isWall world (Location n y x) = @@ -140,7 +139,7 @@ moveBlock' world visited loc loc' dir name box enters offset = moveEpsilon = do epsilon <- findEpsilon world (locName loc') - let eBox = worldBoxes world Map.! epsilon + 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' @@ -177,6 +176,9 @@ 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 + invert :: Movement -> Movement invert (dy,dx) = (-dy, -dx) diff --git a/app/Parser.hs b/app/Parser.hs index f9c0d94..e0db775 100644 --- a/app/Parser.hs +++ b/app/Parser.hs @@ -1,14 +1,14 @@ -{-# Language ViewPatterns #-} -module Parser where +module Parser (parse) where -import Model -import Graphics.Vty.Attributes +import Control.Applicative +import Control.Monad import Data.Array (Array, listArray) import Data.Map qualified as Map import Data.Set qualified as Set +import Graphics.Vty.Attributes import Text.ParserCombinators.ReadP hiding (many) -import Control.Applicative -import Control.Monad + +import Model parse :: String -> World parse str = @@ -17,10 +17,7 @@ parse str = (((p,h,w),bs),_):_ -> do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs] World - (Map.fromList [ - (n, b { boxLocation = fmap head (Map.lookup n m)}) - | (n,b,_) <- bs - ]) + (Map.fromList [(n, b { boxLocation = head <$> Map.lookup n m }) | (n,b,_) <- bs]) p (Set.fromList (Map.findWithDefault [] '-' m)) (head (m Map.! '=')) @@ -45,9 +42,9 @@ parseBoring :: ReadP Bool parseBoring = do t <- token case t of - "boring" -> pure True + "boring" -> pure True "interesting" -> pure False - _ -> empty + _ -> empty parseBlock :: ReadP (Char, Box, [(Char, Location)]) parseBlock = @@ -68,13 +65,13 @@ parseBlock = [target] <- token color <- parseColor _ <- char '\n' - pure (name, Box undefined (Link target) color True, []) + pure (name, Box Nothing (Link target) color True, []) "infinity" -> do [name] <- token [target] <- token color <- parseColor _ <- char '\n' - pure (name, Box undefined (Infinity target) color True,[]) + pure (name, Box Nothing (Infinity target) color True,[]) "epsilon" -> do [name] <- token [target] <- token @@ -83,7 +80,7 @@ parseBlock = _ <- char '\n' xs1 <- parseWalls let locs = findLocs name xs1 - let b = Box undefined (Epsilon target (walls xs1)) color False + let b = Box Nothing (Epsilon target (walls xs1)) color False pure (name, b, locs) _ -> empty diff --git a/app/Rendering.hs b/app/Rendering.hs index 0703be1..ad03620 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -7,6 +7,8 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Data.List (intersperse, group) import Graphics.Vty + +import BigFont import Model border :: Int @@ -17,23 +19,20 @@ unit a h w c = vertCat (replicate h (string a (replicate w c))) drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image -drawBox a 2 1 = string a "[]" -drawBox a w 1 = string a ("[" ++ replicate (w-2) '-' ++ "]") -drawBox a w h = vertCat $ +drawBox a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]") +drawBox a h w = vertCat $ string a ('┌' : replicate (w-2) '─' ++ "┐") : replicate (h-2) (string a ('│' : replicate (w-2) ' ' ++ "│")) ++ [string a ('└' : replicate (w-2) '─' ++ "┘")] button :: Attr -> Int -> Int -> Image -button a 1 2 = string a "[]" -button a 1 n = string a ("[" ++ replicate (n-2) '-' ++ "]") +button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]") button a h w = vertCat $ string a ('┌' : replicate (w-2) '─' ++ "┐") : replicate (h-2) (string a ('│' : replicate (w-2) '░' ++ "│")) ++ [string a ('└' : replicate (w-2) '─' ++ "┘")] home :: Attr -> Int -> Int -> Image -home a 1 2 = string a "<>" home a 1 w = string a ("<" ++ replicate (w-2) '=' ++ ">") home a h w = vertCat $ string a ('╔' : replicate (w-2) '═' ++ "╗") : @@ -41,53 +40,55 @@ home a h w = vertCat $ [string a ('╚' : replicate (w-2) '═' ++ "╝")] renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Int -> Image -renderCell world locMap name box y x h w = - if boxWalls world box ! (y,x) then unit (boxColor box) h w wallChar - else case Map.lookup (Location name' y x) locMap of - Just n -> - let box' = worldBoxes world Map.! n - in if h < boxSize world box' - then unit (boxColor box') h w n - else renderBox world locMap box' n - h w - Nothing - | Set.member loc (worldButtons world) -> button (boxColor box) h w - | loc == worldHome world -> home (boxColor box) h w - | otherwise -> unit (boxColor box) h w floorChar +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' + then unit (boxColor box') h w n + else renderBox world locMap box' n h w + + | Set.member loc (worldButtons world) = button (boxColor box) h w + + | loc == worldHome world = home (boxColor box) h w + + | otherwise = unit (boxColor box) h w floorChar where loc = Location name' y x name' = contentName world name box wallChar = case boxType box of - Original{} -> '▓' - Link{} -> '▒' + Original {} -> '▓' + Link {} -> '▒' Infinity {} -> '▓' - Epsilon {} -> '▓' + Epsilon {} -> '▓' floorChar = case boxType box of - Original{} -> '░' - Link{} -> '·' + Original {} -> '░' + Link {} -> '·' Infinity {} -> '∞' - Epsilon {} -> 'ε' + Epsilon {} -> 'ε' contentName :: World -> Char -> Box -> Char contentName world name box = case boxType box of Original{} -> name - Link c -> c - Infinity c -> contentName world c (worldBoxes world Map.! c) - Epsilon{} -> name + Epsilon{} -> name + Link c -> c + Infinity c -> contentName world c (boxIx world c) renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image renderBox world locMap box name boxh boxw = vertCat [ horizCat [ renderCell world locMap name box y x cellh cellw - | (x,cellw) <- zip [xlo .. xhi] (divisions boxWidth boxw) - ] - | (y,cellh) <- zip [ylo .. yhi] (divisions boxHeight boxh) - ] + | (x,cellw) <- zip [xlo .. xhi] xdivs ] + | (y,cellh) <- zip [ylo .. yhi] ydivs ] where + ydivs = divisions boxHeight boxh + xdivs = divisions boxWidth boxw ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) boxWidth = xhi - xlo + 1 boxHeight = yhi - ylo + 1 @@ -105,15 +106,19 @@ render flat world = picForLayers $ string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║ ██║" <-> string defAttr " ╚══╝╚══╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═══╝╚══════╝╚═╝ ╚═╝" | winCondition world ] ++ + [ pad 94 7 0 0 $ + vertCat (map (string defAttr) (bigText "VOIDED")) + | isNothing (boxLocation (boxIx world (worldMe world))) ] ++ (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 = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world) + , loc <- maybeToList (boxLocation box)] renderFlat :: Map Location Char -> World -> [Image] renderFlat locMap world = [ pad offset 0 0 0 baseImage - , pad offset 0 0 0 $ drawBox borderAttr (imageWidth baseImage) (imageHeight baseImage) + , pad offset 0 0 0 $ drawBox borderAttr (imageHeight baseImage) (imageWidth baseImage) ] where borderAttr = defAttr `withForeColor` white `withBackColor` black @@ -140,28 +145,47 @@ drawNestedWorld locMap world = [ case myLocation world of Nothing - | dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! worldMe world) (worldMe world) h w + | dx==0 && dy==0 -> renderBox world locMap (boxIx world (worldMe world)) (worldMe world) h w | otherwise -> infinityImage Just (Location name0 _ _) -> - case boxLocation (worldBoxes world Map.! name0) of + case boxLocation (boxIx world name0) of Nothing - | dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! name0) name0 h w + | dx==0 && dy==0 -> renderBox world locMap (boxIx world name0) name0 h w | otherwise -> infinityImage Just (Location name1 y1 x1) -> case stackedLoc world locMap (Location name1 (y1+dy) (x1+dx)) of Nothing -> infinityImage Just (Location n y x) -> - let box = worldBoxes world Map.! n in - renderCell world locMap n box y x h w + renderCell world locMap n (boxIx world n) y x h w | dx <- [-1 .. 1] ] | dy <- [-1 .. 1] ] where - infinityImage = unit (withForeColor defAttr black) h w '?' + infinityImage = makeInfinity h w h = worldHeight world w = worldWidth world +makeInfinity :: Int -> Int -> Image +makeInfinity h w = result + where + attr = defAttr `withForeColor` black + single = vertCat (map (string attr) (bigText "?")) + + rowN = (w+1) `div` (imageWidth single + 1) + rowTotalGap = w - rowN * imageWidth single + rowGaps = divisions (rowN-1) rowTotalGap + + row = foldr mkRow single rowGaps + mkRow gap rest = single <|> charFill attr ' ' gap 1 <|> rest + + colN = (h+1) `div` (imageHeight single + 1) + colTotalGap = h - colN * imageHeight single + colGaps = divisions (colN-1) colTotalGap + + result = foldr mkCol row colGaps + mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest + stackedLoc :: World -> Map Location Char -> Location -> Maybe Location stackedLoc world locMap = go Set.empty where @@ -187,20 +211,20 @@ overflow (lo,hi) x | x > hi = x - hi | otherwise = 0 -fixup :: World -> - Map Location Char -> - Int -> - Int -> - Int -> - Int -> - Location -> +fixup :: World -> + Map Location Char -> + Int -> + Int -> + Int -> + Int -> + Location -> Location 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) where - ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (worldBoxes world Map.! name)) + ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (boxIx world name)) fixup1 :: Int -> Int -> Int -> Int -> Int fixup1 _ _ 0 i = i @@ -208,7 +232,10 @@ fixup1 _ hi (-1) _ = hi fixup1 lo _ 1 _ = lo fixup1 _ _ _ _ = error "fixup1: bad delta" -divisions :: Int -> Int -> [Int] +divisions :: + Int {- ^ result length -} -> + Int {- ^ result sum -} -> + [Int] divisions divs size = map length $ group [ round ( diff --git a/levels/player19.txt b/levels/player19.txt index 19457b0..89963ef 100644 --- a/levels/player19.txt +++ b/levels/player19.txt @@ -1,16 +1,14 @@ -player p +player p height 80 width 160 block p magenta interesting - - - p ▓ - - 1 2 - -c + + ▓ ▓ + p + 1 2 +c block c green interesting ▓▓▓ - =▓ -▓▓▓ +▓=▓ +▓ ▓ block 1 blue boring ▓ block 2 blue boring