diff --git a/app/Main.hs b/app/Main.hs index 4e6d195..0dbdbf5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,6 +3,8 @@ module Main (main) where import Control.Exception ( bracket ) import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty qualified as NonEmpty +import Data.Char (toUpper) +import Data.List (intersperse) import Data.Map (Map) import Data.Map qualified as Map import Graphics.Vty @@ -13,6 +15,7 @@ import System.FilePath ( (), takeBaseName ) import Model import Rendering ( render ) import Parser (parse) +import BigFont data Game = Game { gameFlat :: Bool, @@ -98,16 +101,19 @@ renderMenu (w,h) before after = where menu = case Map.minViewWithKey after of - Nothing -> string defAttr "empty menu" + Nothing -> bigString defAttr "empty menu" Just ((k,_),after') -> - let len1 = (h-1)`div`2 in - pad 0 (len1 - Map.size before) 0 0 (vertCat - [ string defAttr x + let len1 = (h-1)`div`2 `div` 6 in + pad 0 (max 0 (6 * (len1 - Map.size before))) 0 0 $ + vertCat $ + intersperse (char defAttr ' ') $ + [ bigString defAttr x | x <- drop (Map.size before - len1) (Map.keys before) - ]) <-> - string (defAttr `withBackColor` cyan `withForeColor` white) k - <-> - vertCat - [ string defAttr x + ] ++ + [bigString (defAttr `withBackColor` cyan `withForeColor` white) k] ++ + [ bigString defAttr x | x <- drop (Map.size after' - h`div`2) (Map.keys after') ] + +bigString :: Attr -> String -> Image +bigString a = vertCat . map (string a) . bigText . map toUpper diff --git a/app/Model.hs b/app/Model.hs index 9e8afab..65fcc61 100644 --- a/app/Model.hs +++ b/app/Model.hs @@ -41,7 +41,9 @@ data World = World { worldBoxes :: Map Char Box, worldMe :: Char, worldButtons :: Set Location, - worldHome :: Location + worldHome :: Location, + worldHeight :: Int, + worldWidth :: Int } deriving (Show, Read, Eq) diff --git a/app/Parser.hs b/app/Parser.hs index 715cc67..fb1044c 100644 --- a/app/Parser.hs +++ b/app/Parser.hs @@ -6,70 +6,109 @@ import Graphics.Vty.Attributes import Data.Array (Array, listArray) import Data.Map qualified as Map import Data.Set qualified as Set +import Text.ParserCombinators.ReadP hiding (many) +import Control.Applicative +import Control.Monad parse :: String -> World -parse str = either error id $ - case lines str of - x:xs -> - do h <- parseHeader x - bs <- parseBlocks xs - let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs] - pure $ World +parse str = + case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of + [] -> error "world parsing failed" + (((p,h,w),bs),_):_ -> + do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs] + World (Map.fromList [ (n, b { boxLocation = head (m Map.! n)}) | (n,b,_) <- bs ]) - h + p (Set.fromList (Map.findWithDefault [] '-' m)) (head (m Map.! '=')) - [] -> Left "empty input" + h w + +parseHeader :: ReadP (Char,Int,Int) +parseHeader = + do "player" <- token + [p] <- token + h <- option 81 + do "height" <- token + integer + w <- option (81*2) + do "width" <- token + integer + pure (p,h,w) -parseHeader :: String -> Either String Char -parseHeader (words -> ["player", [p]]) = Right p -parseHeader _ = Left "bad header" +integer :: ReadP Int +integer = readS_to_P reads -parseBlocks :: [String] -> Either String [(Char, Box, [(Char, Location)])] -parseBlocks [] = Right [] -parseBlocks (x:xs) = - case words x of - ["block", [name], color, boring] -> - do color_ <- parseColor color - let (xs1,xs2) = splitWalls xs - let locs = findLocs name xs1 - let b = Box undefined (Original (walls xs1)) color_ (boring == "boring") - bs <- parseBlocks xs2 - pure ((name, b, locs):bs) - ["link", [name], [target], color] -> - do color_ <- parseColor color - bs <- parseBlocks xs - pure ((name, Box undefined (Link target) color_ True, []):bs) - ["infinity", [name], [target], color] -> - do color_ <- parseColor color - bs <- parseBlocks xs - pure ((name, Box undefined (Infinity target) color_ True,[]):bs) - ["epsilon", [name], [target], color] -> - do color_ <- parseColor color - let (xs1,xs2) = splitWalls xs - let locs = findLocs name xs1 - let b = Box undefined (Epsilon target (walls xs1)) color_ False - bs <- parseBlocks xs2 - pure ((name, b, locs):bs) - _ -> Left "bad block" +parseBoring :: ReadP Bool +parseBoring = + do t <- token + case t of + "boring" -> pure True + "interesting" -> pure False + _ -> empty -splitWalls (x:xs) = - case splitAt (length x - 1) xs of - (a,b) -> (x:a, b) +parseBlock :: ReadP (Char, Box, [(Char, Location)]) +parseBlock = + do cmd <- token + case cmd of + "block" -> + do [name] <- token + color <- parseColor + boring <- parseBoring + skipMany (satisfy (' '==)) + _ <- char '\n' + xs1 <- parseWalls + let locs = findLocs name xs1 + let b = Box undefined (Original (walls xs1)) color boring + pure (name, b, locs) + "link" -> + do [name] <- token + [target] <- token + color <- parseColor + _ <- char '\n' + pure (name, Box undefined (Link target) color True, []) + "infinity" -> + do [name] <- token + [target] <- token + color <- parseColor + _ <- char '\n' + pure (name, Box undefined (Infinity target) color True,[]) + "epsilon" -> + do [name] <- token + [target] <- token + color <- parseColor + skipMany (satisfy (' '==)) + _ <- char '\n' + xs1 <- parseWalls + let locs = findLocs name xs1 + let b = Box undefined (Epsilon target (walls xs1)) color False + pure (name, b, locs) + _ -> empty -parseColor :: String -> Either String Attr -parseColor "white" = Right (withForeColor defAttr white) -parseColor "cyan" = Right (withForeColor defAttr cyan) -parseColor "blue" = Right (withForeColor defAttr blue) -parseColor "red" = Right (withForeColor defAttr red) -parseColor "yellow" = Right (withForeColor defAttr yellow) -parseColor "magenta" = Right (withForeColor defAttr magenta) -parseColor "black" = Right (withForeColor defAttr black) -parseColor "green" = Right (withForeColor defAttr green) -parseColor x = Left ("bad color " ++ x) +parseWalls :: ReadP [String] +parseWalls = + do row0 <- munch1 ('\n' /=) <* char '\n' + rows <- replicateM (length row0 - 1) (munch1 ('\n' /=) <* char '\n') + pure (row0:rows) + +token :: ReadP String +token = readS_to_P lex + +parseColor :: ReadP Attr +parseColor = + do t <- token + case t of + "white" -> pure (withForeColor defAttr white) + "cyan" -> pure (withForeColor defAttr cyan) + "blue" -> pure (withForeColor defAttr blue) + "red" -> pure (withForeColor defAttr red) + "yellow" -> pure (withForeColor defAttr yellow) + "magenta" -> pure (withForeColor defAttr magenta) + "black" -> pure (withForeColor defAttr black) + "green" -> pure (withForeColor defAttr green) + _ -> empty walls :: [String] -> Array Coord Bool walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows)) diff --git a/app/Rendering.hs b/app/Rendering.hs index b8c5069..7f0eba1 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -116,7 +116,7 @@ renderFlat locMap world = ] where borderAttr = defAttr `withForeColor` white `withBackColor` black - offset = max 0 ( (2*(81+2*border)+2 - imageWidth baseImage) `div` 2) + offset = max 0 ( (worldWidth world + 2*(2*border)+2 - imageWidth baseImage) `div` 2) baseImage = pad 2 1 2 1 $ horizCat $ @@ -127,11 +127,10 @@ renderFlat locMap world = drawNestedWorld :: Map Location Char -> World -> Image drawNestedWorld locMap world = - -- (3*81) + 81 + (3*81) - cropTop (81 + 2*border) $ - cropLeft (2*(81 + 2*border)) $ - cropBottom (2*81 + border) $ - cropRight (2*(2*81 + border)) $ + cropTop (h + 2*border) $ + cropLeft (w + 4*border) $ + cropBottom (2*h + border) $ + cropRight (2*(w + border)) $ vertCat $ intersperse (char defAttr ' ') [ @@ -139,15 +138,17 @@ drawNestedWorld locMap world = intersperse (char defAttr ' ') [ case stackedLoc world locMap (Location name1 y_ x_) of - Nothing -> unit (withForeColor defAttr black) 81 162 '?' + Nothing -> unit (withForeColor defAttr black) h w '?' Just (Location n y x) -> let box = worldBoxes world Map.! n in - renderCell world locMap n box y x 81 (81*2) + renderCell world locMap n box y x h w | x_ <- [x1-1 .. x1+1] ] | y_ <- [y1-1 .. y1+1] ] where + h = worldHeight world + w = worldWidth world -- name1 is the box the player is standing in Location name0 _ _ = myLocation world Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0) diff --git a/levels/center8.txt b/levels/center8.txt index e08fc31..6d1d724 100644 --- a/levels/center8.txt +++ b/levels/center8.txt @@ -1,14 +1,10 @@ player p block t white boring -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓t▓a▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓▓▓▓▓ +▓▓▓▓▓ +▓t▓a▓ +▓▓▓▓▓ +▓▓▓▓▓ block a white interesting ▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓▓▓▓▓ @@ -22,14 +18,14 @@ block a white interesting block g green interesting x ▓ ▓▓▓ - - - + + + block x yellow boring ▓ block p magenta boring -▓▓▓▓▓▓ -▓ ▓▓ ▓ -▓▓▓▓▓▓ -▓▓▓▓▓▓ -▓▓▓▓▓▓ +▓▓▓▓▓ +▓ ▓ ▓ +▓▓▓▓▓ +▓▓▓▓▓ +▓▓▓▓▓ diff --git a/levels/eat11.txt b/levels/eat11.txt index 6ed1ab8..31fc751 100644 --- a/levels/eat11.txt +++ b/levels/eat11.txt @@ -1,4 +1,4 @@ -player p +player p height 75 width 150 block t red boring ▓▓▓▓▓ ▓▓▓▓▓ @@ -6,15 +6,11 @@ block t red boring ▓▓▓▓▓ ▓▓▓▓▓ block r red interesting -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓ ▓▓ -▓▓ p y ▓▓ -▓▓ ▓▓ -▓▓ b g ▓▓ -▓▓= -▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ + + p y + + b g += - block p magenta boring ▓▓▓▓▓ ▓ ▓ ▓ diff --git a/levels/infiniteExit15.txt b/levels/infiniteExit15.txt index c90928a..35c67d5 100644 --- a/levels/infiniteExit15.txt +++ b/levels/infiniteExit15.txt @@ -1,14 +1,10 @@ player m block t cyan boring -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓t▓a▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓▓▓▓▓ +▓▓▓▓▓ +▓t▓a▓ +▓▓▓▓▓ +▓▓▓▓▓ block a cyan interesting ▓▓▓G▓▓▓▓▓ ▓▓▓▓ @@ -20,35 +16,19 @@ block a cyan interesting ▓▓▓▓ ▓▓▓▓▓▓▓▓▓ block m magenta boring -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓ ▓▓▓ ▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ -▓▓▓▓▓▓▓▓▓ +▓▓▓▓▓ +▓ ▓ ▓ +▓▓▓▓▓ +▓▓▓▓▓ +▓▓▓▓▓ block g green interesting - - - - - - - - - + + + block p red interesting - - - - - - - - - + + + link G g green link P p red infinity Γ g green diff --git a/parabox.cabal b/parabox.cabal index 01ceaa7..5084f74 100644 --- a/parabox.cabal +++ b/parabox.cabal @@ -19,7 +19,7 @@ common warnings executable parabox import: warnings main-is: Main.hs - other-modules: Rendering, Model, Parser + other-modules: Rendering, Model, Parser, BigFont -- other-modules: default-extensions: ImportQualifiedPost, BlockArguments, LambdaCase