256 lines
8.8 KiB
Haskell
256 lines
8.8 KiB
Haskell
module Rendering where
|
|
|
|
import Data.Array.Unboxed
|
|
import Data.Maybe
|
|
import Data.Map (Map)
|
|
import Data.Map qualified as Map
|
|
import Data.Set qualified as Set
|
|
import Data.List (intersperse, group)
|
|
import Graphics.Vty
|
|
|
|
import BigFont ( bigText )
|
|
import Model
|
|
|
|
border :: Int
|
|
border = 20
|
|
|
|
unit :: Attr -> Int -> Int -> Char -> Image
|
|
unit a h w c =
|
|
vertCat (replicate h (string a (replicate w c)))
|
|
|
|
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 1 = char a '□'
|
|
button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
|
|
button a h w = vertCat $
|
|
string a ('┌' : replicate (w-2) '─' ++ "┐") :
|
|
replicate (h-2) (string a ('│' : replicate (w-2) '░' ++ "│")) ++
|
|
[string a ('└' : replicate (w-2) '─' ++ "┘")]
|
|
|
|
home :: Attr -> Int -> Int -> Image
|
|
home a 1 1 = char a '⊞'
|
|
home a 1 w = string a ("<" ++ replicate (w-2) '=' ++ ">")
|
|
home a h w = vertCat $
|
|
string a ('╔' : replicate (w-2) '═' ++ "╗") :
|
|
replicate (h-2) (string a ('║' : replicate (w-2) '░' ++ "║")) ++
|
|
[string a ('╚' : replicate (w-2) '═' ++ "╝")]
|
|
|
|
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, 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
|
|
|
|
| Set.member loc (worldButtons world) = button (boxColor box) h w
|
|
|
|
| loc == worldHome world = home (boxColor box) h w
|
|
|
|
| otherwise = unit (boxColor box) h w floorChar
|
|
where
|
|
loc = Location name' y x
|
|
name' = contentName world name box
|
|
wallChar =
|
|
case boxType box of
|
|
Original {} -> '▓'
|
|
Link {} -> '▒'
|
|
Infinity {} -> '▓'
|
|
Epsilon {} -> '▓'
|
|
floorChar =
|
|
case boxType box of
|
|
Original {} -> '░'
|
|
Link {} -> '·'
|
|
Infinity {} -> '∞'
|
|
Epsilon {} -> 'ε'
|
|
|
|
contentName :: World -> Char -> Box -> Char
|
|
contentName world name box =
|
|
case boxType box of
|
|
Original{} -> name
|
|
Epsilon{} -> name
|
|
Link c -> c
|
|
Infinity c -> contentName world c (boxIx world c)
|
|
|
|
renderBox :: World -> Map Location (Char, Box) -> Box -> Char -> Int -> Int -> Image
|
|
renderBox world locMap box name boxh boxw =
|
|
vertCat [
|
|
horizCat [
|
|
renderCell world locMap name box y x cellh cellw
|
|
| (x,cellw) <- zip [xlo .. xhi] xdivs ]
|
|
| (y,cellh) <- zip [ylo .. yhi] ydivs ]
|
|
where
|
|
ydivs = divisions boxHeight boxh
|
|
xdivs = divisions boxWidth boxw
|
|
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
|
|
boxWidth = xhi - xlo + 1
|
|
boxHeight = yhi - ylo + 1
|
|
|
|
render ::
|
|
DisplayRegion ->
|
|
Bool {- ^ show flat overlay -} ->
|
|
World ->
|
|
Picture
|
|
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 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 =
|
|
[wrapBox borderAttr baseImage | not (null components)]
|
|
where
|
|
borderAttr = defAttr `withForeColor` white `withBackColor` black
|
|
baseImage = horizCat components
|
|
components =
|
|
[renderBox world locMap b n 18 36
|
|
| (n,b) <- Map.assocs (worldBoxes world)
|
|
, not (boxBoring b)]
|
|
|
|
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 ' ')
|
|
[
|
|
horizCat $
|
|
intersperse (char defAttr ' ')
|
|
[
|
|
case myLocation world of
|
|
Nothing
|
|
| dx==0 && dy==0 -> renderBox world locMap (boxIx world (worldMe world)) (worldMe world) h w
|
|
| otherwise -> infinityImage
|
|
Just (Location name0 _ _) ->
|
|
case boxLocation (boxIx world name0) of
|
|
Nothing
|
|
| dx==0 && dy==0 -> renderBox world locMap (boxIx world 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) ->
|
|
renderCell world locMap n (boxIx world n) y x h w
|
|
| dx <- [-1 .. 1]
|
|
]
|
|
| 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
|
|
|
|
makeInfinity :: Int -> Int -> Image
|
|
makeInfinity h w = result
|
|
where
|
|
attr = defAttr `withForeColor` black
|
|
single = vertCat (map (string attr) (bigText "?"))
|
|
|
|
rowN = (w+1) `div` (imageWidth single + 1)
|
|
rowTotalGap = w - rowN * imageWidth single
|
|
rowGaps = divisions (rowN-1) rowTotalGap
|
|
|
|
row = foldr mkRow single rowGaps
|
|
mkRow gap rest = single <|> charFill attr ' ' gap 1 <|> rest
|
|
|
|
colN = (h+1) `div` (imageHeight single + 1)
|
|
colTotalGap = h - colN * imageHeight single
|
|
colGaps = divisions (colN-1) colTotalGap
|
|
|
|
result = foldr mkCol row colGaps
|
|
mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest
|
|
|
|
-- | 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)
|
|
| Set.member loc visited =
|
|
do b' <- findInfinity world b
|
|
go visited (Location b' y x)
|
|
|
|
go visited loc@(Location b y x) =
|
|
do box <- Map.lookup b (worldBoxes world)
|
|
let bnds@((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
|
|
if inRange bnds (y, x)
|
|
then Just loc
|
|
else
|
|
do let dx = overflow (xlo,xhi) x
|
|
dy = overflow (ylo,yhi) y
|
|
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
|
|
| x < lo = x - lo
|
|
| x > hi = x - hi
|
|
| otherwise = 0
|
|
|
|
fixup :: World ->
|
|
Map Location (Char, Box) ->
|
|
Int ->
|
|
Int ->
|
|
Int ->
|
|
Int ->
|
|
Location ->
|
|
Location
|
|
fixup world locMap dy dx py px loc =
|
|
case Map.lookup loc locMap of
|
|
Nothing -> loc
|
|
Just (name, box) -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px)
|
|
where
|
|
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
|
|
|
|
fixup1 :: Int -> Int -> Int -> Int -> Int
|
|
fixup1 lo hi 0 i = min hi (max lo i)
|
|
fixup1 _ hi (-1) _ = hi
|
|
fixup1 lo _ 1 _ = lo
|
|
fixup1 _ _ _ _ = error "fixup1: bad delta"
|
|
|
|
divisions ::
|
|
Int {- ^ result length -} ->
|
|
Int {- ^ result sum -} ->
|
|
[Int]
|
|
divisions divs size =
|
|
map length $ group
|
|
[ round (
|
|
(fromIntegral i + 1 / 2)
|
|
/ fromIntegral size
|
|
* fromIntegral divs
|
|
- 1/2 :: Rational
|
|
) :: Int
|
|
| i <- [0 ..size-1]
|
|
]
|