diff --git a/src/Dodge/Data/HUD.hs b/src/Dodge/Data/HUD.hs index dee7f504b..853973e3b 100644 --- a/src/Dodge/Data/HUD.hs +++ b/src/Dodge/Data/HUD.hs @@ -5,13 +5,15 @@ module Dodge.Data.HUD where +--import Dodge.Data.SelectionList import Control.Lens import Data.Aeson import Data.Aeson.TH import Geometry.Data data HUDElement - = DisplayInventory {_subInventory :: SubInventory} + = DisplayInventory + { _subInventory :: SubInventory} | DisplayCarte deriving (Eq, Ord, Show, Read) --Generic, Flat) diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs index 1922946b0..bf05771ea 100644 --- a/src/Dodge/Data/SelectionList.hs +++ b/src/Dodge/Data/SelectionList.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Data.SelectionList where @@ -6,6 +8,8 @@ import Picture.Data import Control.Lens import Data.Set (Set) import Dodge.Data.CardinalPoint +import Data.Aeson +import Data.Aeson.TH data ListDisplayParams = ListDisplayParams { _ldpPosX :: Float @@ -43,3 +47,4 @@ data SelectionItem a = SelectionItem makeLenses ''ListDisplayParams makeLenses ''SelectionList makeLenses ''SelectionItem +deriveJSON defaultOptions ''SelectionItem diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index 394b3176e..64604ff98 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -8,7 +8,6 @@ module Dodge.Inventory ( selNumPos, selNumTextPos, selNumCol, - selNumSlots, selNumMidHeight, augmentedInvSizes, rmInvItem, @@ -23,6 +22,7 @@ module Dodge.Inventory ( crNumFreeSlots, crInvSize, selectedCloseObject, + invDimColor, ) where import Color @@ -96,13 +96,16 @@ rmSelectedInvItem :: Int -> World -> World rmSelectedInvItem cid w = rmInvItem cid (crSel (w ^?! cWorld . lWorld . creatures . ix cid)) w augmentedInvSizes :: World -> IM.IntMap Int -augmentedInvSizes = bimapAugmentInv itSlotsTaken closeObjectSize +augmentedInvSizes = trimapAugmentInv itSlotsTaken 1 closeObjectSize -bimapAugmentInv :: (Item -> a) -> (Either FloorItem Button -> a) -> World -> IM.IntMap a -bimapAugmentInv f g w = +trimapAugmentInv :: (Item -> a) -> a -> (Either FloorItem Button -> a) -> World -> IM.IntMap a +trimapAugmentInv f x g w = + IM.insert n x $ IM.union (f <$> yourInv w) - (IM.fromAscList $ zip [length (yourInv w) ..] $ map g $ w ^. cWorld . lWorld . closeObjects) + (IM.fromAscList $ zip [n + 1 ..] $ map g $ w ^. cWorld . lWorld . closeObjects) + where + n = length $ yourInv w invSelSize :: Int -> World -> Int invSelSize i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i @@ -117,15 +120,12 @@ closeObjectCol e = case e of Left flit -> _itInvColor $ _flIt flit Right _ -> yellow -selNumSlots :: Int -> World -> Int -selNumSlots i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i - selNumPos :: Int -> World -> Int selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w)) where - splitgap - | i < length (yourInv w) = 0 - | otherwise = 1 + splitgap = 0 +-- | i < length (yourInv w) = 0 +-- | otherwise = 1 selNumTextPos :: Configuration -> World -> Int -> Point2 selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20)) @@ -140,18 +140,22 @@ selNumMidHeight cfig w i = V2 (150 - hw) (hh + bump - (20 * fromIntegral ipos + hh = halfHeight cfig hw = halfWidth cfig ipos = selNumPos i w - bump = negate $ 10 * fromIntegral (selNumSlots i w) + bump = negate $ 10 * fromIntegral (invSelSize i w) selNumCol :: Int -> World -> Color -selNumCol i w = fromMaybe white $ bimapAugmentInv _itInvColor closeObjectCol w IM.!? i +selNumCol i w = fromMaybe white $ trimapAugmentInv _itInvColor invDimColor closeObjectCol w IM.!? i + +invDimColor :: Color +invDimColor = greyN 0.7 invSelPos :: World -> Int invSelPos w = splitgap + (foldl' (+) 0 . fst $ IM.split invsel (augmentedInvSizes w)) where invsel = yourInvSel w - splitgap - | invsel < length (yourInv w) = 0 - | otherwise = 1 + splitgap = 0 +-- splitgap +-- | invsel < length (yourInv w) = 0 +-- | otherwise = 1 updateTerminal :: World -> World updateTerminal = checkTermDist @@ -172,7 +176,8 @@ updateCloseObjects w = & cWorld . lWorld . creatures . ix 0 . crInvSel . iselPos %~ updateinvsel where updateinvsel curinvsel - | length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w) - 1 + -- | length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w) - 1 + | length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w) | otherwise = curinvsel filt = filter $ \obj -> dist ypos (closeObjPos obj) < 40 && hasButtonLOS ypos (closeObjPos obj) w ypos = _crPos $ you w @@ -371,7 +376,7 @@ changeAugInvSel i w & cWorld . lWorld . creatures . ix 0 . crInvSel . iselPos %~ (`mod` n) . subtract i & cWorld . lWorld . creatures . ix 0 . crInvSel . iselAction .~ NoInvSelAction where - n = length (yourInv w) + length (w ^. cWorld . lWorld . closeObjects) + n = length (yourInv w) + length (w ^. cWorld . lWorld . closeObjects) + 1 bestCloseObjectIndex :: World -> Maybe Int bestCloseObjectIndex w = findIndex f $ w ^. cWorld . lWorld . closeObjects @@ -382,7 +387,7 @@ bestCloseObjectIndex w = findIndex f $ w ^. cWorld . lWorld . closeObjects selectedCloseObject :: World -> Maybe (Int, Either FloorItem Button) selectedCloseObject w - | invsel >= length inv = selectNthCloseObject w (invsel - length inv) + | invsel >= (length inv + 1) = selectNthCloseObject w (invsel - (length inv + 1)) | otherwise = selectNthCloseObject w =<< bestCloseObjectIndex w where invsel = crSel cr diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index bf5c1eb70..1706ca2f7 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -85,7 +85,7 @@ subInvSelectionList = SelectionList inventorySelectionList :: World -> [SelectionItem ()] inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv) - ++ [SelectionItem displayFreeSlots 1 False (length thetext) white 0 ()] + ++ [SelectionItem displayFreeSlots 1 True (length thetext) invDimColor 2 ()] ++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects) where cr = you w @@ -312,7 +312,7 @@ topCursorTypeWidth :: Int -> Picture topCursorTypeWidth ctype width cfig w i = - ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (selNumSlots i w) + ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (invSelSize i w) determineInvSelCursorWidth :: World -> Int determineInvSelCursorWidth w = case _rbOptions w of @@ -355,8 +355,6 @@ invHead cfig s = . scale 0.4 0.4 $ text s -invDimColor :: Color -invDimColor = greyN 0.7 closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem () closeObjectToSelectionItem n e = SelectionItem diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index d090b19c2..e3162f501 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -6,22 +6,19 @@ Description : Simulation update -} module Dodge.Update (updateUniverse) where ---import Dodge.Menu.Option -import Dodge.Menu.Option -import Dodge.SelectionList -import Dodge.Data.SelectionList -import Dodge.InputFocus import Color import Control.Applicative import Data.List import qualified Data.Map.Strict as M import Data.Maybe +import qualified Data.Text as T import Dodge.Base import Dodge.Beam import Dodge.Bullet import Dodge.CrGroupUpdate import Dodge.Creature.Update import Dodge.CullBox +import Dodge.Data.SelectionList import Dodge.Data.Universe import Dodge.Distortion import Dodge.DrWdWd @@ -29,6 +26,7 @@ import Dodge.EnergyBall import Dodge.Flame import Dodge.Flare import Dodge.Hammer +import Dodge.InputFocus import Dodge.Inventory import Dodge.Item.Location import Dodge.Laser.Update @@ -37,6 +35,7 @@ import Dodge.LinearShockwave.Update import Dodge.Machine.Update import Dodge.Magnet.Update import Dodge.Menu +import Dodge.Menu.Option import Dodge.ModificationEffect import Dodge.PosEvent import Dodge.PressPlate @@ -44,6 +43,7 @@ import Dodge.Projectile.Update import Dodge.Prop.Update import Dodge.RadarBlip import Dodge.RadarSweep +import Dodge.SelectionList import Dodge.Shockwave.Update import Dodge.SoundLogic import Dodge.Spark @@ -62,12 +62,9 @@ import Dodge.Zoning.Creature import Geometry import qualified IntMapHelp as IM import LensHelp ---import MaybeHelp import SDL import Sound.Data import StrictHelp -import qualified Data.Text as T ---import ListHelp updateUniverse :: Universe -> Universe updateUniverse u = @@ -95,23 +92,27 @@ gotoTerminal w = case _uvScreenLayers w of mouseClickOptionsList :: ScreenLayer -> Universe -> Universe mouseClickOptionsList screen u = fromMaybe u $ do - sl <- screen ^? scSelectionList - Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of - Just False -> fromMaybe u $ do - i <- sl ^. slSelPos - f <- sl ^? slItems . ix i . siPayload - return $ f u - _ -> u + sl <- screen ^? scSelectionList + Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of + Just False -> fromMaybe u $ do + i <- sl ^. slSelPos + f <- sl ^? slItems . ix i . siPayload + return $ f u + _ -> u mouseOverSelectionList :: ListDisplayParams -> SelectionList (Universe -> Universe) -> Universe -> Universe mouseOverSelectionList ldps sl u | x > xl && x < xr && ylower == yupper && mmoving - && ylower >= 0 && ylower < ymax && isselectable = u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper + && ylower >= 0 + && ylower < ymax + && isselectable = + u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper | otherwise = u where - isselectable = fromMaybe False - $ u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . siIsSelectable - ymax = maybe 0 length $ sl ^? slItems + isselectable = + fromMaybe False $ + u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . siIsSelectable + ymax = maybe 0 length $ sl ^? slItems mmoving = u ^. uvWorld . input . mouseMoving ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50 yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50 @@ -130,27 +131,30 @@ setSelectionListRestriction' cfig screen = fromMaybe screen $ do updateUseInput :: Universe -> Universe updateUseInput u = case u ^? uvScreenLayers . _head of Just (InputScreen thetext _) -> doInputScreenInput thetext u - Just screen@OptionScreen{_scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps} - -> optionScreenUpdate screen mop flag ldps sellist u --- Just ColumnsScreen{} -> u & uvScreenLayers %~ tail + Just screen@OptionScreen{_scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps} -> + optionScreenUpdate screen mop flag ldps sellist u _ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u _ -> M.foldlWithKey' updateKeyInGame u pkeys where pkeys = u ^. uvWorld . input . pressedKeys -optionScreenUpdate :: ScreenLayer -> PositionedMenuOption -> OptionScreenFlag - -> ListDisplayParams - -> SelectionList (Universe -> Universe) - -> Universe -> Universe -optionScreenUpdate screen mop _ ldps sl u = +optionScreenUpdate :: + ScreenLayer -> + PositionedMenuOption -> + OptionScreenFlag -> + ListDisplayParams -> + SelectionList (Universe -> Universe) -> + Universe -> + Universe +optionScreenUpdate screen mop _ ldps sl u = refreshOptionsSelectionList - . optionScreenDefEff mop - . mouseClickOptionsList screen - . mouseOverSelectionList ldps sl - . menuWheelEvents - . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig) - $ u + . optionScreenDefEff mop + . mouseClickOptionsList screen + . mouseOverSelectionList ldps sl + . menuWheelEvents + . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig) + $ u where cfig = u ^. uvConfig @@ -291,12 +295,7 @@ functionalUpdate w = . over uvWorld updateWheelEvents $ over uvWorld updatePastWorlds w ---menuWheelEvents :: Universe -> Universe ---menuWheelEvents u = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax) --- where --- ymax = max 1 $ maybe 1 length (u ^? uvScreenLayers . _head . scSelectionList . slItems) --- y = u ^. uvWorld . input . scrollAmount - +-- this can probably be unified with updateWheelEvents menuWheelEvents :: Universe -> Universe menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y))) where @@ -306,13 +305,13 @@ menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y))) menuWheelStep :: Int -> Universe -> Universe menuWheelStep i u = fromMaybe u $ do sl <- u ^? uvScreenLayers . _head . scSelectionList - selpos <- sl ^? slSelPos . _Just + selpos <- sl ^? slSelPos . _Just ymax <- fmap length (sl ^? slItems) let newpos = (selpos - i) `mod` ymax itm <- sl ^? slItems . ix newpos let newu = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ const newpos if _siIsSelectable itm - then Just newu + then Just newu else Just $ menuWheelStep i newu updateWheelEvents :: World -> World