Add hud module

2021-03-10 05:10:45 +01:00
parent 64df420020
commit 5a16086743
1 changed files with 61 additions and 0 deletions
@@ -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)
+                            ]