handle blocks having undefined location

2022-12-07 13:37:02 -08:00 · 2022-12-07 13:37:02 -08:00 · 84f74366bb
commit 84f74366bb
parent af5305cc24
9 changed files with 177 additions and 203 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -1,10 +1,10 @@
 module Main (main) where

 import Control.Exception ( bracket )
-import Data.List.NonEmpty (NonEmpty(..))
+import Data.List.NonEmpty (NonEmpty(..), (<|))
 import Data.List.NonEmpty qualified as NonEmpty
 import Data.Char (toUpper)
-import Data.List (intersperse)
+import Data.List (intersperse, sort)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Graphics.Vty
@ -29,7 +29,7 @@ data GameMode

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

 main :: IO ()
@ -57,17 +57,18 @@ loop vty game =
  case gameMode game of
    MenuMode ->
     do worldList <- getWorldList
-        let (a,b) = Map.splitAt (gameSelect game) worldList
        bnds <- displayBounds (outputIface vty)
-        update vty (picForImage (renderMenu bnds a b))
+        update vty (picForImage (renderMenu (gameSelect game) worldList bnds))
        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 | Just (path,_) <- Map.minView b ->
+              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) }
              _ -> loop vty game
@ -79,11 +80,12 @@ loop vty game =
        ev <- nextEvent vty
        case ev of
          EvKey key _modifier ->
+            let doMove m = game{ gameMode = PlayMode (move world m <| worlds) } in
            case key of
-              KUp    -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (-1,0)) worlds) }
-              KDown  -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (1,0) ) worlds) }
-              KLeft  -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,-1)) worlds) }
-              KRight -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,1) ) worlds) }
+              KUp    -> loop vty (doMove (-1, 0))
+              KDown  -> loop vty (doMove ( 1, 0))
+              KLeft  -> loop vty (doMove ( 0,-1))
+              KRight -> loop vty (doMove ( 0, 1))
              KChar 'm' -> loop vty game { gameMode = MenuMode }
              KChar 'r' -> loop vty game{ gameMode = PlayMode (pure (NonEmpty.last worlds)) }
              KChar 'z'
@ -95,24 +97,19 @@ loop vty game =
          _ -> loop vty game


-renderMenu :: DisplayRegion -> Map String a -> Map String a -> Image
-renderMenu (w,h) before after =
-  pad ((w - imageWidth menu) `div` 2) 0 0 0 menu
+renderMenu :: Int -> Map String a -> DisplayRegion -> Image
+renderMenu sel list (w,h)
+  | hpad >= 0 = pad wpad hpad 0 0 menu
+  | otherwise = pad wpad 0 0 0 (cropTop (imageHeight menu + hpad) menu)
  where
+    hpad = h`div`2 - sel*6
+    wpad = max 0 (w - imageWidth menu) `div` 2
    menu =
