Reorganise rendering in Dodge
This commit is contained in:
@@ -0,0 +1,174 @@
|
||||
module Dodge.Render.HUD
|
||||
where
|
||||
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Inventory
|
||||
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap as IM
|
||||
|
||||
import Control.Lens
|
||||
|
||||
hudDrawings :: World -> Picture
|
||||
hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $
|
||||
[ scaler . dShadCol white $ displayHP 0 w
|
||||
, scaler . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
|
||||
]
|
||||
++ selectionText
|
||||
where
|
||||
selectionText = if _carteDisplay w
|
||||
then drawLocations w
|
||||
else drawInventory w
|
||||
scaler = scale (2 / _windowX w) (2 / _windowY w)
|
||||
|
||||
drawInventory :: World -> [Picture]
|
||||
drawInventory w =
|
||||
[ closeObjectTexts w
|
||||
, drawListCursor (itCol (yourItem w)) iPos w
|
||||
]
|
||||
++ displayInv 0 w
|
||||
where
|
||||
itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
|
||||
iPos = _crInvSel $ _creatures w IM.! _yourID w
|
||||
|
||||
displayListTopLeft :: [(String,Color)] -> World -> [Picture]
|
||||
displayListTopLeft scols w =
|
||||
map scaler $ zipWith
|
||||
(translate (15-halfWidth w))
|
||||
( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) [0..] )
|
||||
( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
|
||||
where
|
||||
scaler = scale (2 / _windowX w) (2 / _windowY w)
|
||||
|
||||
displayInv :: Int -> World -> [Picture]
|
||||
displayInv n w = displayListTopLeft scols w
|
||||
where
|
||||
scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n
|
||||
|
||||
itemStringCol :: Item -> (String,Color)
|
||||
itemStringCol NoItem = ("----", greyN 0.5)
|
||||
itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm)
|
||||
|
||||
dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----"
|
||||
dItem' i = scale 0.1 0.1 $ dShadCol (_itInvColor i) t
|
||||
where t = text $ _itInvDisplay i i
|
||||
|
||||
drawLocations :: World -> [Picture]
|
||||
drawLocations w = displayListTopLeft locs w
|
||||
++ zipWith bFunc (displayListEndCoords w locTexts) locPoss
|
||||
++ mapOverlay w
|
||||
++ [drawListCursor white iPos w]
|
||||
where
|
||||
iPos = _selLocation w
|
||||
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
|
||||
locPoss = map (cartePosToScreen w . ($ w) . fst) . IM.elems . _seenLocations $ w
|
||||
zoom = _carteZoom w
|
||||
locTexts = fst . unzip $ locs
|
||||
bFunc (x,y) (z,w) = pictures
|
||||
[ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w)
|
||||
, bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w)
|
||||
, bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.035 0.002 (x,y) (0,y) (z,w)
|
||||
] --cheapo antialiasing
|
||||
|
||||
displayListCoords :: World -> [Point2]
|
||||
displayListCoords w = map (g . f) [1..]
|
||||
where
|
||||
f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) )
|
||||
g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
|
||||
|
||||
displayListEndCoords :: World -> [String] -> [Point2]
|
||||
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
|
||||
where
|
||||
f :: Int -> Point2
|
||||
f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) )
|
||||
g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
|
||||
h :: String -> Point2 -> Point2
|
||||
h s (x,y) = (x + 9 * fromIntegral (length s), y)
|
||||
|
||||
--bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
|
||||
|
||||
mapOverlay :: World -> [Picture]
|
||||
mapOverlay w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) :
|
||||
(mapMaybe (mapWall w) . IM.elems $ _walls w)
|
||||
|
||||
mapWall :: World -> Wall -> Maybe Picture
|
||||
mapWall w wl =
|
||||
if _wlSeen wl
|
||||
then Just . color c . polygon $ map (cartePosToScreen w) [x,x +.+ n2,y +.+ n2, y]
|
||||
else Nothing
|
||||
where
|
||||
t = normalizeV (y -.- x)
|
||||
-- n2 = 2 *.* vNormal t
|
||||
n2 = 20 *.* vNormal t
|
||||
(x:y:_) = (_wlLine wl)
|
||||
c = _wlColor wl
|
||||
|
||||
|
||||
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 (worldPosToScreen w $ objPos theObj))
|
||||
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)
|
||||
]
|
||||
|
||||
dShadCol :: Color -> Picture -> Picture
|
||||
dShadCol c p = pictures $
|
||||
[ color black $ uncurry translate (1.2,-1.2) p
|
||||
, color c p
|
||||
]
|
||||
|
||||
drawListCursor :: Color -> Int -> World -> Picture
|
||||
drawListCursor c iPos w = scale (2 / _windowX w) (2 / _windowY w)
|
||||
. translate (105-halfWidth w) (halfHeight w - (20* (fromIntegral iPos)) - 20)
|
||||
$ lineCol [(( 100,12.5) ,withAlpha 0 c)
|
||||
,((-100,12.5) ,c)
|
||||
,((-100,-7.5) ,c)
|
||||
,(( 100,-7.5) ,withAlpha 0 c)
|
||||
]
|
||||
|
||||
displayHP :: Int -> World -> Picture
|
||||
displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
|
||||
scale 0.2 0.2 $ text $ reverse $ take 5 $ (++ repeat ' ') $ reverse $ show
|
||||
$ _crHP $ _creatures w IM.! n
|
||||
|
||||
Reference in New Issue
Block a user