Various refactoring
This commit is contained in:
@@ -0,0 +1,32 @@
|
||||
module Dodge.Render.Connectors
|
||||
( zConnect
|
||||
, bConnect
|
||||
, lConnect
|
||||
) where
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
zConnect :: Point2 -> Point2 -> Picture
|
||||
zConnect (V2 x y) (V2 a b) = line $ map toV2
|
||||
[(x,y)
|
||||
,(0.5 * (x+a), y)
|
||||
,(0.5 * (x+a), b)
|
||||
,(a, b)
|
||||
]
|
||||
|
||||
bConnect :: Point2 -> Point2 -> Picture
|
||||
bConnect (V2 x y) (V2 z w) = pictures
|
||||
[ bline 0.2 0.050 0.010
|
||||
, bline 0.5 0.045 0.005
|
||||
, bline 0.5 0.035 0.002
|
||||
] --cheapo antialiasing
|
||||
where
|
||||
bline alph lwidth rwidth
|
||||
= bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (V2 x y) (V2 0 y) (V2 z w)
|
||||
|
||||
lConnect :: Point2 -> Point2 -> Picture
|
||||
lConnect sp@(V2 _ y) ep@(V2 x _) = line
|
||||
[ sp
|
||||
, V2 x y
|
||||
, ep
|
||||
]
|
||||
+90
-107
@@ -1,12 +1,16 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Render.HUD
|
||||
( hudDrawings
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Base.Window
|
||||
import Dodge.Inventory
|
||||
import Dodge.Render.Connectors
|
||||
import Picture
|
||||
import Geometry
|
||||
import Padding
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
@@ -14,33 +18,39 @@ import qualified Data.Set as S
|
||||
import Control.Lens
|
||||
import SDL (MouseButton (..))
|
||||
|
||||
winScale :: World -> Picture -> Picture
|
||||
winScale w = scale (2 / getWindowX w) (2 / getWindowY w)
|
||||
|
||||
hudDrawings :: World -> Picture
|
||||
hudDrawings w =
|
||||
(winScale w . dShadCol white $ displayHP 0 w)
|
||||
++ (winScale w . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w))
|
||||
++ selectionText
|
||||
hudDrawings w = pictures
|
||||
[ winScale w . dShadCol white $ displayHP 0 w
|
||||
, winScale w . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
|
||||
, selectionText
|
||||
]
|
||||
where
|
||||
selectionText =
|
||||
if _carteDisplay w
|
||||
then concat $ drawLocations w
|
||||
then drawLocations w
|
||||
else drawInventory w
|
||||
|
||||
winScale :: World -> Picture -> Picture
|
||||
{-# INLINE winScale #-}
|
||||
winScale w = scale (2 / getWindowX w) (2 / getWindowY w)
|
||||
|
||||
drawInventory :: World -> Picture
|
||||
drawInventory w = case _inventoryMode w of
|
||||
TopInventory -> closeObjectTexts w
|
||||
++ topInvCursor col iPos w
|
||||
++ concat (displayInv 0 w)
|
||||
TweakInventory ->
|
||||
concat (mCurs it w)
|
||||
++ cursorAt 120 col 5 0 iPos w
|
||||
++ cursorsZ w iPos it
|
||||
++ concat (displayInv 0 w )
|
||||
++ concat (displayMidList w (ammoTweakStrings it) "TWEAK")
|
||||
CombineInventory -> concat (displayInv 0 w) ++ invHead w "COMBINE"
|
||||
InspectInventory -> concat (displayInv 0 w) ++ invHead w "INSPECT"
|
||||
drawInventory w = displayInv 0 w `appendPic` subInventoryDisplay w
|
||||
|
||||
subInventoryDisplay :: World -> Picture
|
||||
subInventoryDisplay w = case _inventoryMode w of
|
||||
TopInventory -> pictures
|
||||
[ closeObjectTexts w
|
||||
, topInvCursor col iPos w
|
||||
]
|
||||
TweakInventory -> pictures
|
||||
[ mCurs it w
|
||||
, cursorAt 120 col 5 0 iPos w
|
||||
, cursorsZ w iPos it
|
||||
, displayMidList w (ammoTweakStrings it) "TWEAK"
|
||||
]
|
||||
CombineInventory -> invHead w "COMBINE"
|
||||
InspectInventory -> invHead w "INSPECT"
|
||||
where
|
||||
itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
|
||||
iPos = _crInvSel $ _creatures w IM.! _yourID w
|
||||
@@ -49,9 +59,10 @@ drawInventory w = case _inventoryMode w of
|
||||
|
||||
cursorsZ :: World -> Int -> Item -> Picture
|
||||
cursorsZ w ipos it = case it ^? wpAmmo . amParamSel of
|
||||
Nothing -> winScale w $ zDraw sp (V2 (155- hw) ( hh - 77.5))
|
||||
Just jpos -> winScale w $ zDraw sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
|
||||
Nothing -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5))
|
||||
Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
|
||||
where
|
||||
f = winScale w . color white
|
||||
hh = halfHeight w
|
||||
hw = halfWidth w
|
||||
sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
|
||||
@@ -60,59 +71,45 @@ topInvCursor :: Color -> Int -> World -> Picture
|
||||
topInvCursor col iPos w
|
||||
| ButtonRight `S.member` _mouseButtons w =
|
||||
cursorAt 100 col 5 0 iPos w
|
||||
++ openCursorAt 20 col 105 0 iPos w
|
||||
| otherwise = openCursorAt 120 col 5 0 iPos w
|
||||
`appendPic` openCursorAt 20 col 105 0 iPos w
|
||||
| otherwise = mainListCursor col iPos w
|
||||
|
||||
ammoTweakStrings :: Item -> [String]
|
||||
ammoTweakStrings it = case it ^? wpAmmo . amPjParams of
|
||||
Just l -> map pjTweakString l
|
||||
_ -> ["NOT TWEAKABLE"]
|
||||
|
||||
mCurs :: Item -> World -> [Picture]
|
||||
mCurs :: Item -> World -> Picture
|
||||
mCurs it w = case it ^? wpAmmo . amParamSel of
|
||||
Nothing -> []
|
||||
Just i
|
||||
| ButtonRight `S.member` _mouseButtons w ->
|
||||
pictures
|
||||
[cursorAt x white y 60 i w
|
||||
,openCursorAt 20 white (x+y) 60 i w
|
||||
]
|
||||
| otherwise -> [openCursorAt 140 white 155 60 i w]
|
||||
| otherwise -> openCursorAt 140 white 155 60 i w
|
||||
where
|
||||
x = 117.5
|
||||
y = 155
|
||||
|
||||
zDraw :: Point2 -> Point2 -> Picture
|
||||
zDraw (V2 x y) (V2 a b) = line $ map toV2
|
||||
[(x,y)
|
||||
,(0.5 * (x+a), y)
|
||||
,(0.5 * (x+a), b)
|
||||
,(a, b)
|
||||
]
|
||||
|
||||
pjTweakString :: PjParam -> String
|
||||
pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
|
||||
|
||||
displayMidList :: World -> [String] -> String -> [Picture]
|
||||
displayMidList :: World -> [String] -> String -> Picture
|
||||
displayMidList w strs s =
|
||||
[invHead w s]
|
||||
++ renderListAt (V2 150 (-60)) (map (,white) strs) w
|
||||
invHead w s
|
||||
`appendPic` renderListAt 150 (-60) (map (,white) strs) w
|
||||
|
||||
invHead :: World -> String -> Picture
|
||||
invHead w s = winScale w . translate (-130) (halfHeight w - 40) . dShadCol white . scale 0.4 0.4 $ text s
|
||||
|
||||
|
||||
displayListTopLeft :: [(String,Color)] -> World -> [Picture]
|
||||
displayListTopLeft = renderListAt (V2 0 0)
|
||||
renderListAt :: Float -> Float -> [(String,Color)] -> World -> Picture
|
||||
renderListAt tx ty scols w =
|
||||
concatMapPic (winScale w) $ zipWith (listItemAt tx ty w) [0..] scols
|
||||
|
||||
renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture]
|
||||
renderListAt (V2 tx ty) scols w =
|
||||
map (winScale w) $ zipWith
|
||||
(translate (tx + 15-halfWidth w))
|
||||
( map (\x -> ty + halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) )
|
||||
( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
|
||||
|
||||
displayInv :: Int -> World -> [Picture]
|
||||
displayInv n w = displayListTopLeft scols w
|
||||
displayInv :: Int -> World -> Picture
|
||||
displayInv n w = renderListAt 0 0 scols w
|
||||
where
|
||||
scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n
|
||||
|
||||
@@ -120,30 +117,17 @@ itemStringCol :: Item -> (String,Color)
|
||||
itemStringCol NoItem = ("----", greyN 0.5)
|
||||
itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm)
|
||||
|
||||
drawLocations :: World -> [Picture]
|
||||
drawLocations wrld = displayListTopLeft locs wrld
|
||||
++ zipWith bFunc (displayListEndCoords wrld locTexts) locPoss
|
||||
drawLocations :: World -> Picture
|
||||
drawLocations wrld = pictures $
|
||||
renderListAt 0 0 locs wrld
|
||||
: zipWith bConnect (displayListEndCoords wrld locTexts) locPoss
|
||||
++ mapOverlay wrld
|
||||
++ [drawListCursor white iPos wrld]
|
||||
++ [mainListCursor white iPos wrld]
|
||||
where
|
||||
iPos = _selLocation wrld
|
||||
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld
|
||||
locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld
|
||||
locTexts = map fst locs
|
||||
bFunc (V2 x y) (V2 z w) = pictures
|
||||
[ bline 0.2 0.050 0.010
|
||||
, bline 0.5 0.045 0.005
|
||||
, bline 0.5 0.035 0.002
|
||||
] --cheapo antialiasing
|
||||
where
|
||||
bline alph lwidth rwidth
|
||||
= bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (V2 x y) (V2 0 y) (V2 z w)
|
||||
|
||||
displayListCoords :: World -> [Point2]
|
||||
displayListCoords w = map (g . f) [(1::Int)..]
|
||||
where
|
||||
f i = V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i))
|
||||
g (V2 x y) = V2 (2*x / getWindowX w) ( 2*y / getWindowY w)
|
||||
|
||||
displayListEndCoords :: World -> [String] -> [Point2]
|
||||
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
|
||||
@@ -154,7 +138,6 @@ displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
|
||||
h :: String -> Point2 -> Point2
|
||||
h s (V2 x y) = V2 (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) :
|
||||
@@ -172,18 +155,13 @@ mapWall w wl =
|
||||
c = _wlColor wl
|
||||
{- | Pictures of popup text for items close to your position.-}
|
||||
closeObjectTexts :: World -> Picture
|
||||
closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (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) = winScale w
|
||||
. tran
|
||||
. translate (xtran i) (negate (20 * fromIntegral i))
|
||||
. scale 0.1 0.1
|
||||
. color c
|
||||
$ text t
|
||||
tran = translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral invPos +1))
|
||||
closeObjectTexts w = pictures $
|
||||
renderListAt pushout (negate 20 * fromIntegral invPos)
|
||||
(map colAndText $ _closeActiveObjects w) 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
|
||||
@@ -191,39 +169,40 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
|
||||
mayIt = mayObj >>= maybeLeft
|
||||
maybeLeft (Left x) = Just x
|
||||
maybeLeft _ = Nothing
|
||||
pushout = 140
|
||||
xtran :: Int -> Float
|
||||
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 (V2 x y) = V2 (x*2/getWindowX w) ( y*2/getWindowY w)
|
||||
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 <- fmap (snd . colAndText) mayObj
|
||||
(theText,col) <- fmap colAndText mayObj
|
||||
let textWidth = 9 * fromIntegral (length theText)
|
||||
let col = maybe white (_itInvColor . _flIt) mayIt
|
||||
let p = V2 (textWidth + xtran 0 + pushout - halfWidth w)
|
||||
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
|
||||
let p' = V2 ( pushout - halfWidth w + 130)
|
||||
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
|
||||
return $ thickLineCol
|
||||
[(itScreenPos, withAlpha 0 col)
|
||||
,(sc p' , col)
|
||||
,(sc p , col)
|
||||
]
|
||||
(1 / halfWidth w)
|
||||
let p = V2 (textWidth + 15 + pushout - halfWidth w)
|
||||
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
|
||||
return . winScale w . color col $ lConnect p itScreenPos
|
||||
{- | Colour picture and add black drop shadow. -}
|
||||
dShadCol :: Color -> Picture -> Picture
|
||||
dShadCol c p = pictures
|
||||
[ color black $ uncurry translate (1.2,-1.2) p
|
||||
[ color black $ translate 1.2 (-1.2) p
|
||||
, color c p
|
||||
]
|
||||
|
||||
drawListCursor :: Color -> Int -> World -> Picture
|
||||
drawListCursor c = openCursorAt 120 c 5 0
|
||||
mainListCursor :: Color -> Int -> World -> Picture
|
||||
mainListCursor c = openCursorAt 120 c 5 0
|
||||
|
||||
listItemAt
|
||||
:: Float -- ^ x offset
|
||||
-> Float -- ^ y offset
|
||||
-> World
|
||||
-> Int -- ^ y offset (discrete)
|
||||
-> (String,Color) -- ^ The text item
|
||||
-> Picture
|
||||
listItemAt xoff yoff w yint (s,col)
|
||||
= translate (xoff + 15 - halfWidth w) (yoff + halfHeight w - (20 * (fromIntegral yint+1)))
|
||||
. scale 0.1 0.1
|
||||
. dShadCol col
|
||||
$ text s
|
||||
|
||||
openCursorAt
|
||||
:: Float -- ^ Width
|
||||
@@ -261,6 +240,10 @@ cursorAt wth col xoff yoff yint w = winScale w
|
||||
]
|
||||
|
||||
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
|
||||
displayHP n w = translate (halfWidth w-80) (halfHeight w-20)
|
||||
. scale 0.2 0.2
|
||||
. text
|
||||
. leftPad 5 ' '
|
||||
. show
|
||||
. _crHP
|
||||
$ _creatures w IM.! n
|
||||
|
||||
+15
-14
@@ -21,22 +21,23 @@ import Control.Lens
|
||||
import Data.Maybe
|
||||
import Data.List (partition)
|
||||
import qualified Data.IntMap.Lazy as IM
|
||||
--import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
||||
|
||||
worldPictures :: World -> Picture
|
||||
worldPictures w = concat $
|
||||
IM.elems (_decorations w) ++
|
||||
(map (dbArg _pjDraw) . IM.elems $ _projectiles w) ++
|
||||
(map (crDraw w) . IM.elems $ _creatures w) ++
|
||||
map (dbArg _ptDraw) (_particles w) ++
|
||||
[ testPic w
|
||||
, concatMap drawItem . IM.elems $ _floorItems w
|
||||
, concatMap (crDraw w) . IM.elems $ _creatures w
|
||||
, concatMap clDraw . reverse $ _clouds w
|
||||
, concatMap ppDraw . IM.elems $ _pressPlates w
|
||||
, concatMap btDraw (IM.elems (_buttons w))
|
||||
, concatMap (dbArg _ptDraw) $ _particles w
|
||||
, concatMap drawWallFloor (wallFloorsToDraw w)
|
||||
worldPictures w = pictures
|
||||
[pictures (_decorations w)
|
||||
,concatMapPic (dbArg _pjDraw) $ _projectiles w
|
||||
,concatMapPic (crDraw w) $ _creatures w
|
||||
,concatMapPic (dbArg _ptDraw) $ _particles w
|
||||
,testPic w
|
||||
,concatMapPic drawItem $ _floorItems w
|
||||
,concatMapPic (crDraw w) $ _creatures w
|
||||
,concatMapPic clDraw $ _clouds w
|
||||
,concatMapPic ppDraw $ _pressPlates w
|
||||
,concatMapPic btDraw $ _buttons w
|
||||
,concatMapPic drawWallFloor $ wallFloorsToDraw w
|
||||
]
|
||||
|
||||
foregroundPics :: World -> [Polyhedra]
|
||||
foregroundPics = _foregroundDecorations
|
||||
|
||||
@@ -58,7 +59,7 @@ customMouseCursor w =
|
||||
$ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
|
||||
|
||||
testPic :: World -> Picture
|
||||
testPic _ = []
|
||||
testPic _ = blank
|
||||
|
||||
-- [ setDepth (-1) . translate 0 0.8
|
||||
-- . scale 0.001 0.001 . text . show $ _crMvDir $ you w
|
||||
|
||||
Reference in New Issue
Block a user