-      case Map.minViewWithKey after of
-        Nothing -> bigString defAttr "empty menu"
-        Just ((k,_),after') ->
-          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)
-            ] ++
-            [bigString (defAttr `withBackColor` cyan `withForeColor` white) k] ++
-            [ bigString defAttr x
-              | x <- drop (Map.size after' - h`div`2) (Map.keys after')
+      [ bigString (if sel == i then defAttr `withBackColor` cyan `withForeColor` white
+                   else defAttr) k
+        | (i,k) <- zip [0..] (Map.keys list)
      ]

 bigString :: Attr -> String -> Image
--- a/app/Model.hs
+++ b/app/Model.hs
@ -12,7 +12,7 @@ import Data.Set (Set)
 type Coord = (Int, Int)

 data Box = Box {
-  boxLocation :: Location,
+  boxLocation :: Maybe Location,
  boxType     :: BoxType,
  boxColor    :: Attr,
  boxBoring   :: Bool
@ -50,9 +50,9 @@ data World = World {
 winCondition :: World -> Bool
 winCondition world =
  Set.isSubsetOf (worldButtons world) coverage &&
-  worldHome world == boxLocation (worldBoxes world Map.! worldMe world)
+  Just (worldHome world) == boxLocation (worldBoxes world Map.! worldMe world)
  where
-    coverage = Set.fromList $ map boxLocation $ Map.elems (worldBoxes world)
+    coverage = Set.fromList $ mapMaybe boxLocation $ Map.elems (worldBoxes world)


 boxSize :: World -> Box -> Int
@ -62,13 +62,16 @@ boxSize world box = yhi-ylo+1

 move :: World -> (Int,Int) -> World
 move world dir =
-  case moveBlock world Map.empty (myLocation world) dir 0 of
+  case myLocation world of
+    Nothing -> world
+    Just loc ->
+      case moveBlock world Map.empty loc dir 0 of
        Nothing -> world
        Just changes ->
-      let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in
-      world { worldBoxes = fmap f (worldBoxes world)}
+          let f box change = box { boxLocation = change } in
+          world { worldBoxes = Map.mergeWithKey (\_ a b -> Just (f a b)) id (const Map.empty) (worldBoxes world) changes}

-myLocation :: World -> Location
+myLocation :: World -> Maybe Location
 myLocation world =
  boxLocation (worldBoxes world Map.! worldMe world)

@ -82,11 +85,11 @@ type Movement = (Int, Int)

 moveBlock ::
  World ->
-  Map Location (Int, Location) ->
+  Map Location (Int, Char, Maybe Location) ->
  Location ->
  Movement ->
  Rational {- ^ offset -} ->
-  Maybe (Map Location Location)
+  Maybe (Map Char (Maybe Location))

 -- moving into a wall, not possible
 moveBlock world _ loc _ _
@ -94,24 +97,25 @@ moveBlock world _ loc _ _

 -- move introduced a loop, trim off the tail and report success
 moveBlock _ visited loc _ _
-  | Just (n,_) <- Map.lookup loc visited
-  = Just (fmap snd (Map.filter (\(a,_)->a >= n) visited))
+  | 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 =
-  case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == loc] of
+  case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == Just loc] of
    -- moving an empty space, so we're done
-    [] -> Just (fmap snd visited)
+    [] -> Just (Map.fromList [(c,l) | (_,c,l) <- Map.elems visited])

    -- moving a box
    (name,box):_ ->
-     do (loc', offset') <- nextLoc world dir loc offset
-        --traceM (show "Next loc " ++ show loc' ++ " offset " ++ show offset')
-        guard (not (isWall world loc'))
+      case nextLoc world dir loc offset of
+        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 ->
-    Map Location (Int, Location) -> 
+    Map Location (Int, Char, Maybe Location) ->
    Location ->
    Location ->
    Movement ->
@ -119,29 +123,32 @@ moveBlock' ::
    Box ->
    Set Location ->
    Rational {- ^ offset -} ->
-    Maybe (Map Location Location)
+    Maybe (Map Char (Maybe Location))
 moveBlock' world visited loc loc' dir name box enters offset =
        msum [moveTo, moveInto, moveToEat]
      where
        moveTo =
-         do moveBlock world (addVisited loc loc' visited) loc' dir 0
+         do moveBlock world (addVisited name loc (Just loc') visited) loc' dir 0

        moveInto =
         do (n,b) <- boxAt world loc'
            (locI, offset') <- enterLoc world n b dir offset
-            if Set.member locI enters then do
-              epsilon <- findEpsilon world (locName loc')
+            if Set.member locI enters then
+              moveEpsilon
+            else
+              moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
+
+        moveEpsilon =
+         do epsilon <- findEpsilon world (locName loc')
            let eBox = worldBoxes world Map.! epsilon
            (locI, offset') <- enterLoc world epsilon eBox dir offset
            moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
-            else
-              moveBlock' world 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 loc loc' visited) loc' locE dir' name' box' Set.empty 0
+            moveBlock' world (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 =
@ -168,7 +175,7 @@ enterLoc world name box dir@(dy,dx) offset =

 boxAt :: World -> Location -> Maybe (Char, Box)
 boxAt world loc =
-  listToMaybe  [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc]
+  listToMaybe  [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == Just loc]

 invert :: Movement -> Movement
 invert (dy,dx) = (-dy, -dx)
@ -177,11 +184,12 @@ midpoint :: Int -> Int -> Rational -> Int
 midpoint lo hi offset = round (offset * fromIntegral (hi-lo+1))

 addVisited ::
+    Char {- ^ name -} ->
    Location {- ^ start -} ->
-    Location {- ^ end   -} ->
-    Map Location (Int, Location) ->
-    Map Location (Int, Location)
-addVisited k v m = Map.insert k (Map.size m, v) m
+    Maybe Location {- ^ end   -} ->
+    Map Location (Int, Char, Maybe Location) ->
+    Map Location (Int, Char, Maybe Location)
+addVisited name k v m = Map.insert k (Map.size m, name, v) m

 nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rational)
 nextLoc world (dy, dx) = go Set.empty
@ -195,7 +203,8 @@ nextLoc world (dy, dx) = go Set.empty
  go visited (Location b y x) offset
    | Just box <- Map.lookup b (worldBoxes world)
    , Set.notMember b visited
-    = go (Set.insert b visited) (boxLocation box)
+    , Just boxLoc <- boxLocation box
+    = go (Set.insert b visited) boxLoc
    $ (offset + fromIntegral (abs dy*x+abs dx*y))
      / fromIntegral (boxSize world box)

@ -208,9 +217,10 @@ nextLoc world (dy, dx) = go Set.empty

 findInfinity :: World -> Char -> Maybe Char
 findInfinity world b =
-  listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world), Infinity i <- [boxType box], i == b]
-
+  listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
+                  , Infinity i <- [boxType box], i == b]

 findEpsilon :: World -> Char -> Maybe Char
 findEpsilon world b =
-  listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world), Epsilon i _ <- [boxType box], i == b]
+  listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
+                  , Epsilon i _ <- [boxType box], i == b]
--- a/app/Parser.hs
+++ b/app/Parser.hs
@ -18,7 +18,7 @@ parse str =
      do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
         World
          (Map.fromList [
-            (n, b { boxLocation = head (m Map.! n)})
+            (n, b { boxLocation = fmap head (Map.lookup n m)})
            | (n,b,_) <- bs
          ])
          p
@ -61,7 +61,7 @@ parseBlock =
          _ <- char '\n'
          xs1 <- parseWalls
          let locs = findLocs name xs1
-          let b = Box undefined (Original (walls xs1)) color boring
+          let b = Box Nothing (Original (walls xs1)) color boring
          pure (name, b, locs)
      "link" ->
       do [name] <- token
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@ -1,6 +1,7 @@
 module Rendering where

 import Data.Array
+import Data.Maybe
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
@ -78,13 +79,13 @@ contentName world name box =
    Epsilon{} -> name

 renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image
-renderBox world locMap box name h w =
+renderBox world locMap box name boxh boxw =
  vertCat [
    horizCat [
-      renderCell world locMap name box y x h w
-      | (x,w) <- zip [xlo .. xhi] (divisions boxWidth w)
+      renderCell world locMap name box y x cellh cellw
+      | (x,cellw) <- zip [xlo .. xhi] (divisions boxWidth boxw)
    ]
-    | (y,h) <- zip [ylo .. yhi] (divisions boxHeight h)
+    | (y,cellh) <- zip [ylo .. yhi] (divisions boxHeight boxh)
  ]
  where
    ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
@ -107,7 +108,7 @@ render flat world = picForLayers $
  (if flat then renderFlat locMap world else []) ++
  [drawNestedWorld locMap world]
  where
-    locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
+    locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world), loc <- maybeToList (boxLocation box)]

 renderFlat :: Map Location Char -> World -> [Image]
 renderFlat locMap world =
