329 lines
12 KiB
Haskell
329 lines
12 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Render.HUD
|
|
( hudDrawings
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.WinScale
|
|
import Dodge.Combine
|
|
import Dodge.Base
|
|
import Dodge.Base.Window
|
|
--import Dodge.Combine.Combinations
|
|
import Dodge.Inventory
|
|
import Dodge.Inventory.ItemSpace
|
|
import Dodge.Render.Connectors
|
|
import Dodge.Render.List
|
|
import Picture
|
|
import Geometry
|
|
import Padding
|
|
import ListHelp
|
|
|
|
--import Data.Foldable
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Set as S
|
|
import qualified Data.IntSet as IS
|
|
import Control.Lens
|
|
import SDL (MouseButton (..))
|
|
--import Data.List
|
|
--import Data.Bifunctor
|
|
|
|
hudDrawings :: Configuration -> World -> Picture
|
|
hudDrawings cfig w = case _hudElement $ _hud w of
|
|
DisplayCarte -> drawCarte cfig w
|
|
DisplayInventory subinv -> drawInGameHUD cfig w
|
|
<> subInventoryDisplay subinv cfig w
|
|
|
|
drawInGameHUD :: Configuration -> World -> Picture
|
|
drawInGameHUD cfig w = pictures
|
|
[ winScale cfig . dShadCol white $ displayHP 0 cfig w
|
|
, listTextPicturesAt (halfWidth cfig) 0 cfig $ map text (_testString w w)
|
|
, inventoryDisplay cfig w
|
|
]
|
|
|
|
inventoryDisplay :: Configuration -> World -> Picture
|
|
inventoryDisplay cfig w = listTextPicturesAt 0 0 cfig invlist
|
|
where
|
|
cr = you w
|
|
inv = _crInv cr
|
|
invlist = concatMap itemText (IM.elems inv)
|
|
++ displayFreeSlots
|
|
++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w)
|
|
-- ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w))
|
|
-- floorItemsColor = case _hudElement (_hud w) of
|
|
-- DisplayInventory NoSubInventory -> id
|
|
-- _ -> color invDimColor
|
|
nfreeslots = crNumFreeSlots cr
|
|
displayFreeSlots = case nfreeslots of
|
|
0 -> [color invDimColor . text $ " INVENTORY FULL"]
|
|
1 -> [color invDimColor . text $ " +1 FREE SLOT"]
|
|
x -> [color invDimColor . text $ " +" ++ show x ++ " FREE SLOTS"]
|
|
|
|
subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture
|
|
subInventoryDisplay subinv cfig w = case subinv of
|
|
LockedInventory -> mempty -- topInvCursor col cursPos cfig w
|
|
NoSubInventory -> pictures
|
|
[ selcursor
|
|
, closeobjectcursor
|
|
, equipcursor
|
|
, equipcursors
|
|
]
|
|
TweakInventory -> pictures
|
|
--[ mCurs it cfig w
|
|
[ selcursor' listCursorNESW
|
|
-- , cursorsZ cfig curpos it
|
|
, fromMaybe mempty $ do
|
|
tweaki <- it ^? _Just . itTweaks . tweakSel
|
|
-- consider moving this functionality out into a tweaks module
|
|
showtweak <- it ^? _Just . itTweaks . tweakParams . ix tweaki . showTweak
|
|
tweakname <- it ^? _Just . itTweaks . tweakParams . ix tweaki . nameTweak
|
|
tweakstring <- showtweak <$> (it ^? _Just . itTweaks . tweakParams . ix tweaki . curTweak)
|
|
return $ lnkMidInvSel cfig w curpos tweaki
|
|
<> listCursorNSW subInvX 60 cfig tweaki white (length $ tweakstring ++ tweakname) 1
|
|
, invHead cfig "TWEAK"
|
|
, listTextPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
|
|
]
|
|
DisplayTerminal {_termParams = tp} -> pictures
|
|
[ invHead cfig "TERMINAL"
|
|
, renderListAt subInvX 60 cfig . reverse $ take (_termMaxLines tp) (_termDisplayedLines tp)
|
|
]
|
|
CombineInventory mi -> pictures
|
|
[ invHead cfig "COMBINE"
|
|
, listTextPicturesAt subInvX 60 cfig $ combineListStringPictures w
|
|
, fromMaybe mempty $ do
|
|
i <- mi
|
|
cpos <- combinePoss w !? i
|
|
strs <- fmap (snd . snd) (combineItemListYou' w !? i)
|
|
return $ listTextPicturesAtOffset (subInvX + 150) 60 cfig cpos $ map (color red . text) strs
|
|
, fromMaybe mempty $ do
|
|
i <- mi
|
|
cpos <- combinePoss w !? i
|
|
csize <- combineSizes w !? i
|
|
col <- (combineItemListYou w !? i) <&> _itInvColor . snd
|
|
return $ listCursorNSW subInvX 60 cfig cpos col 15 csize
|
|
, fromMaybe mempty $ do
|
|
i <- mi
|
|
cpos <- combinePoss w !? i
|
|
col <- (combineItemListYou w !? i) <&> _itInvColor . snd
|
|
lnks <- map fst (combineItemListYou w) !? i
|
|
return $ lnkMidPosInvSelsCol cfig w cpos col lnks
|
|
<> foldMap (cursorAtInvSel listCursorNESW cfig w) lnks
|
|
<> combineCounts cfig w lnks
|
|
]
|
|
InspectInventory -> invHead cfig "INSPECT"
|
|
where
|
|
closeobjectcursor = case selectedCloseObject w of
|
|
Nothing -> mempty
|
|
Just (i,co) -> listCursorNS clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w)
|
|
itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor)
|
|
cr = you w
|
|
it = yourItem w
|
|
selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol topInvW cury <$ it
|
|
selcursor = selcursor' selcursortype
|
|
selcursortype
|
|
| ButtonRight `S.member` _mouseButtons w = listCursorNESW
|
|
| otherwise = listCursorNSW
|
|
curpos = invSelPos w
|
|
cury = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
|
|
equipcursor = case _crLeftInvSel cr of
|
|
Nothing -> mempty
|
|
Just invid -> f cyan invid
|
|
equipcursors = foldMap (f yellow) (IS.toList $ _crInvEquipped cr)
|
|
f col invid = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text "EQUIPPED"
|
|
|
|
topInvW :: Int
|
|
topInvW = 15
|
|
|
|
subInvX :: Float
|
|
subInvX = 9 * fromIntegral topInvW + 50
|
|
|
|
lnkMidInvSel :: Configuration -> World -> Int -> Int -> Picture
|
|
lnkMidInvSel cfig w lefti midi = winScale cfig
|
|
. color white
|
|
. zConnect rp $ selNumMidHeight cfig w lefti
|
|
where
|
|
-- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
|
|
rp = V2 (190 - hw) ( hh - (20 * fromIntegral midi + 77.5))
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
|
|
--lnkMidPosInvSels :: Configuration -> World -> Int -> [Int] -> Picture
|
|
--lnkMidPosInvSels cfig w i = winScale cfig
|
|
-- . color white
|
|
-- . concatMap (zConnect rp . selNumMidHeight cfig w)
|
|
-- where
|
|
---- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
|
|
-- rp = V2 (190 - hw) ( hh - (20 * fromIntegral i + 77.5))
|
|
-- hh = halfHeight cfig
|
|
-- hw = halfWidth cfig
|
|
|
|
combineCounts :: Configuration -> World -> [Int] -> Picture
|
|
combineCounts cfig w = winScale cfig . foldMap f . group
|
|
where
|
|
f (i:is) = case yourInv w ^? ix i . itConsumption of
|
|
Just _ -> color (selNumCol i w) $ uncurryV translate (V2 10 5 +.+ selNumMidHeight cfig w i) . scale 0.1 0.1 . text . show $ length is + 1
|
|
Nothing -> mempty
|
|
f _ = mempty
|
|
|
|
lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
|
|
lnkMidPosInvSelsCol cfig w i col = winScale cfig
|
|
. concatMap (\j -> zConnectCol rp (selNumMidHeight cfig w j) col white white (selNumCol j w))
|
|
where
|
|
-- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
|
|
rp = V2 (190 - hw) ( hh - (20 * fromIntegral i + 77.5))
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
cursorAtInvSel :: (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture)
|
|
-> Configuration -> World -> Int -> Picture
|
|
cursorAtInvSel ctype cfig w i
|
|
= ctype 0 0 cfig (selNumPos i w) (selNumCol i w) topInvW (selNumSlots i w)
|
|
|
|
--listSelHeight :: Configuration -> World -> Int -> Float
|
|
--listSelHeight
|
|
|
|
combineListStringPictures :: World -> [Picture]
|
|
combineListStringPictures w = case concatMap (itemText . snd) . combineItemListYou $ w of
|
|
[] -> [text "NO POSSIBLE COMBINATIONS"]
|
|
xs -> xs
|
|
|
|
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 ' ' (_nameTweak tp) ++ " " ++ _showTweak tp (_curTweak tp)
|
|
|
|
invHead :: Configuration -> String -> Picture
|
|
invHead cfig s = winScale cfig
|
|
. translate (-halfWidth cfig + subInvX + 20) (halfHeight cfig - 40)
|
|
. dShadCol white
|
|
. scale 0.4 0.4
|
|
$ text s
|
|
|
|
invDimColor :: Color
|
|
invDimColor = greyN 0.7
|
|
closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
|
|
closeObjectToTextPictures nfreeslots e = case e of
|
|
Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ _itInvDisplay it it
|
|
Right bt -> [color yellow $ textindent $ _btText bt]
|
|
where
|
|
textindent = text . (replicate clObjIntIn ' '++)
|
|
applycolor it
|
|
| nfreeslots >= itSlotsTaken it = color $ _itInvColor it
|
|
| otherwise = color invDimColor
|
|
|
|
clObjIntIn :: Int
|
|
clObjIntIn = 2
|
|
clObjFloatIn :: Float
|
|
clObjFloatIn = fromIntegral clObjIntIn * 9
|
|
|
|
|
|
drawCarte :: Configuration -> World -> Picture
|
|
drawCarte cfig w = pictures $
|
|
renderListAt 0 0 cfig locs
|
|
: zipWith bConnect (displayListEndCoords cfig locTexts) locPoss
|
|
++ mapOverlay cfig w
|
|
++ [mainListCursor white iPos cfig]
|
|
where
|
|
iPos = _selLocation w
|
|
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
|
|
locPoss = map (cartePosToScreen cfig w . ($ w) . fst) . IM.elems . _seenLocations $ 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 :: Configuration -> World -> [Picture]
|
|
mapOverlay cfig w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) :
|
|
(mapMaybe (mapWall cfig w) . IM.elems $ _walls w)
|
|
|
|
mapWall :: Configuration -> World -> Wall -> Maybe Picture
|
|
mapWall cfig w wl =
|
|
if _wlSeen wl
|
|
then Just . color c . polygon $ map (cartePosToScreen cfig w) [x,x +.+ n2,y +.+ n2, y]
|
|
else 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
|
|
|
|
itemText :: Item -> [Picture]
|
|
{-# INLINE itemText #-}
|
|
itemText it = f $ case _itCurseStatus it of
|
|
UndroppableIdentified -> map (color yellow . text) (_itInvDisplay it it)
|
|
-- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90)))
|
|
_ -> map (color thecolor . text) (_itInvDisplay it it)
|
|
where
|
|
thecolor = _itInvColor it
|
|
f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
|
|
|
|
openCursorAt
|
|
:: Float -- ^ Width
|
|
-> Color
|
|
-> Float -- ^ x offset
|
|
-> Float -- ^ y offset
|
|
-> Int -- ^ y offset (discrete)
|
|
-> Configuration
|
|
-> Picture
|
|
openCursorAt wth col xoff yoff yint w = winScale 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 w = translate (halfWidth cfig-80) (halfHeight cfig-20)
|
|
. scale 0.2 0.2
|
|
. text
|
|
. leftPad 5 ' '
|
|
. show
|
|
. _crHP
|
|
$ _creatures w IM.! cid
|