--{-# LANGUAGE TupleSections #-} module Dodge.Render.HUD ( hudDrawings ) where import Dodge.Data import Dodge.Item.Display import Dodge.Combine import Dodge.Clock import Dodge.Base --import Dodge.InputFocus --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 qualified Data.Vector as V --import Data.Foldable import Data.Maybe import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as M --import qualified Data.Set as S --import qualified Data.IntSet as IS import Control.Lens import SDL (MouseButton (..)) import qualified Data.Text as T --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 , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_testString w cfig w) , inventoryDisplay cfig w ] inventoryDisplay :: Configuration -> World -> Picture inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist where cr = you w inv = _crInv cr invlist = concatMap (itemText' cr) (IM.toList 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 , equipcursors , equipcursor -- the order is important, this should go on top of the other equipcursors , rboptions ] 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" , listPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it) ] DisplayTerminal tid -> displayTerminal tid cfig w CombineInventory mi -> pictures [ invHead cfig "COMBINE" , listPicturesAt subInvX 60 cfig $ combineListStringPictures w , fromMaybe mempty $ do i <- mi cpos <- combinePoss w !? i col <- (combineItemListYou w !? i) <&> _itInvColor . snd return $ pictures [ fromMaybe mempty $ do strs <- fmap (fst . snd) (combineListInfo w !? i) return $ listPicturesAtOff (subInvX + 150) 60 cfig cpos $ map (color red . text) strs , fromMaybe mempty $ do csize <- combineSizes w !? i return $ listCursorNSW subInvX 60 cfig cpos col 15 csize , fromMaybe mempty $ do lnks <- map fst (combineItemListYou w) !? i return $ lnkMidPosInvSelsCol cfig w cpos col lnks <> foldMap (topCursorTypeWidth listCursorNESW (topInvW +2) cfig w) lnks <> combineCounts cfig w lnks ] ] InspectInventory -> mconcat [ selcursor' listCursorNESW , invHead cfig "INSPECT" , listPicturesAt subInvX 60 cfig $ map text (itmInfo it) ] 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 (determineInvSelCursorWidth w) cury <$ it selcursor = selcursor' selcursortype selcursortype | ButtonRight `M.member` _mouseButtons w = listCursorNESW | otherwise = listCursorNSW curpos = invSelPos w cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you w) equipcursor = case _crLeftInvSel cr of Just invid -> f cyan invid (_crInvEquipped cr IM.! invid) _ -> mempty equipcursors = IM.foldMapWithKey (f yellow) (_crInvEquipped cr) f col invid epos = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos rboptions = if ButtonRight `M.member` _mouseButtons w then drawRBOptions cfig w (_rbOptions w) else mempty itmInfo :: Maybe Item -> [String] itmInfo mit = fromMaybe [] $ do itm <- mit return (map show . M.assocs . _iyModules $ _itType itm) displayTerminal :: Int -> Configuration -> World -> Picture displayTerminal tid cfig w = fromMaybe mempty $ do tm <- w ^? terminals . ix tid return $ pictures [ invHead cfig (_tmTitle tm ++ ":T" ++ show tid) , renderListAt subInvX 60 cfig . displayTermInput tm . reverse . take (_tmMaxLines tm) $ _tmDisplayedLines tm ] where displayTermInput tm = case _tmInput tm of TerminalInput s hasfoc _ -> (++ [(displayInputText tm s++displayBlinkCursor hasfoc,white)]) displayInputText tm s | _tmStatus tm == TerminalReady = '>':T.unpack s | otherwise = "" displayBlinkCursor hasfoc | hasfoc = clockCycle 10 (V.fromList ["_",""]) w | otherwise = [] drawRBOptions :: Configuration -> World -> RightButtonOptions -> Picture drawRBOptions cfig w EquipOptions{_opEquip = es,_opSel=i, _opAllocateEquipment=ae} = listPicturesAtOff 342 0 cfig (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 midtext str = listTextPictureAt 252 0 cfig curpos (text str) extratext str = listTextPictureAt 432 0 cfig curpos (text (str ++ deactivatetext)) deactivatetext = case w ^? rbOptions . opActivateEquipment . deactivateEquipment of Just k -> " DEACTIVATES " ++ show (_iyBase $ _itType (_crInv (you w) IM.! k)) Nothing -> "" curpos = invSelPos w otheritem j = show $ _iyBase $ _itType (_crInv (you w) IM.! j) drawRBOptions _ _ _ = mempty eqPosText :: EquipPosition -> String eqPosText ep = case ep of OnHead -> "HEAD" OnChest -> "CHEST" OnBack -> "BACK" OnLeftWrist -> "L.WRIST" OnRightWrist -> "R.WRIST" OnLegs -> "LEGS" OnSpecial -> "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 ItemItselfConsumable{} -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-': show (length is + 1)) _ -> mempty f _ = mempty lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture lnkMidPosInvSelsCol cfig w i col = winScale cfig . concatMap (\j -> zConnectCol rp (V2 18 0+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 topCursorTypeWidth :: (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture) -> Int -> Configuration -> World -> Int -> Picture topCursorTypeWidth ctype width cfig w i = ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (selNumSlots i w) determineInvSelCursorWidth :: World -> Int determineInvSelCursorWidth w = case _rbOptions w of NoRightButtonOptions -> topInvW EquipOptions {} -> if ButtonRight `M.member` _mouseButtons w then 47 else topInvW --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) $ itemDisplay 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 $ reverse $ rectNSWE 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' :: Creature -> (Int,Item) -> [Picture] {-# INLINE itemText' #-} itemText' cr (i,it) = f $ case _itCurseStatus it of UndroppableIdentified -> map (color yellow . text) (itemDisplay it) _ | crSel cr == i -> map (color thecolor . text) (selectedItemDisplay cr it) _ -> map (color thecolor . text) (itemDisplay it) where thecolor = _itInvColor it f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*")) itemText :: Item -> [Picture] {-# INLINE itemText #-} itemText it = f $ case _itCurseStatus it of UndroppableIdentified -> map (color yellow . text) (itemDisplay it) -- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90))) _ -> map (color thecolor . text) (itemDisplay 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