parabox/app/Rendering.hs

module Rendering where

import Data.Array
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
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)))

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

button :: Attr -> Int -> Int -> Image
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 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 -> 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'
      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 -> 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 ::
  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 ] ++
  [ pad 94 7 0 0 $
    vertCat (map (string defAttr) (bigText "VOIDED"))
  | isNothing (boxLocation (boxIx world (worldMe world))) ] ++
  (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)]

renderFlat :: Map Location Char -> 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)
    baseImage =
      pad 2 1 2 1 $
      horizCat $
      intersperse (char borderAttr ' ')
      [renderBox world locMap b n 18 36
      | (n,b) <- Map.assocs (worldBoxes world)
      , not (boxBoring b)]

drawNestedWorld :: Map Location Char -> World -> Image
drawNestedWorld locMap world =
    cropTop   (h + 2*border) $
    cropLeft  (w + 4*border) $
    cropBottom (2*h + border) $
    cropRight  (2*(w + border)) $
    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
    infinityImage = makeInfinity h w
    h = worldHeight world
    w = worldWidth 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

stackedLoc :: World -> Map Location Char -> 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 ->
  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 (boxIx world name))

fixup1 :: Int -> Int -> Int -> Int -> Int
fixup1 _ _ 0 i = 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]
  ]