@ -137,22 +138,29 @@ drawNestedWorld locMap world =
        horizCat $
        intersperse (char defAttr ' ')
         [
-            case stackedLoc world locMap (Location name1 y_ x_) of
-                Nothing -> unit (withForeColor defAttr black) h w '?'
+            case myLocation world of
+              Nothing
+                | dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! worldMe world) (worldMe world) h w
+                | otherwise -> infinityImage
+              Just (Location name0 _ _) ->
+                case boxLocation (worldBoxes world Map.! name0) of
+                  Nothing
+                    | dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! 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
-        | x_ <- [x1-1 .. x1+1]
+        | dx <- [-1 .. 1]
        ]
-        | y_ <- [y1-1 .. y1+1]
+        | dy <- [-1 .. 1]
    ]
  where
+    infinityImage = unit (withForeColor defAttr black) h w '?'
    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)
-

 stackedLoc :: World -> Map Location Char -> Location -> Maybe Location
 stackedLoc world locMap = go Set.empty
@ -168,11 +176,10 @@ stackedLoc world locMap = go Set.empty
      if inRange bnds (y, x)
        then Just loc
        else
-            let dx = overflow (xlo,xhi) x
+         do let dx = overflow (xlo,xhi) x
                dy = overflow (ylo,yhi) y
