cleaner model

2022-12-08 09:34:27 -08:00 · 2022-12-08 09:34:27 -08:00 · 2dbf578d33
commit 2dbf578d33
parent a67bbea3cb
4 changed files with 103 additions and 113 deletions
--- a/app/Model.hs
+++ b/app/Model.hs
@ -1,13 +1,14 @@
 module Model where

-import Data.Array
+import Data.Array.Unboxed
 import Data.Map (Map)
 import Data.Map qualified as Map
-import Graphics.Vty
-import Control.Monad
-import Data.Maybe
+import Graphics.Vty ( Attr )
+import Control.Monad ( guard, msum )
+import Data.Maybe ( listToMaybe, mapMaybe, maybeToList )
 import Data.Set qualified as Set
 import Data.Set (Set)
+import GHC.Stack (HasCallStack)

 type Coord = (Int, Int)

@ -19,31 +20,37 @@ data Box = Box {
 }
   deriving (Show, Read, Eq)

-boxWalls :: World -> Box -> Array Coord Bool
+-- | Compute the height and width of a box.
+boxSize :: World -> Box -> (Int, Int)
+boxSize world box = (yhi-ylo+1, xhi-xlo+1)
+  where
+    ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
+
+-- | Find the array corresponding to the walls of a box.
+boxWalls :: World -> Box -> UArray Coord Bool
 boxWalls world box =
    case boxType box of
-        Original walls -> walls
-        Link c -> boxWalls world (boxIx world c)
-        Infinity c -> boxWalls world (boxIx world c)
+        Original walls  -> walls
+        Link c          -> boxWalls world (boxIx world c)
+        Infinity c      -> boxWalls world (boxIx world c)
        Epsilon _ walls -> walls

 data BoxType
-    = Original (Array Coord Bool)
-    | Link     Char
-    | Infinity Char
-    | Epsilon  Char (Array Coord Bool)
+    = Original (UArray Coord Bool)      -- ^ plain box
+    | Link     Char                     -- ^ entrance clone
+    | Infinity Char                     -- ^ infinite exit
+    | Epsilon  Char (UArray Coord Bool) -- ^ infinite enter
   deriving (Show, Read, Eq)

 data Location = Location { locName :: Char, locY :: Int, locX :: Int }
  deriving (Read, Show, Ord, Eq)

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

@ -54,18 +61,13 @@ winCondition world =
  where
    coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world)))

-
-boxSize :: World -> Box -> Int
-boxSize world box = yhi-ylo+1
-  where
-    ((ylo,_),(yhi,_)) = bounds (boxWalls world box)
-
 move :: World -> (Int,Int) -> World
 move world dir =
  case myLocation world of
    Nothing -> world
    Just loc ->
-      case moveBlock world Map.empty loc dir 0 of
+      let locMap = worldLocations world in
+      case moveBlock world locMap Map.empty loc dir 0 of
        Nothing -> world
        Just changes ->
          let f box change = box { boxLocation = change } in
@ -84,6 +86,7 @@ type Movement = (Int, Int)

 moveBlock ::
  World ->
+  Map Location (Char, Box) ->
  Map Location (Int, Char, Maybe Location) ->
  Location ->
  Movement ->
@ -91,15 +94,15 @@ moveBlock ::
  Maybe (Map Char (Maybe Location))

 -- moving into a wall, not possible
-moveBlock world _ loc _ _
+moveBlock world _ _ loc _ _
  | isWall world loc = Nothing

 -- move introduced a loop, trim off the tail and report success
-moveBlock _ visited loc _ _
+moveBlock _ _ visited loc _ _
  | 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 =
+moveBlock world locMap visited loc dir offset =
  case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == Just loc] of
    -- moving an empty space, so we're done
    [] -> Just (Map.fromList [(c,l) | (_,c,l) <- Map.elems visited])
@ -107,13 +110,16 @@ moveBlock world visited loc dir offset =
    -- moving a box
    (name,box):_ ->
      case nextLoc world dir loc offset of
+        -- block is exiting into the void; finish the move
        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 locMap visited loc loc' dir name box Set.empty offset'

 moveBlock' ::
    World ->
+    Map Location (Char, Box) ->
    Map Location (Int, Char, Maybe Location) ->
    Location ->
    Location ->
@ -123,31 +129,31 @@ moveBlock' ::
    Set Location ->
    Rational {- ^ offset -} ->
    Maybe (Map Char (Maybe Location))
-moveBlock' world visited loc loc' dir name box enters offset =
+moveBlock' world locMap visited loc loc' dir name box enters offset =
        msum [moveTo, moveInto, moveToEat]
      where
        moveTo =
