Files
loop/src/Dodge/Render/HUD.hs
T

515 lines
18 KiB
Haskell

{-# LANGUAGE LambdaCase #-}
module Dodge.Render.HUD (
drawHUD,
) where
import Dodge.Data.Terminal.Status
import Control.Applicative
import Control.Lens
import Control.Monad
import qualified Data.IntSet as IS
import qualified Data.Map.Strict as M
import Data.Maybe
--import qualified Data.Vector as V
import Dodge.Base
import Dodge.CharacterEnums
--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.World
import Dodge.DoubleTree
import Dodge.Equipment.Text
import Dodge.Inventory
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.HUD.Carte
import Dodge.Render.List
import Dodge.ScreenPos
import Dodge.SelectionSections
import Dodge.SelectionSections.Draw
import Dodge.Terminal.Type
import Geometry
import qualified IntMapHelp as IM
import Justify
import NewInt
import Picture
import SDL (MouseButton (..))
drawHUD :: Configuration -> World -> Picture
drawHUD cfig w = case w ^. hud . hudElement of
-- DisplayCarte -> drawCarte cfig w
DisplayInventory{_diSections = sections, _subInventory = subinv} ->
drawInventory sections w cfig
<> drawSubInventory subinv cfig w
drawInventory :: IM.IntMap (SelectionSection ()) -> World -> Configuration -> Picture
drawInventory sss w cfig =
drawSelectionSections sss invDP cfig
<> drawSSCursor sss invDP curs cfig (f $ w ^? hud . hudElement . diSelection . _Just)
<> drawRootCursor w sss (f $ w ^? hud . hudElement . diSelection . _Just) invDP cfig
<> itemconnections
<> drawMouseOver cfig w
where
f = fmap (\(x, y, _) -> (x, y))
curs = invCursorParams w
itemconnections = fromMaybe mempty $ do
inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
case w ^? hud . hudElement . diInvFilter . _Just of
Just (_ : _) -> Nothing
_ -> return . drawItemConnections sss cfig $ invAdj inv
drawRootCursor ::
World ->
IM.IntMap (SelectionSection ()) ->
Maybe (Int, Int) ->
ListDisplayParams ->
Configuration ->
Picture
drawRootCursor w sss msel ldp cfig = fromMaybe mempty $ do
cr <- w ^? cWorld . lWorld . creatures . ix 0
guard $ crIsAiming cr
(i, j) <- msel
guard $ i == 0
inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
(x, y) <- getRootItemBounds j 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 inv -- why indents? why OItem?
itm <- ia ^? ix i . _2
let root = locToTop itm
x <- locDTRightmost root ^? locDT . dtValue . _1 . itLocation . ilInvID
y <- locDTLeftmost root ^? locDT . dtValue . _1 . itLocation . ilInvID
return (x, y)
drawMouseOver :: Configuration -> 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 . hudElement . diSections
return . translateScreenPos cfig (invDP ^. ldpPos)
. color (withAlpha 0.1 white)
-- . color white
$ selSecDrawCursorAt invDP curs sss (j, i)
-- curs = BoundaryCursor [West]
curs = BackdropCursor
combinvsel = do
(j, i) <-
(w ^? input . mouseContext . mcoCombSelect)
<|> (w ^? input . mouseContext . mcoCombCombine)
sss <- w ^? hud . hudElement . subInventory . ciSections
let idp = secondColumnParams
return . translateScreenPos cfig (idp ^. ldpPos)
. color (withAlpha 0.2 white)
$ selSecDrawCursorAt idp curs sss (j, i)
drawDragSelected :: Configuration -> World -> Maybe Picture
drawDragSelected cfig w = do
ys <- w ^? hud . hudElement . diSelection . _Just . _3
guard $
not (IS.null ys)
&& ( case w ^? hud . hudElement . subInventory of
Just NoSubInventory -> True
_ -> False
)
(i, _, _) <- w ^? hud . hudElement . diSelection . _Just
sss <- w ^? hud . hudElement . diSections
let f x = (selSecDrawCursorAt invDP BackdropCursor sss (i, x) <>)
return . translateScreenPos cfig (invDP ^. ldpPos)
. color (withAlpha 0.2 white)
. IS.foldr f mempty
$ ys
drawDragSelecting :: Configuration -> World -> Maybe Picture
drawDragSelecting cfig w = do
OverInvDragSelect (i, j) mselend <- w ^? input . mouseContext
b <- mselend
sss <- w ^? hud . hudElement . diSections
let f x = selSecDrawCursorAt invDP BackdropCursor sss (i, x)
return . translateScreenPos cfig (invDP ^. ldpPos)
. color (withAlpha 0.2 white)
. foldMap f
$ [min j b .. max j b]
drawSubInventory :: SubInventory -> Configuration -> World -> Picture
drawSubInventory subinv cfig w = case subinv of
-- LockedInventory -> mempty -- topInvCursor col cursPos cfig w
NoSubInventory{} -> drawRBOptions cfig w
ExamineInventory -> drawExamineInventory cfig w
DisplayTerminal tid -> drawTerminalDisplay tid cfig (w ^. cWorld . lWorld)
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 ::
Configuration ->
IM.IntMap (SelectionSection CombinableItem) ->
World ->
Picture
drawCombineInventory cfig sss w =
invHead cfig "COMBINE"
<> drawSelectionSections sss secondColumnParams cfig
<> drawSSCursor sss secondColumnParams curs cfig msel
<> combineInventoryExtra sss msel cfig w
where
curs = BoundaryCursor [North, South, West]
msel =
fmap (\(x, y, _) -> (x, y)) $
w ^? hud . hudElement . subInventory . ciSelection . _Just
drawExamineInventory :: Configuration -> World -> Picture
drawExamineInventory cfig w =
invHead cfig "EXAMINE"
<> drawSelectionList
secondColumnParams
cfig
( map
f
( makeParagraph 55 $
yourAugmentedItem
itemInfo
(yourInfo (you w))
(closeObjectInfo (crNumFreeSlots (you w)))
w
)
)
where
f str =
SelectionItem
{ _siPictures = [str]
, _siWidth = 55
, _siHeight = 1
, _siIsSelectable = True
, _siColor = white
, _siOffX = 0
, _siPayload = ()
}
closeObjectInfo :: Int -> Either FloorItem Button -> String
closeObjectInfo n x = case x of
Left FlIt{_flIt = 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 FloorItem 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 . floorItems . unNIntMap . ix j
return . g $ Left flit
-- g . Left $ w ^?! hud . closeItems . ix i
Just (SelCloseButton i) -> fromMaybe x $ do
j <- w ^? hud . closeButtons . ix i
flit <- w ^? cWorld . lWorld . buttons . ix j
return . g $ Right flit
_ -> x
drawRBOptions :: Configuration -> World -> Picture
drawRBOptions cfig w = fold $ do
guard $ ButtonRight `M.member` _mouseButtons (_input w)
invid <- you w ^? crManipulation . manObject . imSelectedItem
eslist <-
fmap eqSiteToPositions $
you w ^? crInv . ix invid >>= equipType -- . itUse . uequipEffect . eeType
i <- w ^? rbOptions . opSel
let ae = getEquipmentAllocation invid w
sss <- w ^? hud . hudElement . diSections
(i', j, _) <- w ^? hud . hudElement . 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 j = fromMaybe "" $ do
itype <- you w ^? crInv . 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 ::
IM.IntMap (SelectionSection ()) ->
Configuration ->
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 ::
IM.IntMap (SelectionSection ()) ->
Configuration ->
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 ::
IM.IntMap (SelectionSection CombinableItem) ->
Maybe (Int, Int) ->
Configuration ->
World ->
Picture
combineInventoryExtra sss msel cfig w = fromMaybe mempty $ do
(i, j) <- msel
si <- sss ^? ix i . ssItems . ix j
let col = _siColor si
lnks <- si ^? siPayload . ciInvIDs
return (lnkMidPosInvSelsCol cfig w j col lnks)
<> foldMap invcursor lnks
where
invcursor i = do
sss' <- w ^? hud . hudElement . diSections
return $
translateScreenPos cfig (invDP ^. ldpPos) $
selSecDrawCursor
invDP
(BoundaryCursor [North, South, East, West])
sss'
(Just (0, i))
drawTerminalDisplay :: Int -> Configuration -> LWorld -> Picture
drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
tm <- w ^? terminals . ix tid
let tsize = getMaxLinesTM + 1
return $
invHead cfig ("T-" ++ show tid)
<> drawSelectionList secondColumnParams cfig (thesellist tm)
<> color
(withAlpha 0.5 green) -- consider integrating termScreenColor somehow
(drawSelectionListBackground secondColumnParams cfig tsize)
<> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig)
where
toselitm (str, col) = SelectionItem [str] 1 55 True col 0 ()
-- not sure if the width (55) is correct here
thesellist tm = thelist tm
thelist tm =
map toselitm . displayTermInput tm
. reverse
. take getMaxLinesTM
$ _tmDisplayedLines tm
displayTermInput tm = case _tmStatus tm of
TerminalOff -> id
TerminalBusy -> (++ [([cFilledRect], white)])
TerminalTextInput s _ ->
(++ [(getPromptTM ++ s ++ [cFilledRect], white)])
TerminalPressTo s ->
(++ [("PRESS TO "++s, white)])
-- partcommand tm = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just . tcString
-- displayInputText tm s
-- | TerminalTextInput <- _tmStatus tm = getPromptTM ++ s
---- | _tmStatus tm == TerminalReady = partcommand tm ++ getPromptTM ++ s
-- | otherwise = ""
-- | hasfoc = clockCycle 10 (V.fromList [[cFilledRect] , "."]) w
lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
lnkMidPosInvSelsCol cfig w i col = fromMaybe mempty . foldMap f
where
f j = do
sss <- w ^? hud . hudElement . diSections
combinesss <- w ^? hud . hudElement . subInventory . ciSections
lp <- selNumPos cfig invDP sss 0 j
rp <- selNumPos cfig secondColumnParams 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 :: Configuration -> 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 :: Configuration -> [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 :: Configuration -> 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 ::
Configuration ->
ListDisplayParams ->
IM.IntMap (SelectionSection 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 ::
CardinalEightPoint ->
Configuration ->
ListDisplayParams ->
IM.IntMap (SelectionSection a) ->
Int ->
Int ->
Maybe Point2
selNumPosCardinal card cfig ldp sss i j = do
ipos <- selSecYint i j sss
-- size <- selSecSelSize 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 =
cardEightVec card
* V2
(xsize * 0.5 * 10 * s)
(ysize * 0.5 * 20 * s)
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 -> IM.IntMap (SelectionSection a) -> Maybe Color
selSecSelCol i j sss = sss ^? ix i . ssItems . ix j . siColor