398 lines
15 KiB
Haskell
398 lines
15 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Render.HUD (
|
|
drawHUD,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import qualified Data.Vector as V
|
|
import Dodge.Base
|
|
import Dodge.Clock
|
|
import Dodge.Creature.Info
|
|
import Dodge.Data.CardinalPoint
|
|
import Dodge.Data.Combine
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.SelectionList
|
|
import Dodge.Data.World
|
|
import Dodge.Default.SelectionList
|
|
import Dodge.Equipment.Text
|
|
import Dodge.Inventory
|
|
import Dodge.Item.Info
|
|
import Dodge.ListDisplayParams
|
|
import Dodge.Render.Connectors
|
|
import Dodge.Render.List
|
|
import Dodge.SelectionSections
|
|
import Dodge.SelectionSections.Draw
|
|
import Dodge.Tweak.Show
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import Justify
|
|
import ListHelp
|
|
import Padding
|
|
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} ->
|
|
drawHP cfig w
|
|
<> drawInventory sections w cfig
|
|
<> drawSubInventory subinv cfig w
|
|
|
|
drawHP :: Configuration -> World -> Picture
|
|
drawHP cfig = dShadCol white . displayHP 0 cfig
|
|
|
|
drawInventory :: SelectionSections () -> World -> Configuration -> Picture
|
|
drawInventory sss = drawSelectionSections sss . invDisplayParams
|
|
|
|
drawSubInventory :: SubInventory -> Configuration -> World -> Picture
|
|
drawSubInventory subinv cfig w = case subinv of
|
|
LockedInventory -> mempty -- topInvCursor col cursPos cfig w
|
|
NoSubInventory -> drawRBOptions cfig w
|
|
ExamineInventory mtweaki -> drawExamineInventory cfig mtweaki w
|
|
DisplayTerminal tid -> displayTerminal tid cfig (w ^. cWorld . lWorld)
|
|
CombineInventory{_ciSections = sss} -> drawCombineInventory cfig sss w
|
|
|
|
drawCombineInventory :: Configuration -> SelectionSections CombinableItem -> World -> Picture
|
|
drawCombineInventory cfig sss w =
|
|
invHead cfig "COMBINE"
|
|
<> drawSelectionSections sss secondColumnParams cfig
|
|
<> combineInventoryExtra sss cfig w
|
|
|
|
drawExamineInventory :: Configuration -> Maybe Int -> World -> Picture
|
|
drawExamineInventory cfig mtweaki w =
|
|
invHead cfig "EXAMINE"
|
|
<> examineInventoryExtra mtweaki itm cfig
|
|
<> drawSelectionList
|
|
secondColumnParams
|
|
cfig
|
|
( defaultSelectionList & slItems .~ ammoTweakSelectionItems itm
|
|
++ map
|
|
f
|
|
( makeParagraph 60 $
|
|
yourAugmentedItem
|
|
itemInfo
|
|
(yourInfo (you w))
|
|
(closeObjectInfo (crNumFreeSlots (you w)))
|
|
w
|
|
)
|
|
)
|
|
where
|
|
itm = yourItem w
|
|
f str =
|
|
SelectionItem
|
|
{ _siPictures = [str]
|
|
, _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 >= ceiling (_itInvSize 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 (InInventory (SelItem i _)) -> f $ yourInv w ^?! ix i
|
|
Just (InNearby (SelCloseObject i)) -> g $ w ^?! hud . closeObjects . ix i
|
|
_ -> x
|
|
|
|
drawRBOptions :: Configuration -> World -> Picture
|
|
drawRBOptions cfig w = fromMaybe mempty $ do
|
|
guard $ ButtonRight `M.member` _mouseButtons (_input w)
|
|
es <- w ^? rbOptions . opEquip
|
|
i <- w ^? rbOptions . opSel
|
|
ae <- w ^? rbOptions . opAllocateEquipment
|
|
sss <- w ^? hud . hudElement . diSections
|
|
(i', j) <- sss ^? sssExtra . sssSelPos . _Just
|
|
curpos <- selSecSelPos i' j sss
|
|
let midtext str = toTopLeft cfig $ translate 252 0 $ drawListElement 10 1 curpos (text str)
|
|
let extratext str = toTopLeft cfig $ translate 432 0 $ drawListElement 10 1 curpos (text (str ++ deactivatetext))
|
|
return $
|
|
toTopLeft cfig (translate 342 0 $ drawListYoff (curpos - i) (map (text . eqPosText) es))
|
|
<> case ae of
|
|
DoNotMoveEquipment -> mempty
|
|
PutOnEquipment{} ->
|
|
midtext "PUT ONTO"
|
|
MoveEquipment{} ->
|
|
midtext "MOVE TO" <> extratext []
|
|
SwapEquipment{_allocOldPos = oldp, _allocSwapID = sid} ->
|
|
midtext "MOVE TO" <> extratext ("SWAPS " ++ otheritem sid ++ " ONTO " ++ eqPosText oldp)
|
|
ReplaceEquipment{_allocRemoveID = rid} ->
|
|
midtext "PUT ONTO" <> extratext ("REMOVES " ++ otheritem rid)
|
|
RemoveEquipment{} ->
|
|
midtext "TAKE OFF"
|
|
where
|
|
deactivatetext = case w ^? rbOptions . opActivateEquipment . deactivateEquipment of
|
|
Just k -> " DEACTIVATES " ++ show (_iyBase $ _itType (_crInv (you w) IM.! k))
|
|
Nothing -> ""
|
|
otheritem j = show $ _iyBase $ _itType (_crInv (you w) IM.! j)
|
|
|
|
examineInventoryExtra :: Maybe Int -> Maybe Item -> Configuration -> Picture
|
|
examineInventoryExtra mtweaki mitm cfig = fromMaybe mempty $ do
|
|
tweaki <- mtweaki
|
|
-- consider moving this functionality out into a tweaks module
|
|
tparam <- mitm ^? _Just . itTweaks . tweakParams . ix tweaki
|
|
return $ toTopLeft cfig $ translate subInvX (-60)
|
|
$ listCursorNSW tweaki 0 white (length $ showTweak tparam) 15
|
|
|
|
combineInventoryExtra :: SelectionSections CombinableItem -> Configuration -> World -> Picture
|
|
combineInventoryExtra sss cfig w = fromMaybe mempty $ do
|
|
(i, j) <- sss ^? sssExtra . sssSelPos . _Just
|
|
si <- sss ^? sssSections . ix i . ssItems . ix j
|
|
cpos <- selSecSelPos i j sss
|
|
let col = _siColor si
|
|
return $
|
|
mconcat
|
|
[ fromMaybe mempty $ do
|
|
strs <- si ^? siPayload . ciInfo
|
|
return $ toTopLeft cfig (translate (subInvX + 150) 60 $ drawListYoff cpos $ map (color red . text) strs)
|
|
, fromMaybe mempty $ do
|
|
lnks <- si ^? siPayload . ciInvIDs
|
|
return $
|
|
lnkMidPosInvSelsCol cfig w cpos col lnks
|
|
<> foldMap invcursor lnks
|
|
<> combineCounts cfig w lnks
|
|
]
|
|
where
|
|
invcursor i = fromMaybe mempty $ do
|
|
sss' <- w ^? hud . hudElement . diSections
|
|
return $ toTopLeft cfig $ selSecDrawCursor 17 [North, South, East] (invDisplayParams w) sss' 0 i
|
|
|
|
displayTerminal :: Int -> Configuration -> LWorld -> Picture
|
|
displayTerminal tid cfig w = fromMaybe mempty $ do
|
|
tm <- w ^? terminals . ix tid
|
|
return $
|
|
invHead cfig (_tmTitle tm ++ ":T" ++ show tid)
|
|
<> drawSelectionList secondColumnParams cfig (thesellist tm)
|
|
where
|
|
toselitm (str, col) = SelectionItem [str] 1 True col 0 ()
|
|
thesellist tm = defaultSelectionList & slItems .~ thelist tm
|
|
thelist tm =
|
|
map toselitm . displayTermInput tm
|
|
. reverse
|
|
. take (_tmMaxLines tm)
|
|
$ _tmDisplayedLines tm
|
|
displayTermInput tm = case _tmInput tm of
|
|
TerminalInput{_tiText = s, _tiFocus = hasfoc} ->
|
|
(++ [(displayInputText tm s ++ displayBlinkCursor hasfoc, white)])
|
|
partcommand tm = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just . tcString
|
|
displayInputText tm s
|
|
| _tmStatus tm == TerminalReady = partcommand tm ++ "> " ++ s
|
|
| otherwise = ""
|
|
displayBlinkCursor hasfoc
|
|
| hasfoc = clockCycle 10 (V.fromList ["_", "."]) w
|
|
| otherwise = []
|
|
|
|
combineCounts :: Configuration -> World -> [Int] -> Picture
|
|
combineCounts cfig w = foldMap f . group
|
|
where
|
|
f (i : is) = fromMaybe mempty $ do
|
|
_ <- yourInv w ^? ix i . itUse . useAmount
|
|
sss <- w ^? hud . hudElement . diSections
|
|
p <- selNumTextEndPos cfig (invDisplayParams w) sss 0 i
|
|
col <- selSecSelCol 0 i sss
|
|
return $ color col $ uncurryV translate p . scale 0.1 0.1 . text $ ('-' : show (length is + 1))
|
|
f _ = mempty
|
|
|
|
lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
|
|
lnkMidPosInvSelsCol cfig w i col = foldMap f
|
|
where
|
|
f j = fromMaybe mempty $ do
|
|
sss <- w ^? hud . hudElement . diSections
|
|
h <- selNumEndMidHeight cfig (invDisplayParams w) sss 0 j
|
|
invcol <- selSecSelCol 0 j sss
|
|
return $ zConnectCol rp (V2 18 0 + h) col white white invcol
|
|
rp = V2 (190 - hw) (hh - (20 * fromIntegral i + 77.5))
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
ammoTweakSelectionItems :: Maybe Item -> [SelectionItem ()]
|
|
ammoTweakSelectionItems = textSelItems . ammoTweakStrings
|
|
|
|
ammoTweakStrings :: Maybe Item -> [String]
|
|
ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
|
|
Just l -> map tweakString $ IM.elems l
|
|
_ -> ["NOT TWEAKABLE"]
|
|
|
|
tweakString :: TweakParam -> String
|
|
tweakString tp = rightPad 12 ' ' (show $ _tweakType tp) ++ " " ++ showTweak tp
|
|
|
|
invHead :: Configuration -> String -> Picture
|
|
invHead cfig =
|
|
translate (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 40)
|
|
. dShadCol white
|
|
. scale 0.4 0.4
|
|
. text
|
|
|
|
drawCarte :: Configuration -> World -> Picture
|
|
drawCarte cfig w =
|
|
pictures $
|
|
toTopLeft cfig (renderListAt 0 0 locs) :
|
|
mapOverlay w
|
|
++ [mainListCursor white iPos cfig]
|
|
where
|
|
iPos = w ^. cWorld . lWorld . selLocation
|
|
locs = map (\(_, s) -> (s, white)) . IM.elems . _seenLocations . _lWorld $ _cWorld w
|
|
|
|
--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
|
|
|
|
mapOverlay :: World -> [Picture]
|
|
mapOverlay w =
|
|
(color (withAlpha 0.5 black) . polygon $ reverse $ rectNSWE 1 (-1) 1 (-1)) :
|
|
[foldMap (drawMapWall (w ^. hud)) $ IM.restrictKeys (lw ^. walls) (w ^. cWorld . seenWalls)]
|
|
where
|
|
lw = w ^. cWorld . lWorld
|
|
--(mapMaybe (mapWall cfig (w ^. hud)) . IM.elems $ w ^. cWorld . lWorld . walls)
|
|
|
|
drawMapWall :: HUD -> Wall -> Picture
|
|
drawMapWall thehud wl = color c . polygon $ map (cartePosToScreen thehud) [x, x +.+ n2, y +.+ n2, y]
|
|
where
|
|
t = normalizeV (y -.- x)
|
|
n2 = 20 *.* vNormal t
|
|
(x, y) = _wlLine wl
|
|
c = _wlColor wl
|
|
|
|
--mapWall :: Configuration -> HUD -> Wall -> Maybe Picture
|
|
--mapWall cfig thehud wl
|
|
-- | _wlSeen wl = Just . color c . polygon $ map (cartePosToScreen cfig thehud) [x, x +.+ n2, y +.+ n2, y]
|
|
-- | otherwise = Nothing
|
|
-- where
|
|
-- t = normalizeV (y -.- x)
|
|
-- n2 = 20 *.* vNormal t
|
|
-- (x, y) = _wlLine wl
|
|
-- c = _wlColor wl
|
|
|
|
--selectedCloseObjectLink :: Configuration -> World -> Picture
|
|
--selectedCloseObjectLink cfig w = mempty
|
|
|
|
-- | Pictures of popup text for items close to your position.
|
|
|
|
--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
|
|
|
|
mainListCursor :: Color -> Int -> Configuration -> Picture
|
|
mainListCursor c = openCursorAt 120 c 5 0
|
|
|
|
textSelItems :: [String] -> [SelectionItem ()]
|
|
textSelItems = map (picsToSelectable . (: []))
|
|
|
|
picsToSelectable :: [String] -> SelectionItem ()
|
|
picsToSelectable pics =
|
|
SelectionItem
|
|
{ _siPictures = pics
|
|
, _siHeight = length pics
|
|
, _siIsSelectable = True
|
|
, _siColor = white
|
|
, _siOffX = 0
|
|
, _siPayload = ()
|
|
}
|
|
|
|
openCursorAt ::
|
|
-- | Width
|
|
Float ->
|
|
Color ->
|
|
-- | x offset
|
|
Float ->
|
|
-- | y offset
|
|
Float ->
|
|
-- | y offset (discrete)
|
|
Int ->
|
|
Configuration ->
|
|
Picture
|
|
openCursorAt wth col xoff yoff yint w =
|
|
translate (xoff - halfWidth w) (halfHeight w - (20 * fromIntegral yint + yoff) - 20) $
|
|
lineCol
|
|
[ (V2 wth 12.5, withAlpha 0 col)
|
|
, (V2 0 12.5, col)
|
|
, (V2 0 (-7.5), col)
|
|
, (V2 wth (-7.5), withAlpha 0 col)
|
|
]
|
|
|
|
displayHP :: Int -> Configuration -> World -> Picture
|
|
displayHP cid cfig =
|
|
translate (halfWidth cfig -80) (halfHeight cfig -20)
|
|
. scale 0.2 0.2
|
|
. text
|
|
. leftPad 5 ' '
|
|
. show
|
|
. (^?! cWorld . lWorld . creatures . ix cid . crHP)
|
|
|
|
-- there are still more ListDisplayParams to integrate here
|
|
selNumTextEndPos :: Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Maybe Point2
|
|
selNumTextEndPos cfig ldp sss i j = do
|
|
ipos <- selSecSelPos i j sss
|
|
return $ V2 (150 - hw) (hh - ((s * 10 + ygap) * (fromIntegral ipos + 1)))
|
|
where
|
|
s = _ldpScale ldp
|
|
ygap = _ldpVerticalGap ldp
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
selNumEndMidHeight ::
|
|
Configuration ->
|
|
ListDisplayParams ->
|
|
SelectionSections a ->
|
|
Int ->
|
|
Int ->
|
|
Maybe Point2
|
|
selNumEndMidHeight cfig ldp sss i j = do
|
|
ipos <- selSecSelPos i j sss
|
|
size <- selSecSelSize i j sss
|
|
--let bump = negate $ (10 * s + ygap) * fromIntegral size
|
|
return $ V2 (150 - hw) (hh - ((10 * s + ygap) * (fromIntegral ipos + fromIntegral size * 0.5)))
|
|
where
|
|
s = _ldpScale ldp
|
|
ygap = _ldpVerticalGap ldp
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
selSecSelCol :: Int -> Int -> SelectionSections a -> Maybe Color
|
|
selSecSelCol i j sss = sss ^? sssSections . ix i . ssItems . ix j . siColor
|