-         do moveBlock world (addVisited name loc (Just loc') visited) loc' dir 0
+         do moveBlock world locMap (addVisited name loc (Just loc') visited) loc' dir 0

        moveInto =
-         do (n,b) <- boxAt world loc'
+         do (n,b) <- Map.lookup loc' locMap
            (locI, offset') <- enterLoc world n b dir offset
            if Set.member locI enters then
              moveEpsilon
            else
-              moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
+              moveBlock' world locMap visited loc locI dir name box (Set.insert locI enters) offset'

        moveEpsilon =
         do epsilon <- findEpsilon world (locName loc')
            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'
+            moveBlock' world locMap 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 name loc (Just loc') visited) loc' locE dir' name' box' Set.empty 0
+            (name', box') <- Map.lookup loc' locMap
+            moveBlock' world locMap (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 =
@ -158,9 +164,14 @@ enterLoc world name box dir@(dy,dx) offset =
        Infinity{} -> Nothing
        Epsilon {} -> Just name

-    let go y x = Just
+    let (bh, bw) = boxSize world box
+
+        -- moving on y axis crosses width face and vice versa
+        faceSize = abs dy * bw + abs dx * bh
+
+        go y x = Just
          (Location name' y x,
-           fromIntegral(boxSize world box) * offset
+           fromIntegral faceSize * offset
           - fromIntegral ((abs dy *x + abs dx*y)))

        ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
@ -172,12 +183,11 @@ enterLoc world name box dir@(dy,dx) offset =
      ( 0, 1) -> go (midpoint ylo yhi offset) xlo
      _ -> error "enterLoc: bad direction"

-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
+boxIx :: HasCallStack => World -> Char -> Box
+boxIx world name =
+  case Map.lookup name (worldBoxes world) of
+    Nothing -> error ("No such box: " ++ [name])
+    Just box -> box

 invert :: Movement -> Movement
 invert (dy,dx) = (-dy, -dx)
@ -206,9 +216,11 @@ nextLoc world (dy, dx) = go Set.empty
    | Just box <- Map.lookup b (worldBoxes world)
    , Set.notMember b visited
    , Just boxLoc <- boxLocation box
+    , let (bh,bw) = boxSize world box
+    , let faceSize = abs dy * bw + abs dx * bh
    = go (Set.insert b visited) boxLoc
    $ (offset + fromIntegral (abs dy*x+abs dx*y))
-      / fromIntegral (boxSize world box)
+    / fromIntegral faceSize

  go visited (Location b y x) offset
    | Set.member b visited
@ -226,3 +238,10 @@ findEpsilon :: World -> Char -> Maybe Char
 findEpsilon world b =
  listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
                  , Epsilon i _ <- [boxType box], i == b]
+
+worldLocations :: World -> Map Location (Char, Box)
+worldLocations world =
+  Map.fromList
+    [(loc, (n,box))
+       | (n, box) <- Map.assocs (worldBoxes world)
+       , loc <- maybeToList (boxLocation box)]
--- a/app/Parser.hs
+++ b/app/Parser.hs
@ -2,7 +2,7 @@ module Parser (parse) where

 import Control.Applicative
 import Control.Monad
-import Data.Array (Array, listArray)
+import Data.Array.Unboxed (UArray, listArray)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Graphics.Vty.Attributes
@ -21,7 +21,7 @@ parse str =
          p
          (Set.fromList (Map.findWithDefault [] '-' m))
          (head (m Map.! '='))
-          h w
+          (h, w)

 parseHeader :: ReadP (Char,Int,Int)
 parseHeader =
@ -107,7 +107,7 @@ parseColor =
      "green" -> pure (withForeColor defAttr green)
      _ -> empty

-walls :: [String] -> Array Coord Bool
+walls :: [String] -> UArray Coord Bool
 walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows))
  where
    width = length (head rows)
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@ -1,6 +1,6 @@
 module Rendering where

-import Data.Array
+import Data.Array.Unboxed
 import Data.Maybe
 import Data.Map (Map)
 import Data.Map qualified as Map
@ -8,7 +8,7 @@ import Data.Set qualified as Set
 import Data.List (intersperse, group)
 import Graphics.Vty

-import BigFont
+import BigFont ( bigText )
 import Model

 border :: Int
@ -39,14 +39,13 @@ home a h w  = vertCat $
  replicate (h-2) (string a ('║' : replicate (w-2) '░' ++ "║")) ++
  [string a ('╚' : replicate (w-2) '═' ++ "╝")]

-renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Int -> Image
+renderCell :: World -> Map Location (Char, Box) -> Char -> Box -> Int -> Int -> Int -> Int -> Image
 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'
+  | Just (n, box') <- Map.lookup (Location name' y x) locMap
+  = if h < fst (boxSize world box')
      then unit (boxColor box') h w n
      else renderBox world locMap box' n h w

@ -79,7 +78,7 @@ contentName world name box =
    Link     c -> c
    Infinity c -> contentName world c (boxIx world c)

-renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image
+renderBox :: World -> Map Location (Char, Box) -> Box -> Char -> Int -> Int -> Image
 renderBox world locMap box name boxh boxw =
  vertCat [
    horizCat [
@ -112,17 +111,16 @@ render flat world = picForLayers $
  (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 = worldLocations world

-renderFlat :: Map Location Char -> World -> [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)
  ]
  where
    borderAttr = defAttr `withForeColor` white `withBackColor` black
-    offset = max 0 ( (worldWidth world + 2*(2*border)+2 - imageWidth baseImage) `div` 2)
+    offset = max 0 ( (snd (worldSize world) + 2*(2*border)+2 - imageWidth baseImage) `div` 2)
    baseImage =
      pad 2 1 2 1 $
      horizCat $
@ -131,7 +129,7 @@ renderFlat locMap world =
      | (n,b) <- Map.assocs (worldBoxes world)
      , not (boxBoring b)]

-drawNestedWorld :: Map Location Char -> World -> Image
+drawNestedWorld :: Map Location (Char, Box) -> World -> Image
 drawNestedWorld locMap world =
    cropTop   (h + 2*border) $
    cropLeft  (w + 4*border) $
@ -163,8 +161,7 @@ drawNestedWorld locMap world =
    ]
  where
    infinityImage = makeInfinity h w
-    h = worldHeight world
-    w = worldWidth world
+    (h, w) = worldSize world

 makeInfinity :: Int -> Int -> Image
 makeInfinity h w = result
@ -186,7 +183,9 @@ makeInfinity h w = result
    result = foldr mkCol row colGaps
    mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest

-stackedLoc :: World -> Map Location Char -> Location -> Maybe Location
+-- | Covert a location on a block that might overflow into a location
+-- following block exits.
+stackedLoc :: World -> Map Location (Char, Box) -> Location -> Maybe Location
 stackedLoc world locMap = go Set.empty
  where
  go visited loc@(Location b y x)
@ -212,7 +211,7 @@ overflow (lo,hi) x
  | otherwise = 0

 fixup :: World ->
-  Map Location Char ->
+  Map Location (Char, Box) ->
  Int ->
  Int ->
  Int ->
@ -222,12 +221,12 @@ fixup :: World ->
 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)
+    Just (name, box) -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px)
      where
-        ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (boxIx world name))
+        ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)

 fixup1 :: Int -> Int -> Int -> Int -> Int
