Refactor, try to limit dependencies
This commit is contained in:
+232
-205
@@ -1,53 +1,48 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Render.HUD
|
||||
( hudDrawings
|
||||
) where
|
||||
import Dodge.WorldPos
|
||||
import Dodge.Data
|
||||
import Dodge.Tweak.Show
|
||||
import Dodge.Item.Display
|
||||
import Dodge.Combine
|
||||
import Dodge.Clock
|
||||
module Dodge.Render.HUD (
|
||||
hudDrawings,
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import Dodge.Base
|
||||
--import Dodge.InputFocus
|
||||
--import Dodge.Combine.Combinations
|
||||
import Dodge.Clock
|
||||
import Dodge.Combine
|
||||
import Dodge.Data.Universe
|
||||
import Dodge.Inventory
|
||||
import Dodge.Inventory.ItemSpace
|
||||
import Dodge.Item.Display
|
||||
import Dodge.Render.Connectors
|
||||
import Dodge.Render.List
|
||||
import Picture
|
||||
import Dodge.Tweak.Show
|
||||
import Dodge.WorldPos
|
||||
import Geometry
|
||||
import Padding
|
||||
import ListHelp
|
||||
|
||||
import qualified Data.Vector as V
|
||||
--import Data.Foldable
|
||||
import Data.Maybe
|
||||
import qualified IntMapHelp 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 ListHelp
|
||||
import Padding
|
||||
import Picture
|
||||
import SDL (MouseButton (..))
|
||||
import qualified Data.Text as T
|
||||
--import Data.List
|
||||
--import Data.Bifunctor
|
||||
|
||||
hudDrawings :: Universe -> Picture
|
||||
hudDrawings uv = case _hudElement $ _hud (_cWorld w) of
|
||||
DisplayCarte -> drawCarte cfig w
|
||||
DisplayInventory subinv -> drawInGameHUD uv
|
||||
<> subInventoryDisplay subinv cfig w
|
||||
DisplayInventory subinv ->
|
||||
drawInGameHUD uv
|
||||
<> subInventoryDisplay subinv cfig w
|
||||
where
|
||||
w = _uvWorld uv
|
||||
cfig = _uvConfig uv
|
||||
|
||||
drawInGameHUD :: Universe -> Picture
|
||||
drawInGameHUD uv = pictures
|
||||
[ winScale cfig . dShadCol white $ displayHP 0 cfig w
|
||||
, listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv)
|
||||
, inventoryDisplay cfig w
|
||||
]
|
||||
drawInGameHUD uv =
|
||||
pictures
|
||||
[ winScale cfig . dShadCol white $ displayHP 0 cfig w
|
||||
, listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv)
|
||||
, inventoryDisplay cfig w
|
||||
]
|
||||
where
|
||||
w = _uvWorld uv
|
||||
cfig = _uvConfig uv
|
||||
@@ -57,13 +52,14 @@ 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 (_cWorld w))
|
||||
-- ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w))
|
||||
-- floorItemsColor = case _hudElement (_hud w) of
|
||||
-- DisplayInventory NoSubInventory -> id
|
||||
-- _ -> color invDimColor
|
||||
invlist =
|
||||
concatMap (itemText' cr) (IM.toList inv)
|
||||
++ displayFreeSlots
|
||||
++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects (_cWorld 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"]
|
||||
@@ -73,58 +69,72 @@ inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
|
||||
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 mtweaki -> pictures
|
||||
--[ mCurs it cfig w
|
||||
[ selcursor' listCursorNESW
|
||||
-- , cursorsZ cfig curpos it
|
||||
, fromMaybe mempty $ do
|
||||
tweaki <- mtweaki
|
||||
NoSubInventory ->
|
||||
pictures
|
||||
[ selcursor
|
||||
, closeobjectcursor
|
||||
, equipcursors
|
||||
, equipcursor -- the order is important, this should go on top of the other equipcursors
|
||||
, rboptions
|
||||
]
|
||||
TweakInventory mtweaki ->
|
||||
pictures
|
||||
--[ mCurs it cfig w
|
||||
[ selcursor' listCursorNESW
|
||||
, -- , cursorsZ cfig curpos it
|
||||
fromMaybe mempty $ do
|
||||
tweaki <- mtweaki
|
||||
-- consider moving this functionality out into a tweaks module
|
||||
tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki
|
||||
return $ lnkMidInvSel cfig w curpos tweaki
|
||||
<> listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 1
|
||||
, invHead cfig "TWEAK"
|
||||
, listPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
|
||||
]
|
||||
tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki
|
||||
return $
|
||||
lnkMidInvSel cfig w curpos tweaki
|
||||
<> listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 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
|
||||
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)
|
||||
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
|
||||
@@ -134,15 +144,16 @@ subInventoryDisplay subinv cfig w = case subinv of
|
||||
| ButtonRight `M.member` _mouseButtons w = listCursorNESW
|
||||
| otherwise = listCursorNSW
|
||||
curpos = invSelPos w
|
||||
cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you 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
|
||||
rboptions =
|
||||
if ButtonRight `M.member` _mouseButtons w
|
||||
then drawRBOptions cfig w (_rbOptions w)
|
||||
else mempty
|
||||
|
||||
itmInfo :: Maybe Item -> [String]
|
||||
itmInfo mit = fromMaybe [] $ do
|
||||
@@ -152,38 +163,40 @@ itmInfo mit = fromMaybe [] $ do
|
||||
displayTerminal :: Int -> Configuration -> World -> Picture
|
||||
displayTerminal tid cfig w = fromMaybe mempty $ do
|
||||
tm <- w ^? cWorld . terminals . ix tid
|
||||
return $ pictures
|
||||
[ invHead cfig (_tmTitle tm ++ ":T" ++ show tid)
|
||||
, renderListAt subInvX 60 cfig
|
||||
. displayTermInput tm
|
||||
. reverse
|
||||
. take (_tmMaxLines tm)
|
||||
$ _tmDisplayedLines tm
|
||||
]
|
||||
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)])
|
||||
TerminalInput s hasfoc _ -> (++ [(displayInputText tm s ++ displayBlinkCursor hasfoc, white)])
|
||||
displayInputText tm s
|
||||
| _tmStatus tm == TerminalReady = '>':T.unpack s
|
||||
| _tmStatus tm == TerminalReady = '>' : T.unpack s
|
||||
| otherwise = ""
|
||||
displayBlinkCursor hasfoc | hasfoc = clockCycle 10 (V.fromList ["_",""]) w
|
||||
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"
|
||||
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))
|
||||
@@ -196,13 +209,13 @@ 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"
|
||||
OnHead -> "HEAD"
|
||||
OnChest -> "CHEST"
|
||||
OnBack -> "BACK"
|
||||
OnLeftWrist -> "L.WRIST"
|
||||
OnRightWrist -> "R.WRIST"
|
||||
OnLegs -> "LEGS"
|
||||
OnSpecial -> "EQUIPPED"
|
||||
|
||||
topInvW :: Int
|
||||
topInvW = 15
|
||||
@@ -211,19 +224,20 @@ 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
|
||||
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))
|
||||
-- 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
|
||||
|
||||
hw = halfWidth cfig
|
||||
|
||||
--lnkMidPosInvSels :: Configuration -> World -> Int -> [Int] -> Picture
|
||||
--lnkMidPosInvSels cfig w i = winScale cfig
|
||||
-- . color white
|
||||
--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))
|
||||
@@ -234,32 +248,38 @@ lnkMidInvSel cfig w lefti midi = winScale cfig
|
||||
combineCounts :: Configuration -> World -> [Int] -> Picture
|
||||
combineCounts cfig w = winScale cfig . foldMap f . group
|
||||
where
|
||||
f (i:is) = case yourInv w ^? ix i . itUse . useAmount of
|
||||
Just _ -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-': show (length is + 1))
|
||||
f (i : is) = case yourInv w ^? ix i . itUse . useAmount of
|
||||
Just _ -> 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
|
||||
. foldMap (\j -> zConnectCol rp (V2 18 0+selNumMidHeight cfig w j) col white white (selNumCol j w))
|
||||
lnkMidPosInvSelsCol cfig w i col =
|
||||
winScale cfig
|
||||
. foldMap (\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))
|
||||
-- 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
|
||||
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)
|
||||
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
|
||||
EquipOptions{} ->
|
||||
if ButtonRight `M.member` _mouseButtons w
|
||||
then 47
|
||||
else topInvW
|
||||
|
||||
--listSelHeight :: Configuration -> World -> Int -> Float
|
||||
--listSelHeight
|
||||
@@ -278,74 +298,77 @@ tweakString :: TweakParam -> String
|
||||
tweakString tp = rightPad 12 ' ' (show $ _tweakType tp) ++ " " ++ showTweak 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
|
||||
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]
|
||||
Right bt -> [color yellow $ textindent $ _btText bt]
|
||||
where
|
||||
textindent = text . (replicate clObjIntIn ' '++)
|
||||
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]
|
||||
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 (_cWorld w)
|
||||
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ _cWorld w
|
||||
locs = map (\(_, s) -> (s, white)) . IM.elems . _seenLocations $ _cWorld w
|
||||
locPoss = map (cartePosToScreen cfig w . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations $ _cWorld w
|
||||
locTexts = map fst locs
|
||||
|
||||
displayListEndCoords :: Configuration -> [String] -> [Point2]
|
||||
displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1..]
|
||||
where
|
||||
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))
|
||||
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 (_cWorld w))
|
||||
mapOverlay cfig w =
|
||||
(color (withAlpha 0.5 black) . polygon $ reverse $ rectNSWE 1 (-1) 1 (-1)) :
|
||||
(mapMaybe (mapWall cfig w) . IM.elems $ _walls (_cWorld 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
|
||||
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
|
||||
(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.-}
|
||||
-- | 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)
|
||||
--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)
|
||||
@@ -358,11 +381,11 @@ mapWall cfig w wl =
|
||||
-- maybeLeft (Left x) = Just x
|
||||
-- maybeLeft _ = Nothing
|
||||
-- pushout = 120
|
||||
-- objPos obj = case obj of
|
||||
-- objPos obj = case obj of
|
||||
-- Left flit -> _flItPos flit
|
||||
-- Right bt -> _btPos bt
|
||||
-- mayScreenPos = fmap (worldPosToScreen w . objPos) mayObj
|
||||
-- maybeLine = do
|
||||
-- maybeLine = do
|
||||
-- itScreenPos <- mayScreenPos
|
||||
-- (theText,col) <- fmap colAndText mayObj
|
||||
-- let textWidth = 9 * fromIntegral (length theText)
|
||||
@@ -373,9 +396,9 @@ mapWall cfig w wl =
|
||||
mainListCursor :: Color -> Int -> Configuration -> Picture
|
||||
mainListCursor c = openCursorAt 120 c 5 0
|
||||
|
||||
itemText' :: Creature -> (Int,Item) -> [Picture]
|
||||
itemText' :: Creature -> (Int, Item) -> [Picture]
|
||||
{-# INLINE itemText' #-}
|
||||
itemText' cr (i,it) = f $ case _itCurseStatus it of
|
||||
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)
|
||||
@@ -383,40 +406,44 @@ itemText' cr (i,it) = f $ case _itCurseStatus it of
|
||||
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)))
|
||||
-- <> 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)
|
||||
]
|
||||
openCursorAt ::
|
||||
-- | Width
|
||||
Float ->
|
||||
Color ->
|
||||
-- | x offset
|
||||
Float ->
|
||||
-- | y offset
|
||||
Float ->
|
||||
-- | y offset (discrete)
|
||||
Int ->
|
||||
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 (_cWorld w) IM.! cid
|
||||
displayHP cid cfig w =
|
||||
translate (halfWidth cfig -80) (halfHeight cfig -20)
|
||||
. scale 0.2 0.2
|
||||
. text
|
||||
. leftPad 5 ' '
|
||||
. show
|
||||
. _crHP
|
||||
$ _creatures (_cWorld w) IM.! cid
|
||||
|
||||
Reference in New Issue
Block a user