improvements

2022-12-08 18:58:07 -08:00 · 2022-12-08 18:58:07 -08:00 · a105ceabab
commit a105ceabab
parent e4ee9d39b7
4 changed files with 128 additions and 77 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -1,26 +1,28 @@
 module Main (main) where

 import Control.Exception ( bracket )
+import Data.Char (toUpper)
+import Data.List (intersperse, isPrefixOf, sort)
 import Data.List.NonEmpty (NonEmpty(..), (<|))
 import Data.List.NonEmpty qualified as NonEmpty
-import Data.Char (toUpper)
-import Data.List (intersperse, sort)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Graphics.Vty
-import System.Environment ( getArgs )
+import Data.Ord (clamp)
 import System.Directory (listDirectory)
-import System.FilePath ( (</>), takeBaseName )
+import System.Environment (getArgs)
+import System.FilePath ((</>), takeBaseName, takeExtension)

+import BigFont (bigText)
 import Model
-import Rendering ( render )
 import Parser (parse)
-import BigFont
+import Rendering (render, wrapBox)

 data Game = Game {
  gameFlat :: Bool,
  gameMode :: GameMode,
-  gameSelect :: Int
+  gameSelect :: Int,
+  gameError :: String
 }

 data GameMode
@ -29,9 +31,20 @@ data GameMode

 getWorldList :: IO (Map String FilePath)
 getWorldList =
- do paths <- sort <$> listDirectory "levels"
+ do paths <- sort . filter isLevelName <$> listDirectory "levels"
    pure (Map.fromList [(takeBaseName path, "levels" </> path) | path <- paths])

+isLevelName :: FilePath -> Bool
+isLevelName path = not ("." `isPrefixOf` path) && ".txt" == takeExtension path
+
+defaultGame :: Game
+defaultGame = Game {
+  gameMode = MenuMode,
+  gameFlat = True,
+  gameSelect = 0,
+  gameError = ""
+}
+
 main :: IO ()
 main =
 do args <- getArgs
@ -39,44 +52,37 @@ main =
    bracket (mkVty =<< userConfig) shutdown \vty ->
      case args of
        x:_ | Just path <- Map.lookup x worldList ->
-         do w <- parse <$> readFile path 
-            loop vty Game {
-              gameMode = PlayMode (pure w),
-              gameFlat = True,
-              gameSelect = Map.findIndex x worldList
-              }
-        _ ->
-          loop vty Game {
-            gameMode = MenuMode,
-            gameFlat = True,
-            gameSelect = 0
-          }
+            loadLevelFile vty defaultGame path
+        _ -> loop vty defaultGame

 loop :: Vty -> Game -> IO ()
-loop vty game =
+loop vty game = do
+  bnds <- displayBounds (outputIface vty)
  case gameMode game of
    MenuMode ->
     do worldList <- getWorldList
-        bnds <- displayBounds (outputIface vty)
-        update vty (picForImage (renderMenu (gameSelect game) worldList bnds))
+        update vty (picForLayers $
+                      [errorImage (gameError game) | not (null (gameError game))] ++
+                      [renderMenu bnds (gameSelect game) worldList])
        ev <- nextEvent vty
        case ev of
          EvKey key _modifier ->
            case key of
-              KEsc -> pure ()
-              KUp | gameSelect game > 0 ->
-                loop vty game{ gameSelect = gameSelect game - 1 }
-              KDown | gameSelect game + 1 < Map.size worldList ->
-                loop vty game{ gameSelect = gameSelect game + 1 }
-              KEnter | (_, path) <- Map.elemAt (gameSelect game) worldList ->
-                do world <- parse <$> readFile path
-                   loop vty game{ gameMode = PlayMode (pure world) }
+              KEsc      -> escape vty game
+              KUp       -> loop vty game{ gameSelect = max 0 (gameSelect game -  1) }
+              KPageUp   -> loop vty game{ gameSelect = max 0 (gameSelect game - 10) }
+              KDown     -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game +  1) }
+              KPageDown -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game + 10) }
+              KEnter
+                | 0 <= gameSelect game, gameSelect game < Map.size worldList
+                , (_, path) <- Map.elemAt (gameSelect game) worldList ->
+                  loadLevelFile vty game path
              _ -> loop vty game
          _ -> loop vty game

    PlayMode worlds ->
     do let world = NonEmpty.head worlds
-        update vty (render (gameFlat game) (NonEmpty.head worlds))
+        update vty (render bnds (gameFlat game) (NonEmpty.head worlds))
        ev <- nextEvent vty
        case ev of
          EvKey key _modifier ->
