refactor rendering
This commit is contained in:
Eric Mertens
parent
7f236b0fe2
commit
77a31583f4
35
app/Model.hs
35
app/Model.hs
|
|
@ -34,6 +34,7 @@ makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
|
|||
(xlo,xhi) = mkRange w
|
||||
(ylo,yhi) = mkRange h
|
||||
|
||||
mkRange :: Int -> (Int,Int)
|
||||
mkRange n = (- (n-1)`div`2, n`div`2)
|
||||
|
||||
boxSize :: Box -> Int
|
||||
|
|
@ -42,6 +43,7 @@ boxSize box = yhi-ylo+1
|
|||
((ylo,_),(yhi,_)) = bounds (boxWalls box)
|
||||
|
||||
|
||||
solid :: Int -> Array Coord Bool
|
||||
solid n = makeWalls (replicate n (replicate n 'x'))
|
||||
|
||||
-- Move an object
|
||||
|
|
@ -79,11 +81,11 @@ moveBlock ::
|
|||
Maybe (Map Location Location)
|
||||
|
||||
-- moving into a wall, not possible
|
||||
moveBlock world visited loc _
|
||||
moveBlock world _ loc _
|
||||
| isWall loc world = Nothing
|
||||
|
||||
-- move introduced a loop, trim off the tail and report success
|
||||
moveBlock world visited loc _
|
||||
moveBlock _ visited loc _
|
||||
| Just (n,_) <- Map.lookup loc visited
|
||||
= Just (fmap snd (Map.filter (\(a,_)->a >= n) visited))
|
||||
|
||||
|
|
@ -98,18 +100,27 @@ moveBlock world visited loc dir =
|
|||
guard (not (isWall loc' world))
|
||||
moveBlock' world visited loc loc' dir name box
|
||||
|
||||
moveBlock' ::
|
||||
World ->
|
||||
Map Location (Int, Location) ->
|
||||
Location ->
|
||||
Location ->
|
||||
Movement ->
|
||||
Char ->
|
||||
Box ->
|
||||
Maybe (Map Location Location)
|
||||
moveBlock' world visited loc loc' dir name box =
|
||||
msum [moveTo loc', moveInto loc', moveToEat loc']
|
||||
msum [moveTo, moveInto, moveToEat]
|
||||
where
|
||||
moveTo loc' =
|
||||
moveTo =
|
||||
do moveBlock world (addVisited loc loc' visited) loc' dir
|
||||
|
||||
moveInto loc' =
|
||||
moveInto =
|
||||
do (n,b) <- boxAt world loc'
|
||||
let locI = enterLoc n b dir
|
||||
moveBlock' world visited loc locI dir name box -- beware epsilon!
|
||||
|
||||
moveToEat loc' =
|
||||
moveToEat =
|
||||
do let dir' = invert dir
|
||||
let locE = enterLoc name box dir'
|
||||
(name', box') <- boxAt world loc'
|
||||
|
|
@ -130,21 +141,29 @@ boxAt :: World -> Location -> Maybe (Char, Box)
|
|||
boxAt world loc =
|
||||
listToMaybe [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc]
|
||||
|
||||
invert :: Movement -> Movement
|
||||
invert (dy,dx) = (-dy, -dx)
|
||||
|
||||
midpoint :: Int -> Int -> Int
|
||||
midpoint lo hi = (hi+lo)`div`2
|
||||
|
||||
addVisited ::
|
||||
Location {- ^ start -} ->
|
||||
Location {- ^ end -} ->
|
||||
Map Location (Int, Location) ->
|
||||
Map Location (Int, Location)
|
||||
addVisited k v m = Map.insert k (Map.size m, v) m
|
||||
|
||||
nextLoc :: World -> Location -> (Int, Int) -> Maybe Location
|
||||
nextLoc world loc (dy, dx) = go Set.empty loc
|
||||
where
|
||||
|
||||
go visited (Location b y x)
|
||||
go _ (Location b y x)
|
||||
| Just box <- Map.lookup b (worldBoxes world)
|
||||
, inRange (bounds (boxWalls box)) (y+dy, x+dx)
|
||||
= Just (Location b (y+dy) (x+dx))
|
||||
|
||||
go visited (Location b y x)
|
||||
go visited (Location b _ _)
|
||||
| Just box <- Map.lookup b (worldBoxes world)
|
||||
, Set.notMember b visited
|
||||
= go (Set.insert b visited) (boxLocation box)
|
||||
|
|
|
|||
|
|
@ -5,52 +5,36 @@ import Data.Map (Map)
|
|||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Graphics.Vty
|
||||
import Data.List (intersperse)
|
||||
|
||||
import Model
|
||||
|
||||
renderBox :: World -> Map Location Char -> Box -> Char -> Image
|
||||
renderBox world locMap box boxName =
|
||||
unit :: Attr -> Int -> Char -> Image
|
||||
unit a scale x =
|
||||
vertCat (replicate scale (string a (replicate (2*scale) x)))
|
||||
|
||||
renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image
|
||||
renderCell world locMap name box y x scale =
|
||||
if boxWalls box ! (y,x) then unit (boxColor box) scale '▓'
|
||||
else case Map.lookup (Location name y x) locMap of
|
||||
Nothing -> unit (boxColor box) scale '░'
|
||||
Just n ->
|
||||
if scale == 1
|
||||
then unit (boxColor (worldBoxes world Map.! n)) scale n
|
||||
else renderBox world locMap (worldBoxes world Map.! n) n
|
||||
(scale `div` boxSize box)
|
||||
|
||||
renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Image
|
||||
renderBox world locMap box name scale =
|
||||
vertCat
|
||||
[
|
||||
horizCat
|
||||
[
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location boxName y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> unit (boxColor (worldBoxes world Map.! n)) n
|
||||
| x <- [xlo .. xhi]
|
||||
]
|
||||
|
||||
| let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
|
||||
, let myAttr = boxColor box
|
||||
, y <- [ylo .. yhi]
|
||||
, let unit a x = string a [x,x]
|
||||
]
|
||||
|
||||
renderBox' :: World -> Map Location Char -> Box -> Char -> Int -> Image
|
||||
renderBox' world locMap box boxName scale
|
||||
| scale == 1 = renderBox world locMap box boxName
|
||||
| otherwise =
|
||||
vertCat
|
||||
[
|
||||
horizCat
|
||||
[
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location boxName y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> renderBox' world locMap box' n (scale `div` boxSize box)
|
||||
where
|
||||
box' = worldBoxes world Map.! n
|
||||
renderCell world locMap name box y x scale
|
||||
| x <- [xlo .. xhi]
|
||||
]
|
||||
| let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
|
||||
, let myAttr = boxColor box
|
||||
, y <- [ylo .. yhi]
|
||||
]
|
||||
where
|
||||
unit a x =
|
||||
vertCat (replicate scale (string a (replicate (2*scale) x)))
|
||||
|
||||
|
||||
drawNestedWorld :: World -> Image
|
||||
|
|
@ -62,26 +46,17 @@ drawNestedWorld world =
|
|||
cropRight (2*(2*49 + border)) $
|
||||
vertCat [
|
||||
horizCat [
|
||||
case stackedLoc world (Location name1 y x) of
|
||||
Nothing -> unit (withForeColor defAttr black) '?'
|
||||
case stackedLoc world (Location name1 y_ x_) of
|
||||
Nothing -> unit (withForeColor defAttr black) 49 '?'
|
||||
Just (Location n y x) ->
|
||||
let box = worldBoxes world Map.! n
|
||||
myAttr = boxColor box in
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location n y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> renderBox' world locMap box' n (49 `div` boxSize box)
|
||||
where
|
||||
box' = worldBoxes world Map.! n
|
||||
| x <- [x1-1 .. x1+1]
|
||||
let box = worldBoxes world Map.! n in
|
||||
renderCell world locMap n box y x 49
|
||||
| x_ <- [x1-1 .. x1+1]
|
||||
]
|
||||
| y <- [y1-1 .. y1+1]
|
||||
| y_ <- [y1-1 .. y1+1]
|
||||
]
|
||||
|
||||
where
|
||||
border = 20
|
||||
unit a x =
|
||||
vertCat (replicate 49 (string a (replicate (2*49) x)))
|
||||
locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
|
||||
|
||||
-- name1 is the box the player is standing in
|
||||
|
|
@ -89,17 +64,6 @@ drawNestedWorld world =
|
|||
|
||||
Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0)
|
||||
|
||||
drawWorld :: World -> Image
|
||||
drawWorld world =
|
||||
horizCat $
|
||||
intersperse (char defAttr ' ')
|
||||
[
|
||||
renderBox world locMap box boxName
|
||||
| (boxName, box) <- Map.toList (worldBoxes world)
|
||||
]
|
||||
where
|
||||
locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
|
||||
|
||||
|
||||
stackedLoc :: World -> Location -> Maybe Location
|
||||
stackedLoc world = go Set.empty
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user