justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Work on inventory ui

Browse Source
This commit is contained in:
justin
2023-05-14 22:22:21 +01:00
parent 3499384d38
commit 1cec50c5ab
9 changed files with 150 additions and 165 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/HUD.hs
+10 -8
View File
@@ -1,17 +1,17 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-} {-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.HUD where module Dodge.Data.HUD where
import Dodge.Data.Combine
import Dodge.Data.SelectionList
import Dodge.Data.Button
import Dodge.Data.FloorItem
import Control.Lens import Control.Lens
import Geometry.Data
import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict (IntMap)
import Dodge.Data.Button
import Dodge.Data.Combine
import Dodge.Data.FloorItem
import Dodge.Data.SelectionList
import Geometry.Data
data HUDElement data HUDElement
= DisplayInventory = DisplayInventory
@@ -23,12 +23,13 @@ data HUDElement
data SubInventory data SubInventory
= NoSubInventory = NoSubInventory
| ExamineInventory {_subInvMSel :: Maybe Int} | ExamineInventory {_subInvMSel :: Maybe Int}
-- | CombineInventory {_subInvMap :: SelectionIntMap CombinableItem} | CombineInventory
| CombineInventory {_ciCombinations :: IntMap (SelectionItem CombinableItem) { _ciCombinations :: IntMap (SelectionItem CombinableItem)
, _ciSections :: SelectionSections CombinableItem , _ciSections :: SelectionSections CombinableItem
} }
| LockedInventory | LockedInventory
| DisplayTerminal {_termID :: Int} | DisplayTerminal {_termID :: Int}
-- deriving (Eq, Ord, Show, Read) --Generic, Flat) -- deriving (Eq, Ord, Show, Read) --Generic, Flat)
data HUD = HUD data HUD = HUD
@@ -38,6 +39,7 @@ data HUD = HUD
, _carteRot :: Float , _carteRot :: Float
, _closeObjects :: [Either FloorItem Button] , _closeObjects :: [Either FloorItem Button]
} }
-- deriving (Eq, Ord, Show, Read) --Generic, Flat) -- deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''HUD makeLenses ''HUD
src/Dodge/ListDisplayParams.hs
+7 -8
View File
@@ -33,21 +33,20 @@ invDisplayParams w =
& ldpWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w) & ldpWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w)
& ldpPos . spPixelOff .~ V2 6 (-1) & ldpPos . spPixelOff .~ V2 6 (-1)
where where
selcursortype selcursortype = case w ^? hud . hudElement . subInventory of
| isexaminesub || ButtonRight `M.member` _mouseButtons (_input w) = [North, South, East, West] _ | ButtonRight `M.member` _mouseButtons (_input w) -> [North, South, East, West]
| otherwise = [North, South, West] Just ExamineInventory{} -> [North, South, East, West]
isexaminesub = case w ^? hud . hudElement . subInventory of Just CombineInventory{} -> []
Just ExamineInventory{} -> True _ -> [North, South, West]
_ -> False
secondColumnParams :: ListDisplayParams secondColumnParams :: ListDisplayParams
secondColumnParams = secondColumnParams =
defaultListDisplayParams defaultListDisplayParams
& ldpPos . spPixelOff .~ V2 subInvX (-71) & ldpPos . spPixelOff .~ V2 subInvX (-81)
& ldpCursorSides .~ [North, South, West] & ldpCursorSides .~ [North, South, West]
subInvX :: Float subInvX :: Float
subInvX = 10 * fromIntegral topInvW + 50 subInvX = 10 * fromIntegral topInvW + 70
topInvW :: Int topInvW :: Int
topInvW = 15 topInvW = 15
src/Dodge/Render/HUD.hs
+60 -57
View File
@@ -3,7 +3,6 @@ module Dodge.Render.HUD (
drawHUD, drawHUD,
) where ) where
import Dodge.Item.Display
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
@@ -20,6 +19,7 @@ import Dodge.Data.World
import Dodge.Default.SelectionList import Dodge.Default.SelectionList
import Dodge.Equipment.Text import Dodge.Equipment.Text
import Dodge.Inventory import Dodge.Inventory
import Dodge.Item.Display
import Dodge.Item.Info import Dodge.Item.Info
import Dodge.ListDisplayParams import Dodge.ListDisplayParams
import Dodge.Render.Connectors import Dodge.Render.Connectors
@@ -74,14 +74,14 @@ drawCombineInventory cfig sss w =
drawExamineInventory :: Configuration -> Maybe Int -> World -> Picture drawExamineInventory :: Configuration -> Maybe Int -> World -> Picture
drawExamineInventory cfig mtweaki w = drawExamineInventory cfig mtweaki w =
invHead cfig "EXAMINE" invHead cfig "EXAMINE"
<> examineInventoryExtra mtweaki itm cfig <> examineInventoryExtra mtweaki cfig
<> drawSelectionList <> drawSelectionList
secondColumnParams secondColumnParams
cfig cfig
( defaultSelectionList & slItems .~ ammoTweakSelectionItems itm ( defaultSelectionList & slItems .~ tweakItems itm
++ map ++ map
f f
( makeParagraph 60 $ ( makeParagraph 55 $
yourAugmentedItem yourAugmentedItem
itemInfo itemInfo
(yourInfo (you w)) (yourInfo (you w))
@@ -127,8 +127,8 @@ drawRBOptions cfig w = fromMaybe mempty $ do
ae <- w ^? rbOptions . opAllocateEquipment ae <- w ^? rbOptions . opAllocateEquipment
sss <- w ^? hud . hudElement . diSections sss <- w ^? hud . hudElement . diSections
(i', j) <- sss ^? sssExtra . sssSelPos . _Just (i', j) <- sss ^? sssExtra . sssSelPos . _Just
curpos <- selSecSelPos i' j sss curpos <- selSecYint i' j sss
let ytext = drawListElement 0 1 curpos . text let ytext = drawListElement 0 1 0 curpos . text
midstr = case ae of midstr = case ae of
DoNotMoveEquipment -> "" DoNotMoveEquipment -> ""
PutOnEquipment{} -> " PUT ON" PutOnEquipment{} -> " PUT ON"
@@ -143,62 +143,71 @@ drawRBOptions cfig w = fromMaybe mempty $ do
"REMOVES " ++ otheritem rid "REMOVES " ++ otheritem rid
_ -> "" _ -> ""
return $ return $
toTopLeft cfig toTopLeft cfig $
$ translate 290 (-1) (ytext midstr) translate 290 (-1) (ytext midstr)
<> translate 160 (-1) (listCursorChooseBorderScale 0 1 [North,South] curpos 0 white 21 1) <> translate 160 (-1) (listCursorChooseBorderScale 0 1 [North, South] curpos 0 white 21 1)
<> translate 380 (-1) (drawListYoff (curpos - i) (map (text . eqPosText) es)) <> translate
<> translate 380 (-1) (listCursorChooseBorderScale 0 1 [East] (curpos - i) 0 white 7 (length es)) 380
<> translate 380 (-1) (listCursorChooseBorderScale 0 1 [West] (curpos + 1) 0 white 7 (length es - (i+1))) (-1)
<> translate 380 (-1) (listCursorChooseBorderScale 0 1 [West] (curpos - i) 0 white 7 i) ( drawListYoff (curpos - i) (map (text . eqPosText) es)
<> translate 380 (-1) (maybetopborder i curpos) <> listCursorChooseBorderScale 0 1 [East] (curpos - i) 0 white 7 (length es)
<> translate 380 (-1) (maybebottomborder i (length es) curpos) <> listCursorChooseBorderScale 0 1 [West] (curpos + 1) 0 white 7 (length es - (i + 1))
<> translate 460 (-1) (ytext extrastr) <> listCursorChooseBorderScale 0 1 [West] (curpos - i) 0 white 7 i
<> maybetopborder i curpos
<> maybebottomborder i (length es) curpos
)
<> translate 460 (-1) (ytext extrastr)
where where
maybetopborder 0 curpos= listCursorChooseBorderScale 0 1 [North] curpos 0 white 7 1 maybetopborder 0 curpos = listCursorChooseBorderScale 0 1 [North] curpos 0 white 7 1
maybetopborder _ _ = mempty maybetopborder _ _ = mempty
maybebottomborder a b curpos maybebottomborder a b curpos
| a == b - 1 | a == b - 1 =
= listCursorChooseBorderScale 0 1 [South] curpos 0 white 7 1 listCursorChooseBorderScale 0 1 [South] curpos 0 white 7 1
| otherwise = mempty | otherwise = mempty
otheritem j = fromMaybe "" $ do otheritem j = fromMaybe "" $ do
itm <- you w ^? crInv . ix j itm <- you w ^? crInv . ix j
return $ itemBaseName itm return $ itemBaseName itm
examineInventoryExtra :: Maybe Int -> Maybe Item -> Configuration -> Picture examineInventoryExtra :: Maybe Int -> Configuration -> Picture
examineInventoryExtra mtweaki mitm cfig = fromMaybe mempty $ do examineInventoryExtra mtweaki cfig = fromMaybe mempty $ do
tweaki <- mtweaki tweaki <- mtweaki
-- consider moving this functionality out into a tweaks module -- consider moving this functionality out into a tweaks module
tparam <- mitm ^? _Just . itTweaks . tweakParams . ix tweaki --tparam <- mitm ^? _Just . itTweaks . tweakParams . ix tweaki
return $ return $
toTopLeft cfig $ toTopLeft cfig $
translate subInvX (-60) $ translate subInvX (-71) $
listCursorNSW tweaki 0 white (length $ showTweak tparam) 15 --listCursorChooseBorderScale 0 1 [North,South,West] tweaki 0 white (length $ showTweak tparam) 1
listCursorChooseBorderScale 0 1 [North, South, West] tweaki 0 white 10 1
combineInventoryExtra :: SelectionSections CombinableItem -> Configuration -> World -> Picture combineInventoryExtra :: SelectionSections CombinableItem -> Configuration -> World -> Picture
combineInventoryExtra sss cfig w = fromMaybe mempty $ do combineInventoryExtra sss cfig w = fromMaybe mempty $ do
(i, j) <- sss ^? sssExtra . sssSelPos . _Just (i, j) <- sss ^? sssExtra . sssSelPos . _Just
cpos <- selSecYint i j sss
si <- sss ^? sssSections . ix i . ssItems . ix j si <- sss ^? sssSections . ix i . ssItems . ix j
cpos <- selSecSelPos i j sss
let col = _siColor si let col = _siColor si
return $ return $
mconcat mconcat
[ fromMaybe mempty $ do [ fromMaybe mempty $ do
strs <- si ^? siPayload . ciInfo strs <- si ^? siPayload . ciInfo
return $ toTopLeft cfig (translate (subInvX + 150) 60 $ drawListYoff cpos $ map (color red . text) strs) return
. translate 160 0
-- it would be better to get the width of the selection list from elsewhere
. translateScreenPos cfig (secondColumnParams ^. ldpPos)
$ drawListYoff cpos $ map (color red . text) strs
, fromMaybe mempty $ do , fromMaybe mempty $ do
lnks <- si ^? siPayload . ciInvIDs lnks <- si ^? siPayload . ciInvIDs
return $ return $
lnkMidPosInvSelsCol cfig w cpos col lnks lnkMidPosInvSelsCol cfig w j col lnks
<> foldMap invcursor lnks <> foldMap invcursor lnks
<> combineCounts cfig w lnks <> combineCounts cfig w lnks
] ]
where where
invcursor i = fromMaybe mempty $ do invcursor i = fromMaybe mempty $ do
sss' <- w ^? hud . hudElement . diSections sss' <- w ^? hud . hudElement . diSections
let idp = invDisplayParams w let idp = (invDisplayParams w & ldpCursorSides .~ [North, South, East, West])
return $ return $
translateScreenPos cfig (idp ^. ldpPos) $ translateScreenPos cfig (idp ^. ldpPos) $
selSecDrawCursor 17 [North, South, East] idp sss' 0 i selSecDrawCursor 17 idp (sss' & sssExtra . sssSelPos ?~ (0, i))
displayTerminal :: Int -> Configuration -> LWorld -> Picture displayTerminal :: Int -> Configuration -> LWorld -> Picture
displayTerminal tid cfig w = fromMaybe mempty $ do displayTerminal tid cfig w = fromMaybe mempty $ do
@@ -231,9 +240,16 @@ combineCounts cfig w = foldMap f . group
f (i : is) = fromMaybe mempty $ do f (i : is) = fromMaybe mempty $ do
_ <- yourInv w ^? ix i . itUse . useAmount _ <- yourInv w ^? ix i . itUse . useAmount
sss <- w ^? hud . hudElement . diSections sss <- w ^? hud . hudElement . diSections
p <- selNumTextEndPos cfig (invDisplayParams w) sss 0 i --p <- selNumTextEndPos cfig (invDisplayParams w) sss 0 i
col <- selSecSelCol 0 i sss col <- selSecSelCol 0 i sss
return $ color col $ uncurryV translate p . scale 0.1 0.1 . text $ ('-' : show (length is + 1)) yint <- selSecYint 0 i sss
--return $ color col $ uncurryV translate p . scale 0.1 0.1 . text $ ('-' : show (length is + 1))
return
. translateScreenPos cfig (invDisplayParams w ^. ldpPos)
. color col
. drawListElement 0 1 15 yint
. text
$ ('-' : show (length is + 1))
f _ = mempty f _ = mempty
lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
@@ -241,15 +257,14 @@ lnkMidPosInvSelsCol cfig w i col = foldMap f
where where
f j = fromMaybe mempty $ do f j = fromMaybe mempty $ do
sss <- w ^? hud . hudElement . diSections sss <- w ^? hud . hudElement . diSections
h <- selNumEndMidHeight cfig (invDisplayParams w) sss 0 j combinesss <- w ^? hud . hudElement . subInventory . ciSections
lp <- selNumPos cfig (invDisplayParams w) sss 0 j
rp <- selNumPos cfig secondColumnParams combinesss 0 i
invcol <- selSecSelCol 0 j sss invcol <- selSecSelCol 0 j sss
return $ zConnectCol rp (V2 18 0 + h) col white white invcol return $ zConnectCol (rp - V2 5 0) (lp + V2 175 0) col white white invcol
rp = V2 (190 - hw) (hh - (20 * fromIntegral i + 77.5))
hh = halfHeight cfig
hw = halfWidth cfig
ammoTweakSelectionItems :: Maybe Item -> [SelectionItem ()] tweakItems :: Maybe Item -> [SelectionItem ()]
ammoTweakSelectionItems = textSelItems . ammoTweakStrings tweakItems = textSelItems . ammoTweakStrings
ammoTweakStrings :: Maybe Item -> [String] ammoTweakStrings :: Maybe Item -> [String]
ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
@@ -261,7 +276,7 @@ tweakString tp = rightPad 12 ' ' (show $ _tweakType tp) ++ " " ++ showTweak tp
invHead :: Configuration -> String -> Picture invHead :: Configuration -> String -> Picture
invHead cfig = invHead cfig =
translateScreenPos cfig (fromTopLeft (V2 subInvX 80)) translateScreenPos cfig (fromTopLeft (V2 (subInvX - 5) 80))
. dShadCol white . dShadCol white
. scale 0.4 0.4 . scale 0.4 0.4
. textJustifyLeft . textJustifyLeft
@@ -323,34 +338,22 @@ picsToSelectable pics =
, _siPayload = () , _siPayload = ()
} }
-- there are still more ListDisplayParams to integrate here selNumPos ::
selNumTextEndPos :: Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Maybe Point2
selNumTextEndPos cfig ldp sss i j = do
ipos <- selSecSelPos i j sss
return $ V2 (150 - hw) (hh - ((s * 10 + ygap) * (fromIntegral ipos + 1)))
where
s = _ldpScale ldp
ygap = _ldpVerticalGap ldp
hh = halfHeight cfig
hw = halfWidth cfig
selNumEndMidHeight ::
Configuration -> Configuration ->
ListDisplayParams -> ListDisplayParams ->
SelectionSections a -> SelectionSections a ->
Int -> Int ->
Int -> Int ->
Maybe Point2 Maybe Point2
selNumEndMidHeight cfig ldp sss i j = do selNumPos cfig ldp sss i j = do
ipos <- selSecSelPos i j sss ipos <- selSecYint i j sss
size <- selSecSelSize i j sss size <- selSecSelSize i j sss
--let bump = negate $ (10 * s + ygap) * fromIntegral size return $
return $ V2 (150 - hw) (hh - ((10 * s + ygap) * (fromIntegral ipos + fromIntegral size * 0.5))) screenPosAbs cfig (ldp ^. ldpPos)
+ V2 0 (negate (20 * s + ygap) * (fromIntegral ipos + fromIntegral size * 0.5))
where where
s = _ldpScale ldp s = _ldpScale ldp
ygap = _ldpVerticalGap ldp ygap = _ldpVerticalGap ldp
hh = halfHeight cfig
hw = halfWidth cfig
selSecSelCol :: Int -> Int -> SelectionSections a -> Maybe Color selSecSelCol :: Int -> Int -> SelectionSections a -> Maybe Color
selSecSelCol i j sss = sss ^? sssSections . ix i . ssItems . ix j . siColor selSecSelCol i j sss = sss ^? sssSections . ix i . ssItems . ix j . siColor
src/Dodge/Render/InfoBox.hs
+2 -1
View File
@@ -3,6 +3,7 @@ module Dodge.Render.InfoBox
, renderInfoListsAt , renderInfoListsAt
) where ) where
import Dodge.Data.CardinalPoint -- this should be imported implicitly
import Dodge.Base import Dodge.Base
import Dodge.Data.Camera import Dodge.Data.Camera
import Dodge.Data.Config import Dodge.Data.Config
@@ -15,7 +16,7 @@ renderInfoListAt :: Float -> Float -> Configuration -> Camera -> (Point2, [Strin
renderInfoListAt x y cfig cam (p, ss) = renderInfoListAt x y cfig cam (p, ss) =
toTopLeft cfig (renderListAt x y (zip ss (repeat white))) toTopLeft cfig (renderListAt x y (zip ss (repeat white)))
<> color white (lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p)) <> color white (lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen cam p))
<> toTopLeft cfig (translate x (-y) $ listCursorNSW 0 0 white 19 (length ss)) <> toTopLeft cfig (translate x (-y) $ listCursorChooseBorderScale 0 1 [North,South] 0 0 white 19 (length ss))
where where
hw = halfWidth cfig hw = halfWidth cfig
hh = halfHeight cfig hh = halfHeight cfig
src/Dodge/Render/List.hs
+51 -68
View File
@@ -1,6 +1,5 @@
module Dodge.Render.List ( module Dodge.Render.List (
renderListAt, renderListAt,
listCursorNSW,
drawList, drawList,
drawSelectionList, drawSelectionList,
listPicturesYgapScaleYoff, listPicturesYgapScaleYoff,
@@ -10,15 +9,15 @@ module Dodge.Render.List (
drawListYoff, drawListYoff,
stackPicturesAt, stackPicturesAt,
toTopLeft, toTopLeft,
listCursorChooseBorderScale , listCursorChooseBorderScale,
) where ) where
import Dodge.ScreenPos
import Data.Maybe import Data.Maybe
import Dodge.Base.Window import Dodge.Base.Window
import Dodge.Data.CardinalPoint import Dodge.Data.CardinalPoint
import Dodge.Data.Config import Dodge.Data.Config
import Dodge.Data.SelectionList import Dodge.Data.SelectionList
import Dodge.ScreenPos
import Dodge.SelectionList import Dodge.SelectionList
import Dodge.SelectionSections import Dodge.SelectionSections
import Geometry import Geometry
@@ -30,39 +29,13 @@ drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Pi
drawSelectionList ldps cfig sl = drawSelectionList ldps cfig sl =
translateScreenPos translateScreenPos
cfig cfig
(ldps ^. ldpPos) $ (ldps ^. ldpPos)
listPicturesYgapScaleYoff $ listPicturesYgapScaleYoff
(_ldpVerticalGap ldps)
(_ldpScale ldps)
0
(makeSelectionListPictures sl)
<> drawSelectionCursor sl ldps
makeSelectionListPictures :: SelectionList a -> [Picture]
makeSelectionListPictures = concatMap f . getShownItems
where
f si = map (color (_siColor si) . text) $ _siPictures si
drawCursorAt :: Maybe Int -> [SelectionItem a] -> ListDisplayParams -> Picture
drawCursorAt mi lis ldps = fromMaybe mempty $ do
i <- mi
selit <- lis !? i
let j = sum . map _siHeight $ take i lis
col = _siColor selit
return $
listCursorChooseBorderScale
(_ldpVerticalGap ldps) (_ldpVerticalGap ldps)
(_ldpScale ldps) (_ldpScale ldps)
(ldps ^. ldpCursorSides) 0
j (makeSelectionListPictures sl)
(_siOffX selit) <> drawSelectionCursor sl ldps
col
wdth
(_siHeight selit)
where
wdth = case _ldpWidth ldps of
FixedSelectionWidth x -> x
_ -> 1
drawSelectionCursor :: SelectionList a -> ListDisplayParams -> Picture drawSelectionCursor :: SelectionList a -> ListDisplayParams -> Picture
drawSelectionCursor sl = drawCursorAt (f $ sl ^. slSelPos) (getShownItems sl) drawSelectionCursor sl = drawCursorAt (f $ sl ^. slSelPos) (getShownItems sl)
@@ -73,43 +46,61 @@ drawSelectionCursor sl = drawCursorAt (f $ sl ^. slSelPos) (getShownItems sl)
"" | not (sl ^. slRegexInput) -> id "" | not (sl ^. slRegexInput) -> id
_ -> fmap (+ 1) _ -> fmap (+ 1)
makeSelectionListPictures :: SelectionList a -> [Picture]
makeSelectionListPictures = concatMap f . getShownItems
where
f si = map (color (_siColor si) . text) $ _siPictures si
drawCursorAt :: Maybe Int -> [SelectionItem a] -> ListDisplayParams -> Picture
drawCursorAt mi lis ldps = fromMaybe mempty $ do
i <- mi
selit <- lis !? i
return $
listCursorChooseBorderScale
(_ldpVerticalGap ldps)
(_ldpScale ldps)
(ldps ^. ldpCursorSides)
(sum . map _siHeight $ take i lis)
(_siOffX selit)
(_siColor selit)
(getLDPWidth ldps)
(_siHeight selit)
getLDPWidth :: ListDisplayParams -> Int
getLDPWidth ldps = case _ldpWidth ldps of
FixedSelectionWidth x -> x
_ -> 1
drawListYoff :: Int -> [Picture] -> Picture drawListYoff :: Int -> [Picture] -> Picture
drawListYoff = listPicturesYgapScaleYoff 0 1 drawListYoff = listPicturesYgapScaleYoff 0 1
listPicturesYgapScaleYoff :: Float -> Float -> Int -> [Picture] -> Picture listPicturesYgapScaleYoff :: Float -> Float -> Int -> [Picture] -> Picture
listPicturesYgapScaleYoff ygap s i = mconcat . zipWith (drawListElement ygap s) [i ..] listPicturesYgapScaleYoff ygap s i = mconcat . zipWith (drawListElement ygap s 0) [i ..]
stackPicturesAt :: [Picture] -> Picture stackPicturesAt :: [Picture] -> Picture
stackPicturesAt = stackPicturesAtOff 0 stackPicturesAt = stackPicturesAtOff 0
stackPicturesAtOff :: Int -> [Picture] -> Picture stackPicturesAtOff :: Int -> [Picture] -> Picture
stackPicturesAtOff i = mconcat . zipWith (drawListElement 10 1) [i, i -1 ..] stackPicturesAtOff i = mconcat . zipWith (drawListElement 10 1 0) [i, i -1 ..]
selSecDrawCursor :: Int -> [CardinalPoint] -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Picture selSecDrawCursor :: Int -> ListDisplayParams -> SelectionSections a -> Picture
selSecDrawCursor xsize borders ldp sss i j = fromMaybe mempty $ do selSecDrawCursor xsize ldp sss = fromMaybe mempty $ do
yint <- selSecSelPos i j sss (i, j) <- sss ^? sssExtra . sssSelPos . _Just
yint <- selSecYint i j sss
xint <- sss ^? sssSections . ix i . ssIndent xint <- sss ^? sssSections . ix i . ssIndent
si <- sss ^? sssSections . ix i . ssItems . ix j si <- sss ^? sssSections . ix i . ssItems . ix j
return $ listCursorDisplayParams ldp borders yint xint (_siColor si) xsize (length $ _siPictures si) return $
listCursorChooseBorderScale
listCursorDisplayParams :: (ldp ^. ldpVerticalGap)
ListDisplayParams -> (ldp ^. ldpScale)
[CardinalPoint] -> (ldp ^. ldpCursorSides)
Int -> yint
Int -> xint
Color -> (_siColor si)
Int -> xsize
Int -> (length $ _siPictures si)
Picture
listCursorDisplayParams ldp borders a b c d =
listCursorChooseBorderScale ygap s borders a b c d
where
ygap = _ldpVerticalGap ldp
s = _ldpScale ldp
-- displays a cursor that should match up to list text pictures -- displays a cursor that should match up to list text pictures
-- the width of a character appears to be 9(?!)
-- this is probably because it is 8 pixels plus one for the border
listCursorChooseBorderScale :: listCursorChooseBorderScale ::
Float -> Float ->
Float -> Float ->
@@ -130,11 +121,6 @@ listCursorChooseBorderScale ygap s borders yint xint col cursxsize cursysize =
wth = 10 * (fromIntegral cursxsize + 1) wth = 10 * (fromIntegral cursxsize + 1)
hgt = 20 * fromIntegral cursysize + ygap * (fromIntegral cursysize - 1) hgt = 20 * fromIntegral cursysize + ygap * (fromIntegral cursysize - 1)
-- displays a cursor that should match up to list text pictures
listCursorChooseBorder ::
[CardinalPoint] -> Int -> Int -> Color -> Int -> Int -> Picture
listCursorChooseBorder = listCursorChooseBorderScale 10 1
-- note we cannot simply scale lines because they are drawn as solid rectangles -- note we cannot simply scale lines because they are drawn as solid rectangles
chooseCursorBorders :: Float -> Float -> [CardinalPoint] -> Picture chooseCursorBorders :: Float -> Float -> [CardinalPoint] -> Picture
chooseCursorBorders w h = foldMap (line . toLine) chooseCursorBorders w h = foldMap (line . toLine)
@@ -145,9 +131,6 @@ chooseCursorBorders w h = foldMap (line . toLine)
toLine South = [V2 w h', V2 0 h'] toLine South = [V2 w h', V2 0 h']
toLine West = [V2 0 h', V2 0 0] toLine West = [V2 0 h', V2 0 0]
listCursorNSW :: Int -> Int -> Color -> Int -> Int -> Picture
listCursorNSW a b c d = listCursorChooseBorder [North, South, West] a b c d
--fillScreenText :: Configuration -> String -> Picture --fillScreenText :: Configuration -> String -> Picture
--fillScreenText cfig str = --fillScreenText cfig str =
-- scale wscale hscale -- scale wscale hscale
@@ -168,9 +151,9 @@ listCursorNSW a b c d = listCursorChooseBorder [North, South, West] a b c d
-- thescale = hw * 0.02 / fromIntegral (length str) -- thescale = hw * 0.02 / fromIntegral (length str)
-- hw = halfWidth cfig -- hw = halfWidth cfig
drawListElement :: Float -> Float -> Int -> Picture -> Picture drawListElement :: Float -> Float -> Int -> Int -> Picture -> Picture
drawListElement ygap s yint = drawListElement ygap s xint yint =
translate 0 (negate ((s * 20 + ygap) * (fromIntegral yint + 1))) translate (s * 10 * fromIntegral xint) (negate ((s * 20 + ygap) * (fromIntegral yint + 1)))
. scale (s * 0.1) (s * 0.1) . scale (s * 0.1) (s * 0.1)
renderListAt :: Float -> Float -> [(String, Color)] -> Picture renderListAt :: Float -> Float -> [(String, Color)] -> Picture
src/Dodge/ScreenPos.hs
+5 -6
View File
@@ -10,11 +10,10 @@ fromTopLeft :: Point2 -> ScreenPos
fromTopLeft (V2 x y) = ScreenPos (V2 (-0.5) 0.5) (V2 x (- y)) fromTopLeft (V2 x y) = ScreenPos (V2 (-0.5) 0.5) (V2 x (- y))
translateScreenPos :: Configuration -> ScreenPos -> Picture -> Picture translateScreenPos :: Configuration -> ScreenPos -> Picture -> Picture
translateScreenPos cfig sp = translate x y translateScreenPos cfig = uncurryV translate . screenPosAbs cfig
where
V2 x y = sp ^. spScreenOff * V2 w h + sp ^. spPixelOff
w = fromIntegral $ cfig ^. windowX
h = fromIntegral $ cfig ^. windowY
screenPosAbs :: Configuration -> ScreenPos -> Point2 screenPosAbs :: Configuration -> ScreenPos -> Point2
screenPosAbs = undefined screenPosAbs cfig sp = sp ^. spScreenOff * V2 w h + sp ^. spPixelOff
where
w = fromIntegral $ cfig ^. windowX
h = fromIntegral $ cfig ^. windowY
src/Dodge/SelectionList.hs
+4 -1
View File
@@ -1,4 +1,7 @@
module Dodge.SelectionList where module Dodge.SelectionList (
getShownItems,
getAvailableListLines,
) where
import Color import Color
import Data.Maybe import Data.Maybe
src/Dodge/SelectionSections.hs
+3 -3
View File
@@ -4,7 +4,7 @@ module Dodge.SelectionSections (
ssLookupGT, ssLookupGT,
ssSetCursor, ssSetCursor,
setFirstPosSelectionSections, setFirstPosSelectionSections,
selSecSelPos, selSecYint,
selSecSelSize, selSecSelSize,
) where ) where
@@ -124,8 +124,8 @@ ssLookupGE' i sss = do
selSecSelSize :: Int -> Int -> SelectionSections a -> Maybe Int selSecSelSize :: Int -> Int -> SelectionSections a -> Maybe Int
selSecSelSize i j sss = fmap length $ sss ^? sssSections . ix i . ssItems . ix j . siPictures selSecSelSize i j sss = fmap length $ sss ^? sssSections . ix i . ssItems . ix j . siPictures
selSecSelPos :: Int -> Int -> SelectionSections a -> Maybe Int selSecYint :: Int -> Int -> SelectionSections a -> Maybe Int
selSecSelPos i j sss = do selSecYint i j sss = do
ss <- sss ^? sssSections . ix i ss <- sss ^? sssSections . ix i
return . (secpos +) return . (secpos +)
. subtract (ss ^. ssOffset) . subtract (ss ^. ssOffset)
src/Dodge/SelectionSections/Draw.hs
+6 -11
View File
@@ -1,25 +1,20 @@
module Dodge.SelectionSections.Draw where module Dodge.SelectionSections.Draw where
import Dodge.ScreenPos
import Control.Lens import Control.Lens
import Data.Maybe
import Dodge.Data.CardinalPoint
import Dodge.Data.Config import Dodge.Data.Config
import Dodge.Data.SelectionList import Dodge.Data.SelectionList
import Dodge.Render.List import Dodge.Render.List
import Dodge.ScreenPos
import Picture.Base import Picture.Base
drawSelectionSections :: SelectionSections a -> ListDisplayParams -> Configuration -> Picture drawSelectionSections :: SelectionSections a -> ListDisplayParams -> Configuration -> Picture
drawSelectionSections sss ldps cfig = drawSelectionSections sss ldp cfig =
translateScreenPos cfig (ldps ^. ldpPos) $ translateScreenPos cfig (ldp ^. ldpPos) $
listPicturesYgapScaleYoff listPicturesYgapScaleYoff
(_ldpVerticalGap ldps) (_ldpVerticalGap ldp)
(_ldpScale ldps) (_ldpScale ldp)
0 0
pics pics
<> thecursor' <> selSecDrawCursor 15 ldp sss
where where
thecursor' = fromMaybe mempty $ do
(i, j) <- sss ^? sssExtra . sssSelPos . _Just
return $ selSecDrawCursor 15 [North, South, West] ldps sss i j
pics = foldMap _ssShownItems (_sssSections sss) pics = foldMap _ssShownItems (_sssSections sss)