glguy/parabox
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

configurable sizes

Browse Source
This commit is contained in:
Eric Mertens 2022-12-07 10:11:06 -08:00
parent 2912fb9488
commit babd42f838
8 changed files with 154 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
app/Main.hs
View File

@ -3,6 +3,8 @@ module Main (main) where
import Control.Exception ( bracket ) import Control.Exception ( bracket )
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import Data.List.NonEmpty qualified as NonEmpty import Data.List.NonEmpty qualified as NonEmpty
import Data.Char (toUpper)
import Data.List (intersperse)
import Data.Map (Map) import Data.Map (Map)
import Data.Map qualified as Map import Data.Map qualified as Map
import Graphics.Vty import Graphics.Vty
@ -13,6 +15,7 @@ import System.FilePath ( (</>), takeBaseName )
import Model import Model
import Rendering ( render ) import Rendering ( render )
import Parser (parse) import Parser (parse)
import BigFont
data Game = Game { data Game = Game {
gameFlat :: Bool, gameFlat :: Bool,
@ -98,16 +101,19 @@ renderMenu (w,h) before after =
where where
menu = menu =
case Map.minViewWithKey after of case Map.minViewWithKey after of
Nothing -> string defAttr "empty menu" Nothing -> bigString defAttr "empty menu"
Just ((k,_),after') -> Just ((k,_),after') ->
let len1 = (h-1)`div`2 in let len1 = (h-1)`div`2 `div` 6 in
pad 0 (len1 - Map.size before) 0 0 (vertCat pad 0 (max 0 (6 * (len1 - Map.size before))) 0 0 $
[ string defAttr x vertCat $
intersperse (char defAttr ' ') $
[ bigString defAttr x
| x <- drop (Map.size before - len1) (Map.keys before) | x <- drop (Map.size before - len1) (Map.keys before)
]) <-> ] ++
string (defAttr `withBackColor` cyan `withForeColor` white) k [bigString (defAttr `withBackColor` cyan `withForeColor` white) k] ++
<-> [ bigString defAttr x
vertCat
[ string defAttr x
| x <- drop (Map.size after' - h`div`2) (Map.keys after') | x <- drop (Map.size after' - h`div`2) (Map.keys after')
] ]
bigString :: Attr -> String -> Image
bigString a = vertCat . map (string a) . bigText . map toUpper

4
app/Model.hs
View File

@ -41,7 +41,9 @@ data World = World {
worldBoxes :: Map Char Box, worldBoxes :: Map Char Box,
worldMe :: Char, worldMe :: Char,
worldButtons :: Set Location, worldButtons :: Set Location,
worldHome :: Location worldHome :: Location,
worldHeight :: Int,
worldWidth :: Int
} }
deriving (Show, Read, Eq) deriving (Show, Read, Eq)

139
app/Parser.hs
View File

@ -6,70 +6,109 @@ import Graphics.Vty.Attributes
import Data.Array (Array, listArray) import Data.Array (Array, listArray)
import Data.Map qualified as Map import Data.Map qualified as Map
import Data.Set qualified as Set import Data.Set qualified as Set
import Text.ParserCombinators.ReadP hiding (many)
import Control.Applicative
import Control.Monad
parse :: String -> World parse :: String -> World
parse str = either error id $ parse str =
case lines str of case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of
x:xs -> [] -> error "world parsing failed"
do h <- parseHeader x (((p,h,w),bs),_):_ ->
bs <- parseBlocks xs do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs] World
pure $ World
(Map.fromList [ (Map.fromList [
(n, b { boxLocation = head (m Map.! n)}) (n, b { boxLocation = head (m Map.! n)})
| (n,b,_) <- bs | (n,b,_) <- bs
]) ])
h p
(Set.fromList (Map.findWithDefault [] '-' m)) (Set.fromList (Map.findWithDefault [] '-' m))
(head (m Map.! '=')) (head (m Map.! '='))
[] -> Left "empty input" h w
parseHeader :: String -> Either String Char parseHeader :: ReadP (Char,Int,Int)
parseHeader (words -> ["player", [p]]) = Right p parseHeader =
parseHeader _ = Left "bad header" do "player" <- token
[p] <- token
h <- option 81
do "height" <- token
integer
w <- option (81*2)
do "width" <- token
integer
pure (p,h,w)
parseBlocks :: [String] -> Either String [(Char, Box, [(Char, Location)])] integer :: ReadP Int
parseBlocks [] = Right [] integer = readS_to_P reads
parseBlocks (x:xs) =
case words x of parseBoring :: ReadP Bool
["block", [name], color, boring] -> parseBoring =
do color_ <- parseColor color do t <- token
let (xs1,xs2) = splitWalls xs case t of
"boring" -> pure True
"interesting" -> pure False
_ -> empty
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 locs = findLocs name xs1
let b = Box undefined (Original (walls xs1)) color_ (boring == "boring") let b = Box undefined (Original (walls xs1)) color boring
bs <- parseBlocks xs2 pure (name, b, locs)
pure ((name, b, locs):bs) "link" ->
["link", [name], [target], color] -> do [name] <- token
do color_ <- parseColor color [target] <- token
bs <- parseBlocks xs color <- parseColor
pure ((name, Box undefined (Link target) color_ True, []):bs) _ <- char '\n'
["infinity", [name], [target], color] -> pure (name, Box undefined (Link target) color True, [])
do color_ <- parseColor color "infinity" ->
bs <- parseBlocks xs do [name] <- token
pure ((name, Box undefined (Infinity target) color_ True,[]):bs) [target] <- token
["epsilon", [name], [target], color] -> color <- parseColor
do color_ <- parseColor color _ <- char '\n'
let (xs1,xs2) = splitWalls xs 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 locs = findLocs name xs1
let b = Box undefined (Epsilon target (walls xs1)) color_ False let b = Box undefined (Epsilon target (walls xs1)) color False
bs <- parseBlocks xs2 pure (name, b, locs)
pure ((name, b, locs):bs) _ -> empty
_ -> Left "bad block"
splitWalls (x:xs) = parseWalls :: ReadP [String]
case splitAt (length x - 1) xs of parseWalls =
(a,b) -> (x:a, b) do row0 <- munch1 ('\n' /=) <* char '\n'
rows <- replicateM (length row0 - 1) (munch1 ('\n' /=) <* char '\n')
pure (row0:rows)
parseColor :: String -> Either String Attr token :: ReadP String
parseColor "white" = Right (withForeColor defAttr white) token = readS_to_P lex
parseColor "cyan" = Right (withForeColor defAttr cyan)
parseColor "blue" = Right (withForeColor defAttr blue) parseColor :: ReadP Attr
parseColor "red" = Right (withForeColor defAttr red) parseColor =
parseColor "yellow" = Right (withForeColor defAttr yellow) do t <- token
parseColor "magenta" = Right (withForeColor defAttr magenta) case t of
parseColor "black" = Right (withForeColor defAttr black) "white" -> pure (withForeColor defAttr white)
parseColor "green" = Right (withForeColor defAttr green) "cyan" -> pure (withForeColor defAttr cyan)
parseColor x = Left ("bad color " ++ x) "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 :: [String] -> Array Coord Bool
walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows)) walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows))

