From 7c472c4ca4d31790fcb175605ebe1a5c7db9a0d7 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 24 May 2022 15:25:05 +0100 Subject: [PATCH] Improve combine menu visuals --- src/Dodge/Creature/Impulse/UseItem.hs | 47 +++-------------------- src/Dodge/Event.hs | 2 +- src/Dodge/Inventory.hs | 2 +- src/Dodge/Render/HUD.hs | 54 ++++++++++++++------------- 4 files changed, 37 insertions(+), 68 deletions(-) diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index 7161ee62d..cb6b2e668 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -22,14 +22,12 @@ itemEffect :: Creature -> Item -> World -> World itemEffect cr it w = case it ^? itUse of Just RightUse {_rUse = eff,_useMods = usemods} -> hammerTest $ foldr ($) eff usemods it cr - Just LeftUse {} -> setuhamdown $ lhammer $ (toggleEquipmentAt (_rbOptions w) (_crInvSel cr) - . activateEquipmentAt (_rbOptions w)) - Just EquipUse{} -> setuhamdown $ lhammer $ (toggleEquipmentAt (_rbOptions w) (_crInvSel cr) - . activateEquipmentAt (_rbOptions w)) + Just LeftUse {} -> doequipmentchange + Just EquipUse{} -> doequipmentchange -- ConsumeUse will cause problems if the item is not selected Just (ConsumeUse eff) -> setuhamdown $ hammerTest $ eff it cr . rmInvItem (_crID cr) (_crInvSel cr) - Just NoUse -> setuhamdown w - Nothing -> setuhamdown w + Just NoUse -> setuhamdown w + Nothing -> setuhamdown w where hammerTest f = case _crHammerPosition cr of HammerUp -> f w @@ -38,6 +36,8 @@ itemEffect cr it w = case it ^? itUse of HammerUp -> creatures . ix (_crID cr) %~ f' _ -> id setuhamdown = creatures . ix (_crID cr) . crHammerPosition .~ HammerDown + doequipmentchange = setuhamdown $ lhammer (toggleEquipmentAt (_rbOptions w) (_crInvSel cr) + . activateEquipmentAt (_rbOptions w)) activateEquipmentAt :: RightButtonOptions -> Creature -> Creature activateEquipmentAt rbo = case (rbo ^? opActivateEquipment . activateEquipment, rbo ^? opActivateEquipment . deactivateEquipment) of @@ -68,41 +68,6 @@ toggleEquipmentAt rbops invid cr = case rbops ^? opAllocateEquipment of -> cr & crEquipment . at oldp .~ Nothing & crInvEquipped . at invid .~ Nothing Nothing -> error "tried to toggle equipment whilst not prepared" --- case cr ^? crInvEquipped . ix invid of --- Just epos -> cr & crInvEquipped . at invid .~ Nothing --- & crEquipment . at epos .~ Nothing --- Nothing -> equipUsingSite invid itm cr - --- | First check if the item is already equiped, then do nothing -equipUsingSiteCheck :: Int -> Item -> Creature -> Creature -equipUsingSiteCheck invid itm cr - | isJust (cr ^? crInvEquipped . ix invid) = cr - | otherwise = equipUsingSite invid itm cr - -equipUsingSite :: Int -> Item -> Creature -> Creature -equipUsingSite invid itm cr = cr - & crInvEquipped . at invid ?~ epos - & crEquipment . at epos ?~ invid - & removeOtherEquipment - where - epos = eqSiteToPos cr (_eqSite $ _itUse itm) - removeOtherEquipment = case cr ^? crEquipment . ix epos of - Nothing -> id - Just oid -> (crInvEquipped . at oid .~ Nothing) . removeIfLUse oid - removeIfLUse oid - | _crLeftInvSel cr == Just oid = crLeftInvSel .~ Nothing - | otherwise = id - -eqSiteToPos :: Creature -> EquipSite -> EquipPosition -eqSiteToPos cr es = case es of - GoesOnHead -> OnHead - GoesOnChest -> OnChest - GoesOnBack -> OnBack - GoesOnLegs -> OnLegs - GoesOnSpecial -> OnSpecial - GoesOnWrist -> case cr ^? crEquipment . ix OnLeftWrist of - Nothing -> OnLeftWrist - _ -> OnRightWrist useLeftItem :: Int -> World -> World useLeftItem cid w diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 898269d30..0702e0d8a 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -152,7 +152,7 @@ wheelEvent y w = case _hudElement $ _hud w of scrollRBOption :: Float -> World -> World scrollRBOption y w | y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w))-1) . (+1)) - | y > 0 = w & rbOptions . opSel %~ (max 0 . (subtract 1)) + | y > 0 = w & rbOptions . opSel %~ (max 0 . subtract 1) | otherwise = w -- nice idea, but the chain of setters and getters seems prohibitive diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index dbd39a99b..70da789a1 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -108,7 +108,7 @@ selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w | otherwise = 1 selNumTextPos :: Configuration -> World -> Int -> Point2 -selNumTextPos cfig w i = V2 (150 - hw) ( hh + 20 * fromIntegral ipos + 7.5) +selNumTextPos cfig w i = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 20)) where hh = halfHeight cfig hw = halfWidth cfig diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 04fef05f9..535583ba0 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -101,6 +101,7 @@ subInventoryDisplay subinv cfig w = case subinv of cpos <- combinePoss w !? i csize <- combineSizes w !? i col <- (combineItemListYou w !? i) <&> _itInvColor . snd + --return $ listCursorNSW subInvX 60 cfig cpos col 15 csize return $ listCursorNSW subInvX 60 cfig cpos col 15 csize , fromMaybe mempty $ do i <- mi @@ -108,7 +109,7 @@ subInventoryDisplay subinv cfig w = case subinv of col <- (combineItemListYou w !? i) <&> _itInvColor . snd lnks <- map fst (combineItemListYou w) !? i return $ lnkMidPosInvSelsCol cfig w cpos col lnks - <> foldMap (cursorAtInvSel listCursorNESW cfig w) lnks + <> foldMap (topCursorTypeWidth listCursorNESW (topInvW +2) cfig w) lnks <> combineCounts cfig w lnks ] InspectInventory -> invHead cfig "INSPECT" @@ -119,7 +120,7 @@ subInventoryDisplay subinv cfig w = case subinv of itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor) cr = you w it = yourItem w - selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol topInvW cury <$ it + selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol (determineInvSelCursorWidth w) cury <$ it selcursor = selcursor' selcursortype selcursortype | ButtonRight `S.member` _mouseButtons w = listCursorNESW @@ -127,43 +128,40 @@ subInventoryDisplay subinv cfig w = case subinv of curpos = invSelPos w cury = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w) equipcursor = case _crLeftInvSel cr of - Just invid | _crInvSel cr /= invid || not (ButtonRight `S.member` _mouseButtons w) - -> f cyan invid (_crInvEquipped cr IM.! invid) + Just invid -> f cyan invid (_crInvEquipped cr IM.! invid) _ -> mempty equipcursors = IM.foldMapWithKey (f yellow) (_crInvEquipped cr) - f col invid epos - | _crInvSel cr /= invid || not (ButtonRight `S.member` _mouseButtons w) - = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos - | otherwise = mempty + f col invid epos = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos +-- | _crInvSel cr /= invid || not (ButtonRight `S.member` _mouseButtons w) +-- = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos +-- | otherwise = mempty --rboptions = listTextPicturesAtOffset 200 0 cfig (selNumPos invid w) ["TEST","ME"] rboptions = drawRBOptions cfig w (_rbOptions w) drawRBOptions :: Configuration -> World -> RightButtonOptions -> Picture drawRBOptions cfig w EquipOptions{_opEquip = es,_opSel=i, _opAllocateEquipment=ae} = - listTextPicturesAtOffset 252 0 cfig (curpos-i) (map (text . eqPosText) es) + listTextPicturesAtOffset 342 0 cfig (curpos-i) (map (text . eqPosText) es) <> case ae of DoNotMoveEquipment -> mempty PutOnEquipment {} - -> putontext - MoveEquipment {_allocOldPos = oldp } - -> putontext <> extratext ("MOVES FROM "++eqPosText oldp) + -> midtext "PUT ONTO" + MoveEquipment {} + -> midtext "MOVE TO" <> extratext [] SwapEquipment { _allocOldPos = oldp, _allocSwapID = sid } - -> putontext <> extratext ("SWAPS "++otheritem sid ++ " ONTO " ++eqPosText oldp) + -> midtext "MOVE TO" <> extratext ("SWAPS "++otheritem sid ++ " ONTO " ++eqPosText oldp) ReplaceEquipment { _allocRemoveID = rid } - -> putontext <> extratext ("REMOVES " ++ otheritem rid) + -> midtext "PUT ONTO" <> extratext ("REMOVES " ++ otheritem rid) RemoveEquipment { } - -> takeofftext + -> midtext "TAKE OFF" where - takeofftext = listTextPictureAt 144 0 cfig curpos (text " TAKE OFF") - putontext = listTextPictureAt 144 0 cfig curpos (text " PUT ONTO") - extratext str = listTextPictureAt 350 0 cfig curpos (text (str ++ deactivatetext)) + midtext str = listTextPictureAt 252 0 cfig curpos (text str) + extratext str = listTextPictureAt 432 0 cfig curpos (text (str ++ deactivatetext)) deactivatetext = case w ^? rbOptions . opActivateEquipment . deactivateEquipment of Just k -> " DEACTIVATES " ++ _itName (_crInv (you w) IM.! k) Nothing -> "" curpos = invSelPos w otheritem j = _itName (_crInv (you w) IM.! j) drawRBOptions _ _ _ = mempty - eqPosText :: EquipPosition -> String eqPosText ep = case ep of @@ -206,23 +204,29 @@ combineCounts :: Configuration -> World -> [Int] -> Picture combineCounts cfig w = winScale cfig . foldMap f . group where f (i:is) = case yourInv w ^? ix i . itConsumption of - Just _ -> color (selNumCol i w) $ uncurryV translate (V2 10 5 +.+ selNumMidHeight cfig w i) . scale 0.1 0.1 . text . show $ length is + 1 - Nothing -> mempty + Just ItemItselfConsumable{} -> 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 - . concatMap (\j -> zConnectCol rp (selNumMidHeight cfig w j) col white white (selNumCol j w)) + . concatMap (\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)) hh = halfHeight cfig hw = halfWidth cfig -cursorAtInvSel :: (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture) +topCursorTypeWidth :: (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture) + -> Int -> Configuration -> World -> Int -> Picture -cursorAtInvSel ctype cfig w i - = ctype 0 0 cfig (selNumPos i w) (selNumCol i w) topInvW (selNumSlots i w) +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 {} -> 47 --listSelHeight :: Configuration -> World -> Int -> Float --listSelHeight