@ -91,14 +97,28 @@ loop vty game =
              KChar 'z'
                | Just worlds' <- NonEmpty.nonEmpty (NonEmpty.tail worlds) ->
                  loop vty game{ gameMode = PlayMode worlds' }
-              KEsc -> pure ()
+              KEsc -> escape vty game
              KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) }
              _ -> loop vty game
          _ -> loop vty game

+escape :: Vty -> Game -> IO ()
+escape vty game
+  | null (gameError game) = pure ()
+  | otherwise = loop vty game{ gameError = "" }

-renderMenu :: Int -> Map String a -> DisplayRegion -> Image
-renderMenu sel list (w,h)
+loadLevelFile :: Vty -> Game -> FilePath -> IO ()
+loadLevelFile vty game path =
+ do file <- readFile path
+    case parse file of
+      Left errorMessage -> loop vty game{ gameError = errorMessage }
+      Right world -> loop vty game{
+                       gameMode = PlayMode (pure world),
+                       gameError = ""
+                     }
+
+renderMenu :: DisplayRegion -> Int -> Map String a -> Image
+renderMenu (w,h) sel list
  | hpad >= 0 = pad wpad hpad 0 0 menu
  | otherwise = pad wpad 0 0 0 (cropTop (imageHeight menu + hpad) menu)
  where
@ -112,5 +132,10 @@ renderMenu sel list (w,h)
        | (i,k) <- zip [0..] (Map.keys list)
      ]

+errorImage :: String -> Image
+errorImage str = wrapBox a (bigString a str)
+  where
+    a = defAttr `withForeColor` red
+
 bigString :: Attr -> String -> Image
 bigString a = vertCat . map (string a) . bigText . map toUpper
--- a/app/Model.hs
+++ b/app/Model.hs
@ -207,11 +207,13 @@ nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rationa
 nextLoc world (dy, dx) = go Set.empty
  where

+  -- Step fits within current box, success
  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)

+  -- Step takes us off the edge of the box, exit to parent
  go visited (Location b y x) offset
    | Just box <- Map.lookup b (worldBoxes world)
    , Set.notMember b visited
@ -222,11 +224,13 @@ nextLoc world (dy, dx) = go Set.empty
    $ (offset + fromIntegral (abs dy*x+abs dx*y))
    / fromIntegral faceSize

+  -- exiting has cycled, exit from next infinity box
  go visited (Location b y x) offset
    | Set.member b visited
    , Just b' <- findInfinity world b
    = go visited (Location b' y x) offset

+  -- infinity boxes exhausted, exit to void
  go _ _ _ = Nothing

 findInfinity :: World -> Char -> Maybe Char
--- a/app/Parser.hs
+++ b/app/Parser.hs
@ -10,18 +10,34 @@ import Text.ParserCombinators.ReadP hiding (many)

 import Model

-parse :: String -> World
+parse :: String -> Either String World
 parse str =
  case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of
-    [] -> error "world parsing failed"
+    [] -> Left "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 <$> Map.lookup n m }) | (n,b,_) <- bs])
-          p
-          (Set.fromList (Map.findWithDefault [] '-' m))
-          (head (m Map.! '='))
-          (h, w)
+
+         home <-
+           case Map.lookup '=' m of
+             Nothing -> Left "no home location defined"
+             Just [home] -> Right home
+             Just _      -> Left "ambiguous home defined"
+
+         boxes <- sequence $
+           Map.fromList
+             [(n, case Map.lookup n m of
+                    Nothing -> Right b {boxLocation = Nothing}
+                    Just [l] -> Right b {boxLocation = Just l}
+                    Just _   -> Left ("ambiguous location for: " ++ [n])
+              ) | (n,b,_) <- bs]
+
+         Right World {
+          worldBoxes   = boxes,
+          worldMe      = p,
+          worldButtons = Set.fromList (Map.findWithDefault [] '-' m),
+          worldHome    = home,
+          worldSize    = (h, w)
+          }

 parseHeader :: ReadP (Char,Int,Int)
 parseHeader =
@ -30,7 +46,7 @@ parseHeader =
    h <- option 81
          do "height" <- token
             integer
-    w <- option (81*2)
+    w <- option (h*2)
          do "width" <- token
             integer
    pure (p,h,w)
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@ -18,12 +18,11 @@ unit :: Attr -> Int -> Int -> Char -> Image
 unit a h w c =
  vertCat (replicate h (string a (replicate w c)))

-drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image
-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) '─' ++ "┘")]
+wrapBox :: Attr -> Image -> Image
+wrapBox a body =
+  char a '┌' <|> charFill a '─' (imageWidth body) 1 <|> char a '┐' <->
+  charFill a '│' 1 (imageHeight body) <|> body <|> charFill a '│' 1 (imageHeight body) <->
+  char a '└' <|> charFill a '─' (imageWidth body) 1 <|> char a '┘'

 button :: Attr -> Int -> Int -> Image
 button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
