parabox/app/Rendering.hs

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