17
app/Rendering.hs
View File

@ -116,7 +116,7 @@ renderFlat locMap world =
] ]
where where
borderAttr = defAttr `withForeColor` white `withBackColor` black 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 = baseImage =
pad 2 1 2 1 $ pad 2 1 2 1 $
horizCat $ horizCat $
@ -127,11 +127,10 @@ renderFlat locMap world =
drawNestedWorld :: Map Location Char -> World -> Image drawNestedWorld :: Map Location Char -> World -> Image
drawNestedWorld locMap world = drawNestedWorld locMap world =
-- (3*81) + 81 + (3*81) cropTop (h + 2*border) $
cropTop (81 + 2*border) $ cropLeft (w + 4*border) $
cropLeft (2*(81 + 2*border)) $ cropBottom (2*h + border) $
cropBottom (2*81 + border) $ cropRight (2*(w + border)) $
cropRight (2*(2*81 + border)) $
vertCat $ vertCat $
intersperse (char defAttr ' ') intersperse (char defAttr ' ')
[ [
@ -139,15 +138,17 @@ drawNestedWorld locMap world =
intersperse (char defAttr ' ') intersperse (char defAttr ' ')
[ [
case stackedLoc world locMap (Location name1 y_ x_) of 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) -> Just (Location n y x) ->
let box = worldBoxes world Map.! n in 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] | x_ <- [x1-1 .. x1+1]
] ]
| y_ <- [y1-1 .. y1+1] | y_ <- [y1-1 .. y1+1]
] ]
where where
h = worldHeight world
w = worldWidth world
-- name1 is the box the player is standing in -- name1 is the box the player is standing in
Location name0 _ _ = myLocation world Location name0 _ _ = myLocation world
Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0) Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0)

24
levels/center8.txt
View File

@ -1,14 +1,10 @@
player p player p
block t white boring block t white boring
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓t▓a▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓t▓a▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block a white interesting block a white interesting
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓▓▓▓▓
@ -28,8 +24,8 @@ block g green interesting
block x yellow boring block x yellow boring
▓ ▓
block p magenta boring block p magenta boring
▓▓▓▓▓▓ ▓▓▓▓▓
▓ ▓▓ ▓ ▓ ▓ ▓
▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓ ▓▓▓▓▓

16
levels/eat11.txt
View File

@ -1,4 +1,4 @@
player p player p height 75 width 150
block t red boring block t red boring
▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓ ▓▓▓▓▓
@ -6,15 +6,11 @@ block t red boring
▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓ ▓▓▓▓▓
block r red interesting block r red interesting
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ p y
▓▓ ▓▓
▓▓ p y ▓▓ b g
▓▓ ▓▓ = -
▓▓ b g ▓▓
▓▓= -▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block p magenta boring block p magenta boring
▓▓▓▓▓ ▓▓▓▓▓
▓ ▓ ▓ ▓ ▓ ▓

40
levels/infiniteExit15.txt
View File

@ -1,14 +1,10 @@
player m player m
block t cyan boring block t cyan boring
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓t▓a▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓t▓a▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block a cyan interesting block a cyan interesting
▓▓▓G▓▓▓▓▓ ▓▓▓G▓▓▓▓▓
▓▓▓▓ ▓▓▓▓
@ -20,35 +16,19 @@ block a cyan interesting
▓▓▓▓ ▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓▓▓▓▓
block m magenta boring block m magenta boring
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓ ▓ ▓
▓▓ ▓▓▓ ▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block g green interesting block g green interesting
block p red interesting block p red interesting
link G g green link G g green
link P p red link P p red
infinity Γ g green infinity Γ g green

2
parabox.cabal
View File

@ -19,7 +19,7 @@ common warnings
executable parabox executable parabox
import: warnings import: warnings
main-is: Main.hs main-is: Main.hs
other-modules: Rendering, Model, Parser other-modules: Rendering, Model, Parser, BigFont
-- other-modules: -- other-modules:
default-extensions: ImportQualifiedPost, BlockArguments, LambdaCase default-extensions: ImportQualifiedPost, BlockArguments, LambdaCase