@ -93,48 +92,53 @@ renderBox world locMap box name boxh boxw =
    boxHeight = yhi - ylo + 1

 render ::
+  DisplayRegion ->
  Bool {- ^ show flat overlay -} ->
  World ->
  Picture
-render flat world = picForLayers $
-  [ pad 98 12 0 0 $
-    string defAttr "██╗    ██╗██╗███╗   ██╗███╗   ██╗███████╗██████╗ " <->
-    string defAttr "██║    ██║██║████╗  ██║████╗  ██║██╔════╝██╔══██╗" <->
-    string defAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗  ██████╔╝" <->
-    string defAttr "██║███╗██║██║██║╚██╗██║██║╚██╗██║██╔══╝  ██╔══██╗" <->
-    string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║  ██║" <->
-    string defAttr " ╚══╝╚══╝ ╚═╝╚═╝  ╚═══╝╚═╝  ╚═══╝╚══════╝╚═╝  ╚═╝"
-  | winCondition world ] ++
-  [ pad 94 7 0 0 $
+render bnds flat world = picForLayers $
+  [ center bnds $
+    pad 0 12 0 0 $
+    wrapBox winAttr $
+    string winAttr "██╗    ██╗██╗███╗   ██╗███╗   ██╗███████╗██████╗ " <->
+    string winAttr "██║    ██║██║████╗  ██║████╗  ██║██╔════╝██╔══██╗" <->
+    string winAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗  ██████╔╝" <->
+    string winAttr "██║███╗██║██║██║╚██╗██║██║╚██╗██║██╔══╝  ██╔══██╗" <->
+    string winAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║  ██║" <->
+    string winAttr " ╚══╝╚══╝ ╚═╝╚═╝  ╚═══╝╚═╝  ╚═══╝╚══════╝╚═╝  ╚═╝"
+  | let winAttr = defAttr `withForeColor` yellow
+  , winCondition world ] ++
+  [ center bnds $
    vertCat (map (string defAttr) (bigText "VOIDED"))
  | isNothing (boxLocation (boxIx world (worldMe world))) ] ++
-  (if flat then renderFlat locMap world else []) ++
-  [drawNestedWorld locMap world]
+  (if flat then map (center bnds) (renderFlat locMap world) else []) ++
+  [center bnds (drawNestedWorld bnds locMap world)]
  where
    locMap = worldLocations world

+-- | Center an image horizontally within the display region.
+-- If the image is wider than the region, left-align it.
+center :: DisplayRegion -> Image -> Image
+center (w,_) image =
+  pad (max 0 (w - imageWidth image) `div` 2) 0 0 0 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)
-  ]
+  [wrapBox borderAttr baseImage | not (null components)]
  where
    borderAttr = defAttr `withForeColor` white `withBackColor` black
-    offset = max 0 ( (snd (worldSize world) + 2*(2*border)+2 - imageWidth baseImage) `div` 2)
-    baseImage =
-      pad 2 1 2 1 $
-      horizCat $
-      intersperse (char borderAttr ' ')
+    baseImage = horizCat components
+    components =
      [renderBox world locMap b n 18 36
      | (n,b) <- Map.assocs (worldBoxes world)
      , not (boxBoring b)]

-drawNestedWorld :: Map Location (Char, Box) -> World -> Image
-drawNestedWorld locMap world =
-    cropTop   (h + 2*border) $
-    cropLeft  (w + 4*border) $
-    cropBottom (2*h + border) $
-    cropRight  (2*(w + border)) $
+drawNestedWorld :: DisplayRegion -> Map Location (Char, Box) -> World -> Image
+drawNestedWorld (drW, drH) locMap world =
+    cropTop   (h + 2 + 2*edgeH) $
+    cropLeft  (w + 2 + 2*edgeW) $
+    cropBottom (2*h + 2 + edgeH) $
+    cropRight  (2*w + 2 + edgeW) $
    vertCat $
    intersperse (char defAttr ' ')
    [
@ -160,6 +164,8 @@ drawNestedWorld locMap world =
        | dy <- [-1 .. 1]
    ]
  where
+    edgeW = max 0 (drW - w) `div` 2
+    edgeH = max 0 (drH - h) `div` 2
    infinityImage = makeInfinity h w
    (h, w) = worldSize world