Files
loop/src/Dodge/Render/HUD.hs
T
2025-12-24 16:49:51 +00:00

500 lines
18 KiB
Haskell

{-# LANGUAGE LambdaCase #-}
module Dodge.Render.HUD (drawHUD) where
import Control.Applicative
import Control.Lens
import Control.Monad
import qualified Data.IntSet as IS
import Data.List (elemIndex)
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Vector as V
-- import qualified Data.Vector as V
import Dodge.Base
import Dodge.CharacterEnums
import Dodge.Clock
-- import Dodge.Clock
import Dodge.Creature.Info
import Dodge.Creature.Test
import Dodge.Data.CardinalPoint
import Dodge.Data.Combine
import Dodge.Data.Config
import Dodge.Data.DoubleTree
import Dodge.Data.EquipType
import Dodge.Data.SelectionList
import Dodge.Data.Terminal.Status
import Dodge.Data.World
import Dodge.DoubleTree
import Dodge.Equipment.Text
import Dodge.Inventory
import Dodge.Inventory.CheckSlots
import Dodge.Item.Display
import Dodge.Item.Grammar
import Dodge.Item.Info
import Dodge.Item.InvSize
import Dodge.Item.Location
import Dodge.ListDisplayParams
import Dodge.Render.Connectors
import Dodge.Render.List
import Dodge.ScreenPos
import Dodge.SelectionSections
import Dodge.SelectionSections.Draw
import Dodge.Terminal
import Dodge.Terminal.Type
import Geometry
import qualified IntMapHelp as IM
import Justify
import Linear
import NewInt
import Picture
import SDL (MouseButton (..))
drawHUD :: Config -> World -> Picture
drawHUD cfig w =
drawInventory sections w cfig subinv
<> drawSubInventory subinv cfig w
where
sections = w ^. hud . diSections
subinv = w ^. hud . subInventory
drawInventory :: IMSS () -> World -> Config -> SubInventory -> Picture
drawInventory sss w cfig = \case
DisplayTerminal{} ->
drawSelectionSections sss invDP cfig
<> itemconnections
<> drawMouseOver cfig w
_ ->
drawSelectionSections sss invDP cfig
<> foldMap (drawSSCursor sss invDP curs cfig) (w ^. hud . diSelection)
<> drawRootCursor w sss (w ^. hud . diSelection) invDP cfig
<> itemconnections
<> drawMouseOver cfig w
where
curs = invCursorParams w
itemconnections = fromMaybe mempty $ do
inv' <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
let inv = fmap (\k -> w ^?! cWorld . lWorld . items . ix k) inv'
case w ^? hud . diInvFilter . _Just of
Just (_ : _) -> Nothing
_ -> return . drawItemConnections sss cfig $ invAdj inv
drawRootCursor ::
World -> IMSS () -> Maybe Selection -> LDParams -> Config -> Picture
drawRootCursor w sss msel ldp cfig = fromMaybe mempty $ do
cr <- w ^? cWorld . lWorld . creatures . ix 0
guard $ crIsAiming cr
i <- msel ^? _Just . slSec
j <- msel ^? _Just . slInt
guard $ i == 0
inv' <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
let inv = fmap (\k -> w ^?! cWorld . lWorld . items . ix k) inv'
(x, y) <- getRootItemBounds j $ _unNIntMap inv
return $
drawSSMultiCursor
sss
(Just (0, x))
(Just (y - x))
ldp
(BoundaryCursor [minBound ..])
cfig
getRootItemBounds :: Int -> IM.IntMap Item -> Maybe (Int, Int)
getRootItemBounds i inv = do
let ia = invIndents $ NIntMap inv -- why indents? why OItem?
itm <- ia ^? ix i . _2
let root = locToTop itm
x <- locDTRightmost root ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
y <- locDTLeftmost root ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
return (x, y)
drawMouseOver :: Config -> World -> Picture
drawMouseOver cfig w =
concat
(invsel <|> combinvsel <|> drawDragSelecting cfig w)
<> concat (drawDragSelected cfig w)
where
invsel = do
(j, i) <-
w ^? input . mouseContext . mcoInvSelect
<|> w ^? input . mouseContext . mcoInvFilt
sss <- w ^? hud . diSections
return
. translateScreenPos cfig (invDP ^. ldpPos)
. color (0.3 *^ white)
-- . color white
$ selSecDrawCursor invDP curs sss (Sel j i mempty)
-- curs = BoundaryCursor [West]
curs = BackdropCursor
combinvsel = do
(j, i) <-
(w ^? input . mouseContext . mcoCombSelect)
<|> (w ^? input . mouseContext . mcoCombCombine)
sss <- w ^? hud . subInventory . ciSections
let idp = secondColumnLDP
return
. translateScreenPos cfig (idp ^. ldpPos)
. color (0.3 * white)
$ selSecDrawCursor idp curs sss (Sel j i mempty)
drawDragSelected :: Config -> World -> Maybe Picture
drawDragSelected cfig w = do
ys <- w ^? hud . diSelection . _Just . slSet
guard $
not (IS.null ys)
&& ( case w ^? hud . subInventory of
Just NoSubInventory -> True
_ -> False
)
Sel i _ _ <- w ^? hud . diSelection . _Just
sss <- w ^? hud . diSections
let f x = (selSecDrawCursor invDP BackdropCursor sss (Sel i x mempty) <>)
return
. translateScreenPos cfig (invDP ^. ldpPos)
. color (0.2 *^ white)
. IS.foldr f mempty
$ ys
drawDragSelecting :: Config -> World -> Maybe Picture
drawDragSelecting cfig w = do
OverInvDragSelect (Just (i, j)) (Just b) <- w ^? input . mouseContext
sss <- w ^? hud . diSections
let f x = selSecDrawCursor invDP BackdropCursor sss (Sel i x mempty)
return
. translateScreenPos cfig (invDP ^. ldpPos)
. color (0.2 *^ white)
. foldMap f
$ [min j b .. max j b]
drawSubInventory :: SubInventory -> Config -> World -> Picture
drawSubInventory subinv cfig w = case subinv of
NoSubInventory{} -> drawRBOptions cfig w
ExamineInventory -> drawExamineInventory cfig w
DisplayTerminal tid -> drawTerminalDisplay w cfig tid
CombineInventory{_ciSections = sss} -> drawCombineInventory cfig sss w
MapperInventory _ _ itid -> drawMapperInventory itid w
drawMapperInventory :: NewInt ItmInt -> World -> Picture
drawMapperInventory itid w = fold $ do
itm <- w ^? pointerToItemID itid
ls <- itm ^? itUse . useMapperLines
let _ = w ^. wCam . camRot
return . color red $ foldMap (\(x, y) -> line [f x, f y]) ls
where
f = worldPosToScreen (w ^. wCam)
drawCombineInventory :: Config -> IMSS CombItem -> World -> Picture
drawCombineInventory cfig sss w =
drawSelectionSections sss secondColumnLDP cfig
<> foldMap (drawSSCursor sss secondColumnLDP curs cfig) msel
<> combineInventoryExtra sss msel cfig w
where
curs = BoundaryCursor [North, South, West]
msel = w ^? hud . subInventory . ciSelection . _Just
drawExamineInventory :: Config -> World -> Picture
drawExamineInventory cfig w =
invHead cfig "EXAMINE"
<> drawSelectionList
secondColumnLDP
cfig
( map
f
( makeParagraph 55 $
yourAugmentedItem
itemInfo
(yourInfo (you w))
(closeObjectInfo (crNumFreeSlots (w ^. cWorld . lWorld . items) (you w)))
w
)
)
where
f str =
SelItem
{ _siPictures = [str]
, _siWidth = 55
, _siHeight = 1
, _siIsSelectable = True
, _siColor = white
, _siOffX = 0
, _siPayload = Nothing
, _siDisplayMod = NoSIDisplayMod
}
closeObjectInfo :: Int -> Either Item Button -> String
closeObjectInfo n x = case x of
Left itm -> itemInfo itm ++ " It is on the floor" ++ floorItemPickupInfo n itm
Right _ -> "Some sort of switch or button."
floorItemPickupInfo :: Int -> Item -> String
floorItemPickupInfo n itm
| n >= itInvHeight itm = ", but you have space to pick it up."
| otherwise = ", and you don't have space to pick it up."
-- note the use of ^?!
-- it is probably desirable for this to crash hard for now
yourAugmentedItem :: (Item -> a) -> a -> (Either Item Button -> a) -> World -> a
yourAugmentedItem f x g w = case you w ^? crManipulation . manObject of
Just (SelectedItem i _ _) -> f $ yourInv w ^?! ix i
Just (SelCloseItem i) -> fromMaybe x $ do
j <- w ^? hud . closeItems . ix i . unNInt
flit <- w ^? cWorld . lWorld . items . ix j
return . g $ Left flit
Just (SelCloseButton i) -> fromMaybe x $ do
j <- w ^? hud . closeButtons . ix i
but <- w ^? cWorld . lWorld . buttons . ix j
return . g $ Right but
_ -> x
drawRBOptions :: Config -> World -> Picture
drawRBOptions cfig w = fold $ do
guard $ ButtonRight `M.member` _mouseButtons (_input w)
invid <- you w ^? crManipulation . manObject . imSelectedItem
itid <- you w ^? crInv . ix invid
eslist <-
fmap eqTypeToSites $
w ^? cWorld . lWorld . items . ix itid >>= equipType
i <- w ^? rbState . opSel
let ae = equipmentDesignation invid w
sss <- w ^? hud . diSections
Sel i' j _ <- w ^? hud . diSelection . _Just
curpos <- selSecYint i' j sss
let ytext = drawListElement 0 1 0 curpos . text
midstr = equipAllocString ae
extrastr = case ae of
SwapEquipment{_allocOldPos = oldp, _allocSwapID = sid} ->
"SWAPS " ++ otheritem sid ++ " ONTO " ++ eqPosText oldp
ReplaceEquipment{_allocRemoveID = rid} ->
"REMOVES " ++ otheritem rid
_ -> ""
return $
toTopLeft cfig $
translate 290 (-1) (ytext midstr)
<> translate
160
(-1)
( listCursorChooseBorderScale
0
1
(BoundaryCursor [North, South])
curpos
0
white
21
1
)
<> translate
380
(-1)
( drawListYoff (curpos - i) (map (text . eqPosText) eslist)
<> listCursorChooseBorderScale 0 1 (bc East) (curpos - i) 0 white 7 (length eslist)
<> listCursorChooseBorderScale 0 1 (bc West) (curpos + 1) 0 white 7 (length eslist - (i + 1))
<> listCursorChooseBorderScale 0 1 (bc West) (curpos - i) 0 white 7 i
<> maybetopborder i curpos
<> maybebottomborder i (length eslist) curpos
)
<> translate 460 (-1) (ytext extrastr)
where
bc x = BoundaryCursor [x]
maybetopborder 0 curpos = listCursorChooseBorderScale 0 1 (bc North) curpos 0 white 7 1
maybetopborder _ _ = mempty
maybebottomborder a b curpos
| a == b - 1 = listCursorChooseBorderScale 0 1 (bc South) curpos 0 white 7 1
| otherwise = mempty
otheritem (NInt j) = fromMaybe "" $ do
itype <- w ^? cWorld . lWorld . items . ix j . itType
return $ itemBaseName itype
equipAllocString :: EquipmentAllocation -> String
equipAllocString = \case
DoNotMoveEquipment -> ""
PutOnEquipment{} -> " PUT ON"
MoveEquipment{} -> " MOVE TO"
SwapEquipment{} -> " MOVE TO"
ReplaceEquipment{} -> " PUT ON"
RemoveEquipment{} -> "TAKE OFF"
drawItemConnections ::
IMSS () -> Config -> IM.IntMap (Maybe (Int, Int), [Int], [Int]) -> Picture
drawItemConnections sss cfig =
translate (negate 5) 0
. IM.foldMapWithKey (drawItemChildrenConnect sss cfig)
. fmap (\(_, a, b) -> a <> b)
drawItemChildrenConnect :: IMSS () -> Config -> Int -> [Int] -> Picture
drawItemChildrenConnect sss cfig i is = fromMaybe mempty $ do
p <- snum i
let ps = mapMaybe snum is
return $ color white $ lConnectMulti ps p
where
snum = selNumPos cfig invDP sss 0
combineInventoryExtra :: IMSS CombItem -> Maybe Selection -> Config -> World -> Picture
combineInventoryExtra sss msel cfig w = fold $ do
i <- msel ^? _Just . slSec
j <- msel ^? _Just . slInt
si <- sss ^? ix i . ssItems . ix j
let col = _siColor si
lnks <- si ^? siPayload . _Just . ciInvIDs
return (lnkMidPosInvSelsCol cfig w j col lnks) <> Just (foldMap invcursor lnks)
where
invcursor i =
translateScreenPos cfig (invDP ^. ldpPos) $
selSecDrawCursor
invDP
(BoundaryCursor [North, South, East, West])
(w ^. hud . diSections)
(Sel 0 i mempty)
drawTerminalDisplay :: World -> Config -> Int -> Picture
drawTerminalDisplay w cfig tid = fold $ do
tm <- w ^? cWorld . lWorld . terminals . ix tid
let toselitm (str, col) = SelItem [str] 1 55 True col 0 Nothing NoSIDisplayMod
f =
toselitm ("TERMINAL " ++ show tid, white)
: ( map (toselitm . (_1 %~ (" " <>)))
. displayTermInput
. reverse
$ _tmDisplayedLines tm
)
displayTermInput = case _tmStatus tm of
TerminalOff -> id
TerminalDeactivated -> id
TerminalLineRead -> (++ [(spincurs, termTextColor)])
TerminalTextInput s -> (++ [(getPromptTM ++ s ++ [cFilledRect], white)])
TerminalPressTo s -> (++ [(s, white)])
return $
drawSelectionList (secondColumnLDP & ldpBorder ?~ (49, 16)) cfig f
<> drawTerminalCursorLink w cfig tm
where
-- <> tm ^. tmButtonID
-- <> invHead cfig ("TERMINAL-" ++ show tid)
-- <> color
-- (withAlpha 0.5 green) -- consider integrating termScreenColor somehow
-- (drawSelectionListBackground secondColumnLDP cfig tsize)
-- <> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig)
-- tsize = getMaxLinesTM + 1
-- not sure if the width (55) is correct here
spincurs = clockCycle 4 (V.fromList ["/", "-", "\\", "|"]) lw
lw = w ^. cWorld . lWorld
drawTerminalCursorLink :: World -> Config -> Terminal -> Picture
drawTerminalCursorLink w cfig tm = fold $ do
j <- elemIndex (tm ^. tmButtonID) $ w ^. hud . closeButtons
lp <- selNumPos cfig invDP (w ^. hud . diSections) 5 j
let rp = screenPosAbs cfig (secondColumnLDP ^. ldpPos) - V2 5 10
lcol <- selSecSelCol 5 j (w ^. hud . diSections)
return $
translateScreenPos
cfig
(invDP ^. ldpPos)
( selSecDrawCursor
invDP
(BoundaryCursor [North, South, East, West])
(w ^. hud . diSections)
(Sel 5 j mempty)
)
<> lConnectCol (lp + V2 155 0) rp lcol white white
lnkMidPosInvSelsCol :: Config -> World -> Int -> Color -> [Int] -> Picture
lnkMidPosInvSelsCol cfig w i col = fromMaybe mempty . foldMap f
where
f j = do
let sss = w ^. hud . diSections
combinesss <- w ^? hud . subInventory . ciSections
lp <- selNumPos cfig invDP sss 0 j
rp <- selNumPos cfig secondColumnLDP combinesss 0 i
invcol <- selSecSelCol 0 j sss
return $ zConnectColMidX (rp - V2 5 0) (lp + V2 155 0) (rp ^. _1 - 20) col col col invcol
invHead :: Config -> String -> Picture
invHead cfig =
translateScreenPos cfig (fromTopLeft (V2 subInvX 80))
. dShadCol white
. scale 0.4 0.4
. textJustifyLeft
-- locPoss = map (cartePosToScreen cfig (w ^. hud) . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations . _lWorld $ _cWorld w
-- locTexts = map fst locs
-- displayListEndCoords :: Config -> [String] -> [Point2]
-- displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1 ..]
-- where
-- f :: Int -> Point2
-- f i = V2 (15 - halfWidth cfig) (2.5 + halfHeight cfig - (20 * fromIntegral i))
-- h :: String -> Point2 -> Point2
-- h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y
-- closeObjectTexts :: Config -> World -> Picture
-- closeObjectTexts cfig w = pictures $
-- renderListAt pushout (negate 20 * fromIntegral invPos) cfig (map colAndText $ _closeObjects w)
-- : maybeToList maybeLine
-- where
-- colAndText (Left x) = ( _itName $ _flIt x, _itInvColor $ _flIt x)
-- colAndText (Right x) = (_btText x,yellow)
-- youSel = _crInvSel $ you w
-- freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w
-- invPos = fromMaybe youSel freeSlot
-- mayObj = listToMaybe $ _closeObjects w
-- mayIt = mayObj >>= maybeLeft
-- maybeLeft (Left x) = Just x
-- maybeLeft _ = Nothing
-- pushout = 120
-- objPos obj = case obj of
-- Left flit -> _flItPos flit
-- Right bt -> _btPos bt
-- mayScreenPos = fmap (worldPosToScreen w . objPos) mayObj
-- maybeLine = do
-- itScreenPos <- mayScreenPos
-- (theText,col) <- fmap colAndText mayObj
-- let textWidth = 9 * fromIntegral (length theText)
-- let p = V2 (textWidth + 15 + pushout - halfWidth cfig)
-- ( halfHeight cfig - 20* (fromIntegral invPos +1) + 2.5)
-- return . winScale cfig . color col $ lConnect p itScreenPos
-- textSelItems :: [String] -> [SelectionItem ()]
-- textSelItems = map (picsToSelectable . (: []))
-- would be nice to add parameter to orient this with NSEW, cf cursor
selNumPos :: Config -> LDParams -> IMSS a -> Int -> Int -> Maybe Point2
selNumPos = selNumPosCardinal West8
-- selNumPos cfig ldp sss i j = do
-- ipos <- selSecYint i j sss
-- size <- selSecSelSize i j sss
-- indent <- sss ^? sssSections . ix i . ssItems . ix j . siOffX
-- return $
-- screenPosAbs cfig (ldp ^. ldpPos)
-- + V2
-- (10 * s * fromIntegral indent)
-- (negate (20 * s + ygap) * (fromIntegral ipos + fromIntegral size * 0.5))
-- where
-- s = _ldpScale ldp
-- ygap = _ldpVerticalGap ldp
-- need to be able to determine a selection item's width for this
selNumPosCardinal ::
Cardinal8 -> Config -> LDParams -> IMSS a -> Int -> Int -> Maybe Point2
selNumPosCardinal card cfig ldp sss i j = do
ipos <- selSecYint i j sss
ysize <- fromIntegral <$> sss ^? ix i . ssItems . ix j . siHeight
xsize <- fromIntegral <$> sss ^? ix i . ssItems . ix j . siWidth
itmindent <- fromIntegral <$> sss ^? ix i . ssItems . ix j . siOffX
sindent <- fromIntegral <$> sss ^? ix i . ssIndent
let indent = itmindent + sindent
let offset = s *^ (card8Vec card * V2 (xsize * 5) (ysize * 10))
return $
screenPosAbs cfig (ldp ^. ldpPos)
+ offset
+ V2
(10 * s * (indent + xsize * 0.5))
(negate (20 * s + ygap) * (fromIntegral ipos + ysize * 0.5))
where
s = _ldpScale ldp
ygap = _ldpVerticalGap ldp
selSecSelCol :: Int -> Int -> IMSS a -> Maybe Color
selSecSelCol i j = (^? ix i . ssItems . ix j . siColor)