loop/src/Dodge/Render/List.hs

{-# LANGUAGE LambdaCase #-}

module Dodge.Render.List (
    renderListAt,
    drawList,
    drawSelectionList,
    drawSelectionListBackground,
    drawListYgapScaleYoff,
    drawListElement,
    dShadCol,
    drawListYoff,
    stackPicturesAt,
    toTopLeft,
    listCursorChooseBorderScale,
    selSecDrawCursor,
    drawTitleBackground, -- should be renamed, made sensible
    drawCursorAt,
    drawLabelledList,
) where

import Data.Maybe
import Dodge.Base.Window
import Dodge.Data.CardinalPoint
import Dodge.Data.Config
import Dodge.Data.HUD
import Dodge.Data.SelectionList
import Dodge.ListDisplayParams
import Dodge.ScreenPos
import Dodge.SelectionSections
import Geometry
import LensHelp
import ListHelp
import Picture

drawSelectionList :: LDParams -> Config -> [SelectionItem a] -> Picture
drawSelectionList ldps cfig sl =
    translateScreenPos cfig (ldps ^. ldpPos) $
        drawListYgapScaleYoff ygap sf 0 (makeSelectionListPictures sl)
            <> foldMap (g . f) (ldps ^. ldpBorder)
  where
    g xs = color white (polygonWire xs) <> setDepth 0.5 (polygon xs)
    ygap = ldps ^. ldpVerticalGap
    sf = ldps ^. ldpScale
    f (x, y) =
        rectNSWE
            5
            (negate $ (20 * sf + ygap) * fromIntegral y + 5)
            (-5)
            (10 * sf * fromIntegral x)

drawTitleBackground :: Config -> Picture
drawTitleBackground cfig =
    translateScreenPos cfig (fromTopLeft (V2 (subInvX - 5) 75))
        . polygon
        . reverse
        $ rectNSWE 70 0 0 560

drawSelectionListBackground ::
    LDParams ->
    Config ->
    Int -> -- list length
    Picture
drawSelectionListBackground ldp cfig l =
    translateScreenPos cfig (ldp ^. ldpPos)
        . polygon
        . reverse
        $ rectNSWE 5 s (-5) e
  where
    s = -(5 + fromIntegral l * (20 * ldp ^. ldpScale + ldp ^. ldpVerticalGap))
    e = 555 -- HACK isOverTerminalScreen

makeSelectionListPictures :: [SelectionItem a] -> [Picture]
makeSelectionListPictures = concatMap f
  where
    f si = map (color (_siColor si) . text) $ _siPictures si

-- note this does not take into account any selectionsection indent
drawCursorAt ::
    Maybe Int -> [SelectionItem a] -> LDParams -> Int -> CursorDisplay -> Picture
drawCursorAt mi lis ldps width curs = fromMaybe mempty $ do
    i <- mi
    selit <- lis !? i
    return $
        listCursorChooseBorderScale
            (_ldpVerticalGap ldps)
            (_ldpScale ldps)
            curs
            (sum . map _siHeight $ take i lis)
            (_siOffX selit)
            (_siColor selit)
            width
            (_siHeight selit)

drawListYoff :: Int -> [Picture] -> Picture
drawListYoff = drawListYgapScaleYoff 0 1

drawListYgapScaleYoff :: Float -> Float -> Int -> [Picture] -> Picture
drawListYgapScaleYoff ygap s i = mconcat . zipWith (drawListElement ygap s 0) [i ..]

stackPicturesAt :: [Picture] -> Picture
stackPicturesAt = stackPicturesAtOff 0

stackPicturesAtOff :: Int -> [Picture] -> Picture
stackPicturesAtOff i = mconcat . zipWith (drawListElement 10 1 0) [i, i - 1 ..]

selSecDrawCursor :: LDParams -> CursorDisplay -> IMSS a -> Selection -> Picture
selSecDrawCursor ldp curs sss sel = fold $ do
    let i = sel ^. slSec
        j = sel ^. slInt
    yint <- selSecYint i j sss
    sindent <- sss ^? ix i . ssIndent
    si <- sss ^? ix i . ssItems . ix j
    return $
        listCursorChooseBorderScale
            (ldp ^. ldpVerticalGap)
            (ldp ^. ldpScale)
            curs
            yint
            (_siOffX si + sindent)
            (_siColor si)
            (_siWidth si)
            (_siHeight si)

-- displays a cursor that should match up to list text pictures
listCursorChooseBorderScale ::
    Float ->
    Float ->
    CursorDisplay ->
    Int ->
    Int ->
    Color ->
    Int ->
    Int ->
    Picture
listCursorChooseBorderScale ygap s curs yint xint col cursxsize cursysize =
    translate
        ((10 * fromIntegral xint - 5) * s)
        (-(ygap + (s * 20 + ygap) * fromIntegral yint))
        . color col
        $ chooseCursorBorders (s * wth) (s * hgt) curs
  where
    wth = 10 * (fromIntegral cursxsize + 1)
    hgt = 20 * fromIntegral cursysize + ygap * (fromIntegral cursysize - 1)

-- note we cannot simply scale lines because they are drawn as solid rectangles
chooseCursorBorders :: Float -> Float -> CursorDisplay -> Picture
chooseCursorBorders w h = \case
    BoundaryCursor ps -> foldMap (line . toLine) ps
    BackdropCursor -> polygon $ rectNSWE 0 h' 0 w
  where
    h' = negate h
    toLine North = [V2 0 0, V2 w 0]
    toLine East = [V2 w 0, V2 w h']
    toLine South = [V2 w h', V2 0 h']
    toLine West = [V2 0 h', V2 0 0]

-- fillScreenText :: Config -> String -> Picture
-- fillScreenText cfig str =
--    scale wscale hscale
--        . centerText
--        $ str
--  where
--    wscale = hw * 0.02 / fromIntegral (length str)
--    hscale = hh * 0.01
--    hw = halfWidth cfig
--    hh = halfHeight cfig

-- fillWidthText :: Config -> String -> Picture
-- fillWidthText cfig str =
--    scale thescale thescale
--        . centerText
--        $ str
--  where
--    thescale = hw * 0.02 / fromIntegral (length str)
--    hw = halfWidth cfig

drawListElement :: Float -> Float -> Int -> Int -> Picture -> Picture
drawListElement ygap s xint yint =
    translate (s * 10 * fromIntegral xint) (negate ((s * 20 + ygap) * (fromIntegral yint + 1)))
        . scale (s * 0.1) (s * 0.1)

renderListAt :: Float -> Float -> [(String, Color)] -> Picture
renderListAt tx ty =
    translate tx (-ty)
        . drawList
        . map (\(str, col) -> color col $ text str)

-- inverseText :: String -> Color -> Picture
-- inverseText str col =
--    translate3 (V3 0 0 (0.5))
--    (color (V4 0 1 0 0.1) ( text str))
--    <>
--    translate3 (V3 0 0 (0.4))
--    (color col (polygon [0,V2 l 0, V2 l 200, V2 0 200]))
--  where
--    l = 100 * fromIntegral (length str)

-- given a list of pictures that are each the size of a "text" call, displays them as
-- a list on the screen
drawList :: [Picture] -> Picture
drawList = drawListYgapScaleYoff 0 1 0

drawLabelledList :: [(String, [String])] -> Picture
drawLabelledList ((s, ss) : xs) =
    translate (-10) 0 (drawListYgapScaleYoff 0 1 0 [textJustifyRight s])
        <> drawListYgapScaleYoff 0 1 0 (text <$> ss)
        <> translate 0 (negate $ fromIntegral (max 1 $ length ss) * 20) (drawLabelledList xs)
drawLabelledList [] = mempty

-- TODO put the following functions in an appropriate place

-- | Colour picture and add black drop shadow.
dShadCol :: Color -> Picture -> Picture
{-# INLINE dShadCol #-}
dShadCol c p = color black (translate 1.2 (-1.2) p) <> color c p

toTopLeft :: Config -> Picture -> Picture
toTopLeft cfig = translate (-halfWidth cfig) (halfHeight cfig)