diff --git a/src/Dodge/Rendering/HUD.hs b/src/Dodge/Rendering/HUD.hs new file mode 100644 index 000000000..889a271fa --- /dev/null +++ b/src/Dodge/Rendering/HUD.hs @@ -0,0 +1,61 @@ +module Dodge.Rendering.HUD + where + +import Dodge.Data +import Dodge.Base +import Dodge.Inventory + +import Picture +import Geometry + +import Data.Maybe + +closeObjectTexts :: World -> Picture +closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w) + ++ maybeToList maybeLine + where colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x) + colAndText (Right x) = (white, _btText x) + renderList i (c,t) = scale (2/_windowX w) (2/_windowY w) + . tran + . translate (xtran i) (0 - 20 * fromIntegral i) + . scale 0.1 0.1 + . color c + $ text t + tran = translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral invPos +1)) + youSel = _crInvSel $ you w + freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w + invPos = fromMaybe youSel freeSlot + mayObj = listToMaybe $ _closeActiveObjects w + mayIt = mayObj >>= maybeLeft + maybeLeft (Left x) = Just x + maybeLeft _ = Nothing + pushout = 140 + xtran 0 = case mayIt of Nothing -> 25 + _ -> -25 + xtran _ = 0 + objPos obj = case obj of Left flit -> _flItPos flit + Right bt -> _btPos bt + mayScreenPos = mayObj >>= (\theObj -> + Just (sc $ rotateV (0 - _cameraRot w) + $ _cameraZoom w *.* (objPos theObj + -.- _cameraPos w + ) + ) + ) + sc (x, y) = (x*2/_windowX w, y*2/_windowY w) + maybeLine = do + itScreenPos <- mayScreenPos + theText <- fmap (snd . colAndText) mayObj + let textWidth = 9 * fromIntegral (length theText) + let col = fromMaybe white $ fmap (_itInvColor . _flIt) mayIt + let p = (textWidth + xtran 0 + pushout - halfWidth w + , halfHeight w - 20* (fromIntegral invPos +1) + 2.5 + ) + let p' = ( pushout - halfWidth w + 130 + , halfHeight w - 20* (fromIntegral invPos +1) + 2.5 + ) + return $ lineCol + [(itScreenPos, withAlpha 0 col) + ,(sc p' , col) + ,(sc p , col) + ]