parabox/app/Rendering.hs

module Rendering where

import Data.Array
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.List (intersperse)
import Graphics.Vty

import Model

border :: Int
border = 20

unit :: Attr -> Int -> Char -> Image
unit a scale x =
    vertCat (replicate scale (string a (replicate (2*scale) x)))

drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image
drawBox a _ 1 = string a "[]"
drawBox a w h = vertCat $
  string a ('┌' : replicate (w-2) '─' ++ "┐") :
  replicate (h-2) (string a ('│' : replicate (w-2) ' ' ++ "│")) ++
  [string a ('└' : replicate (w-2) '─' ++ "┘")]

button :: Attr -> Int -> Image
button a 1 = string a "[]"
button a n = vertCat $
  string a ('┌' : replicate (2*n-2) '─' ++ "┐") :
  replicate (n-2) (string a ('│' : replicate (2*n-2) '░' ++ "│")) ++
  [string a ('└' : replicate (2*n-2) '─' ++ "┘")]

home :: Attr -> Int -> Image
home a 1 = string a "<>"
home a n = vertCat $
  string a ('╔' : replicate (2*n-2) '═' ++ "╗") :
  replicate (n-2) (string a ('║' : replicate (2*n-2) '░' ++ "║")) ++
  [string a ('╚' : replicate (2*n-2) '═' ++ "╝")]

renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image
renderCell world locMap name box y x scale =
    if boxWalls world box ! (y,x) then unit (boxColor box) scale wallChar
      else case Map.lookup (Location name' y x) locMap of
        Just n ->
            if scale < 9
                then unit (boxColor (worldBoxes world Map.! n)) scale n 
                else renderBox world locMap (worldBoxes world Map.! n) n
                        (scale `div` boxSize world box)
        Nothing
          | Set.member loc (worldButtons world) -> button (boxColor box) scale
          | loc == worldHome world -> home (boxColor box) scale
          | otherwise -> unit (boxColor box) scale '░'
    where
      loc = Location name' y x
      name' =
          case boxType box of
              Original{} -> name
              Link c -> c
      wallChar =
          case boxType box of
              Original{} -> '▓'
              Link{} -> '▒'

renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Image
renderBox world locMap box name scale =
  vertCat [
    horizCat [
      renderCell world locMap name box y x scale
      | x <- [xlo .. xhi]
    ]
    | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
    , y <- [ylo .. yhi]
  ]

render ::
  Bool {- ^ show flat overlay -} ->
  World ->
  Picture
render flat world = picForLayers $
  [ pad 98 12 0 0 $
    string defAttr "██╗    ██╗██╗███╗   ██╗███╗   ██╗███████╗██████╗ " <->
    string defAttr "██║    ██║██║████╗  ██║████╗  ██║██╔════╝██╔══██╗" <->
    string defAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗  ██████╔╝" <->
    string defAttr "██║███╗██║██║██║╚██╗██║██║╚██╗██║██╔══╝  ██╔══██╗" <->
    string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║  ██║" <->
    string defAttr " ╚══╝╚══╝ ╚═╝╚═╝  ╚═══╝╚═╝  ╚═══╝╚══════╝╚═╝  ╚═╝"
  | winCondition world ] ++
  (if flat then renderFlat locMap world else []) ++
  [drawNestedWorld locMap world]
  where
    locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]

renderFlat :: Map Location Char -> World -> [Image]
renderFlat locMap world =
  [ pad offset 0 0 0 baseImage
  , pad offset 0 0 0 $ drawBox borderAttr (imageWidth baseImage) (imageHeight baseImage)
  ]
  where
    borderAttr = defAttr `withForeColor` white `withBackColor` black
    offset = max 0 ( (2*(81+2*border)+2 - imageWidth baseImage) `div` 2)
    baseImage =
      pad 2 1 2 1 $
      horizCat $
      intersperse (char borderAttr ' ')
      [renderBox world locMap b n 2
      | (n,b) <- Map.assocs (worldBoxes world)
      , not (boxBoring b)]

drawNestedWorld :: Map Location Char -> World -> Image
drawNestedWorld locMap world =
    -- (3*81) + 81 + (3*81)
    cropTop   (81 + 2*border) $
    cropLeft  (2*(81 + 2*border)) $
    cropBottom (2*81 + border) $
    cropRight  (2*(2*81 + border)) $
    vertCat $
    intersperse (char defAttr ' ')
    [
        horizCat $
        intersperse (char defAttr ' ')
         [
            case stackedLoc world locMap (Location name1 y_ x_) of
                Nothing -> unit (withForeColor defAttr black) 81 '?'
                Just (Location n y x) ->
                    let box = worldBoxes world Map.! n in
                    renderCell world locMap n box y x 81
        | x_ <- [x1-1 .. x1+1]
        ]
        | y_ <- [y1-1 .. y1+1]
    ]
  where
    -- 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
  where
  go visited loc | Set.member loc visited = Nothing

  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 
            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))


overflow :: (Int, Int) -> Int -> Int
overflow (lo,hi) x
  | x < lo = x - lo
  | x > hi = x - hi
  | otherwise = 0

fixup :: World -> 
  Map Location Char -> 
  Int -> 
  Int -> 
  Int -> 
  Int -> 
  Location -> 
  Location
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)
      where
        ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (worldBoxes world Map.! name))

fixup1 :: Int -> Int -> Int -> Int -> Int
fixup1 _ _ 0 i = i
fixup1 _ hi (-1) _ = hi
fixup1 lo _ 1 _ = lo
fixup1 _ _ _ _ = error "fixup1: bad delta"