-fixup1 _ _ 0 i = i
+fixup1 lo hi 0 i = min hi (max lo i)
 fixup1 _ hi (-1) _ = hi
 fixup1 lo _ 1 _ = lo
 fixup1 _ _ _ _ = error "fixup1: bad delta"
--- a/levels/player18.txt
+++ b/levels/player18.txt
@ -1,51 +1,23 @@
-player u
+player u height 98 width 196
 block c yellow interesting
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓     ▓▓
-▓▓ c 1 ▓▓
-▓▓  u    
-▓▓ 2 3 ▓▓
-▓▓     ▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓▓▓▓▓▓▓
+▓     ▓
+▓ c 1 ▓
+▓  u   
+▓ 2 3 ▓
+▓     ▓
+▓▓▓▓▓▓▓
 block u magenta interesting
-▓▓▓▓ ▓▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓    -▓▓
-▓▓     ▓▓
-▓▓=    ▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓▓▓ ▓▓▓
+▓▓▓ ▓▓▓
+▓▓▓ ▓▓▓
+▓    -▓
+▓     ▓
+▓=    ▓
+▓▓▓▓▓▓▓
 block 1 blue boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓
 block 2 blue boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓  ▓▓▓▓
-▓▓▓▓▓ ▓▓▓
-▓▓▓▓ ▓▓▓▓
-▓▓▓ ▓▓▓▓▓
-▓▓▓   ▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓
 block 3 blue boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓   ▓▓▓
-▓▓▓▓▓ ▓▓▓
-▓▓▓▓  ▓▓▓
-▓▓▓▓▓ ▓▓▓
-▓▓▓   ▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