cleaner model
This commit is contained in:
Eric Mertens
parent
a67bbea3cb
commit
2dbf578d33
109
app/Model.hs
109
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)]
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
▓▓▓▓▓▓▓▓▓
|
||||
▓▓▓▓▓▓▓▓▓
|
||||
▓▓▓ ▓▓▓
|
||||
▓▓▓▓▓ ▓▓▓
|
||||
▓▓▓▓ ▓▓▓
|
||||
▓▓▓▓▓ ▓▓▓
|
||||
▓▓▓ ▓▓▓
|
||||
▓▓▓▓▓▓▓▓▓
|
||||
▓▓▓▓▓▓▓▓▓
|
||||
▓
|
||||
|
||||
Loading…
Reference in New Issue
Block a user