-                Location parent py px = boxLocation box
-            in fixup world locMap dy dx y x <$> go (Set.insert loc visited) (Location parent (py+dy) (px+dx))
-
+            Location parent py px <- boxLocation box
+            fixup world locMap dy dx y x <$> go (Set.insert loc visited) (Location parent (py+dy) (px+dx))

 overflow :: (Int, Int) -> Int -> Int
 overflow (lo,hi) x
@ -208,7 +215,7 @@ divisions divs size =
    (fromIntegral i + 1 / 2)
    / fromIntegral size
    * fromIntegral divs
-    - 1/2
-  )
+    - 1/2 :: Rational
+    ) :: Int
  | i <- [0 ..size-1]
  ]
--- a/levels/infiniteEnter11.txt
+++ b/levels/infiniteEnter11.txt
@ -1,4 +1,4 @@
-player p
+player p height 98 width 196
 block t white boring
 ▓▓▓▓▓
 ▓▓▓▓▓
@ -6,15 +6,13 @@ block t white boring
 ▓▓▓▓▓
 ▓▓▓▓▓
 block w white interesting
-▓▓▓▓▓▓▓▓▓
-▓▓     ▓▓
-▓▓ g G ▓▓
-▓▓     ▓▓
-▓▓ = p ▓▓
-▓▓     ▓▓
-▓▓▓▓▓▓ ▓▓
-▓▓▓ε▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓     ▓
+▓ g G ▓
+▓     ▓
+▓ = p ▓
+▓     ▓
+▓▓▓▓▓ ▓
+▓▓ε▓▓▓▓
 link G g green
 link H g green
 block g green interesting
--- a/levels/infiniteEnter6.txt
+++ b/levels/infiniteEnter6.txt
@ -1,24 +1,12 @@
 player p
-block t black boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓t▓▓▓w▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓ε▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
 block w white interesting
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓  p  ▓▓
-▓▓ G H ▓▓
-▓▓ =   ▓▓
-▓▓    -▓▓
-▓▓▓▓g▓=▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓▓▓▓▓▓▓
+▓  p  ▓
+▓ G H ▓
+▓     ▓
+▓    -▓
+▓▓▓g▓=▓
+▓▓▓▓▓▓▓
 link G g green
 link H g green
 block g green interesting
@ -27,10 +15,6 @@ block g green interesting
     
     
     
-         
-         
-         
-         
 epsilon ε g green
     b 
       
@ -39,25 +23,13 @@ epsilon ε g green
   ▓   
       
       
-         
-         
 block p magenta boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓ ▓▓▓ ▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓▓▓▓▓
+▓ ▓ ▓
+▓▓▓▓▓
+▓▓▓▓▓
+▓▓▓▓▓
 block b blue interesting
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
 ▓▓▓
-      ▓▓▓
-      ▓▓▓
-▓▓▓   ▓▓▓
-▓▓▓   ▓▓▓
-▓▓▓   ▓▓▓
+  ▓
+▓ ▓
--- a/levels/infiniteExit16.txt
+++ b/levels/infiniteExit16.txt
@ -10,15 +10,9 @@ block t white boring
 ▓▓▓▓▓▓▓▓▓
 ▓▓▓▓▓▓▓▓▓
 block a white interesting
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓p  ▓▓▓
-▓▓▓  ∞▓▓▓
-▓▓▓ P▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+p  
+  ∞
+ P▓
 link P p magenta
 infinity ∞ p magenta
 block p magenta interesting
@ -32,32 +26,10 @@ block p magenta interesting
         
    ▓   c
 block c green interesting
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
 ▓▓▓
-    = ▓▓▓
+ =▓
 ▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
 block 1 blue boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓
 block 2 blue boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓
--- a/levels/player19.txt
+++ b/levels/player19.txt
@ -0,0 +1,17 @@
+player p
+block p magenta interesting
+       
+       
+  p ▓  
+       
+  1 2  
+       
+c      
+block c green interesting
+▓▓▓
+ =▓
+▓▓▓
+block 1 blue boring
+▓
+block 2 blue boring
+▓
--- a/levels/transfer14.txt
+++ b/levels/transfer14.txt
@ -17,14 +17,15 @@ block g green interesting
   ▓   
 block y yellow interesting
 ▓     ▓
-▓     ▓
       
       
       
-▓     ▓
+       
+       
 ▓     ▓
 block p magenta boring
 ▓▓▓▓▓
 ▓ ▓ ▓
 ▓▓▓▓▓
 ▓▓▓▓▓
+▓▓▓▓▓