From 0187ae6001fe34f7d620e233beddd91ec7794e9b Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 26 May 2021 17:25:46 +0200 Subject: [PATCH] Refactor inventory management, add tweak, combine and inspect modes --- src/Dodge/Data.hs | 15 ++- src/Dodge/Default.hs | 163 +++++++++++------------------- src/Dodge/Default/Wall.hs | 50 +++++++++ src/Dodge/Default/Weapon.hs | 9 ++ src/Dodge/Event.hs | 100 +++++++----------- src/Dodge/Event/Keyboard.hs | 12 ++- src/Dodge/Inventory.hs | 16 ++- src/Dodge/Item/Weapon/Launcher.hs | 24 +++-- src/Dodge/Layout.hs | 2 +- src/Dodge/Render/HUD.hs | 150 ++++++++++++++++++++------- src/Dodge/Render/Picture.hs | 11 +- src/Dodge/Room.hs | 2 +- src/Dodge/Room/Placement.hs | 2 +- 13 files changed, 323 insertions(+), 233 deletions(-) create mode 100644 src/Dodge/Default/Wall.hs diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 34e9f794c..a41f244bb 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -96,7 +96,14 @@ data World = World , _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] , _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] , _debugFlags :: DebugFlags + , _inventoryMode :: InventoryMode } +data InventoryMode + = TopInventory + | TweakInventory + | CombineInventory + | InspectInventory + deriving (Eq, Ord, Show) data CrGroupParams = CrGroupParams { _crGroupParamID :: Int , _crGroupIDs :: IS.IntSet @@ -390,13 +397,19 @@ data Ammo = ShellAmmo { _amPayload :: Point2 -> World -> World , _amString :: String - , _amPjMove :: Item -> Creature -> [Projectile -> World -> World] + , _amPjMove :: [PjParam] , _amPjDraw :: Projectile -> Picture + , _amParamSel :: Int } | BulletAmmo { _amString :: String } | GenericAmmo +data PjParam = PjParam + { _pjMoveParam :: Int -> Item -> Creature -> Projectile -> World -> World + , _pjIntParam :: Int + , _pjDisplayParam :: Int -> String + } data Projectile = Projectile { _pjPos :: Point2 diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index ffeb8cb76..fd7d64db2 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -19,7 +19,6 @@ import Dodge.Config.Data import Dodge.Config.KeyConfig import Geometry import Picture -import qualified DoubleStack as DS import Control.Lens import System.Random @@ -28,50 +27,65 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Graph.Inductive.Graph hiding ((&)) import Data.List -{- Indestructible wall. -} -defaultWall :: Wall -defaultWall = Wall - { _wlLine = ((0,0),(50,0)) - , _wlID = 0 - , _wlColor = greyN 0.6 - , _wlSeen = False - , _wlIsSeeThrough = False - } -{- Indestructible see-through wall. -} -defaultCrystalWall :: Wall -defaultCrystalWall = Wall - { _wlLine = ((0,0),(50,0)) - , _wlID = 0 - , _wlColor = withAlpha 0.5 aquamarine - , _wlSeen = False - , _wlIsSeeThrough = True - } -{- Door that opens on approach. -Pathable. -} -defaultAutoDoor :: Wall -defaultAutoDoor = Door - { _wlLine = ((0,0),(50,0)) - , _wlID = 0 - , _doorMech = id - , _wlColor = light $ dim $ dim $ dim yellow - , _wlSeen = False - , _wlIsSeeThrough = False - , _doorPathable = True - , _drPositions = DS.singleton ((0,0),(50,0)) - } -{- -Non-pathable door. - -} -defaultDoor :: Wall -defaultDoor = Door - { _wlLine = ((0,0),(50,0)) - , _wlID = 0 - , _doorMech = id - , _wlColor = light $ dim $ dim $ dim yellow - , _wlSeen = False - , _wlIsSeeThrough = False - , _doorPathable = False - , _drPositions = DS.singleton ((0,0),(50,0)) +defaultWorld :: World +defaultWorld = World + { _keys = S.empty + , _mouseButtons = S.empty + , _cameraCenter = (0,0) + , _cameraRot = 0 + , _cameraZoom = 1 + , _cameraViewFrom = (0,0) + , _creatures = IM.empty + , _creaturesZone = IM.empty + , _creatureGroups = IM.empty + , _clouds = IM.empty + , _cloudsZone = IM.empty + , _itemPositions = IM.empty + , _projectiles = IM.empty + , _particles = [] + , _staticWalls = [] + , _walls = IM.empty + , _wallsZone = IM.empty + , _forceFields = IM.empty + , _floorItems = IM.empty + , _randGen = mkStdGen 2 + , _mousePos = (0,0) + , _testString = [] + , _yourID = 0 + , _worldEvents = id + , _pressPlates = IM.empty + , _buttons = IM.empty + , _soundQueue = [] + , _sounds = M.empty + , _corpses = IM.empty + , _decorations = IM.empty + , _storedLevel = Nothing + , _menuLayers = [LevelMenu 1] + , _worldState = M.empty + , _worldTriggers = S.empty + , _clickMousePos = (0,0) + , _pathGraph = Data.Graph.Inductive.Graph.empty + , _pathGraph' = [] + , _pathPoints = IM.empty + , _pathInc = M.empty + , _carteDisplay = False + , _carteCenter = (0,0) + , _carteZoom = 0.5 + , _carteRot = 0 + , _lightSources = IM.empty + , _tempLightSources = [youLight] + , _closeActiveObjects = [] + , _seenLocations = IM.fromList + [(0, (_crPos . you, "CURRENT POSITION")) + ,(1, (const (0,0) , "START POSITION")) + ] + , _selLocation = 0 + , _keyConfig = defaultKeyConfigSDL + , _config = defaultConfig + , _sideEffects = [] + , _doneSideEffects = [] + , _debugFlags = defaultDebugFlags + , _inventoryMode = TopInventory } defaultCreature :: Creature defaultCreature = Creature @@ -220,65 +234,6 @@ defaultPP = PressPlate , _ppID = -1 , _ppText = "Pressure plate" } -defaultWorld :: World -defaultWorld = World - { _keys = S.empty - , _mouseButtons = S.empty - , _cameraCenter = (0,0) - , _cameraRot = 0 - , _cameraZoom = 1 - , _cameraViewFrom = (0,0) - , _creatures = IM.empty - , _creaturesZone = IM.empty - , _creatureGroups = IM.empty - , _clouds = IM.empty - , _cloudsZone = IM.empty - , _itemPositions = IM.empty - , _projectiles = IM.empty - , _particles = [] - , _staticWalls = [] - , _walls = IM.empty - , _wallsZone = IM.empty - , _forceFields = IM.empty - , _floorItems = IM.empty - , _randGen = mkStdGen 2 - , _mousePos = (0,0) - , _testString = [] - , _yourID = 0 - , _worldEvents = id - , _pressPlates = IM.empty - , _buttons = IM.empty - , _soundQueue = [] - , _sounds = M.empty - , _corpses = IM.empty - , _decorations = IM.empty - , _storedLevel = Nothing - , _menuLayers = [LevelMenu 1] - , _worldState = M.empty - , _worldTriggers = S.empty - , _clickMousePos = (0,0) - , _pathGraph = Data.Graph.Inductive.Graph.empty - , _pathGraph' = [] - , _pathPoints = IM.empty - , _pathInc = M.empty - , _carteDisplay = False - , _carteCenter = (0,0) - , _carteZoom = 0.5 - , _carteRot = 0 - , _lightSources = IM.empty - , _tempLightSources = [youLight] - , _closeActiveObjects = [] - , _seenLocations = IM.fromList - [(0, (_crPos . you, "CURRENT POSITION")) - ,(1, (const (0,0) , "START POSITION")) - ] - , _selLocation = 0 - , _keyConfig = defaultKeyConfigSDL - , _config = defaultConfig - , _sideEffects = [] - , _doneSideEffects = [] - , _debugFlags = defaultDebugFlags - } defaultDebugFlags :: DebugFlags defaultDebugFlags = DebugFlags { _noClip = False diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs new file mode 100644 index 000000000..2972a75be --- /dev/null +++ b/src/Dodge/Default/Wall.hs @@ -0,0 +1,50 @@ +module Dodge.Default.Wall + where +import Dodge.Data +import Picture +import qualified DoubleStack as DS +{- Indestructible wall. -} +defaultWall :: Wall +defaultWall = Wall + { _wlLine = ((0,0),(50,0)) + , _wlID = 0 + , _wlColor = greyN 0.6 + , _wlSeen = False + , _wlIsSeeThrough = False + } +{- Indestructible see-through wall. -} +defaultCrystalWall :: Wall +defaultCrystalWall = Wall + { _wlLine = ((0,0),(50,0)) + , _wlID = 0 + , _wlColor = withAlpha 0.5 aquamarine + , _wlSeen = False + , _wlIsSeeThrough = True + } +{- Door that opens on approach. +Pathable. -} +defaultAutoDoor :: Wall +defaultAutoDoor = Door + { _wlLine = ((0,0),(50,0)) + , _wlID = 0 + , _doorMech = id + , _wlColor = light $ dim $ dim $ dim yellow + , _wlSeen = False + , _wlIsSeeThrough = False + , _doorPathable = True + , _drPositions = DS.singleton ((0,0),(50,0)) + } +{- +Non-pathable door. + -} +defaultDoor :: Wall +defaultDoor = Door + { _wlLine = ((0,0),(50,0)) + , _wlID = 0 + , _doorMech = id + , _wlColor = light $ dim $ dim $ dim yellow + , _wlSeen = False + , _wlIsSeeThrough = False + , _doorPathable = False + , _drPositions = DS.singleton ((0,0),(50,0)) + } diff --git a/src/Dodge/Default/Weapon.hs b/src/Dodge/Default/Weapon.hs index b3d105332..2d3ab492d 100644 --- a/src/Dodge/Default/Weapon.hs +++ b/src/Dodge/Default/Weapon.hs @@ -43,3 +43,12 @@ defaultAutoGun = defaultGun , _itScrollDown = const id , _itInvDisplay = basicWeaponDisplay } + +defaultShellAmmo :: Ammo +defaultShellAmmo = ShellAmmo + { _amPayload = \_ -> id + , _amString = "Shell" + , _amPjMove = [] + , _amPjDraw = \_ -> blank + , _amParamSel = 0 + } diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index c3b75a50c..f613711b6 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -46,31 +46,21 @@ handleEvent' e = case eventPayload e of _ -> Just handleMouseMotionEvent :: MouseMotionEventData -> World -> Maybe World -handleMouseMotionEvent mmev w - = Just $ w & mousePos .~ (fromIntegral x - 0.5*getWindowX w - ,0.5*getWindowY w - fromIntegral y - ) - where P (V2 x y) = mouseMotionEventPos mmev +handleMouseMotionEvent mmev w = Just $ w & mousePos .~ + (fromIntegral x - 0.5*getWindowX w + ,0.5*getWindowY w - fromIntegral y + ) + where + P (V2 x y) = mouseMotionEventPos mmev handleMouseButtonEvent :: MouseButtonEventData -> World -> Maybe World handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of - Released -> Just $ over mouseButtons (S.delete but) w - Pressed -> handlePressedMouseButton but - $ over mouseButtons (S.insert but) w - where but = mouseButtonEventButton mbev + Released -> Just $ over mouseButtons (S.delete but) w + Pressed -> handlePressedMouseButton but $ over mouseButtons (S.insert but) w + where + but = mouseButtonEventButton mbev -handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World -handleMouseWheelEvent mwev w = case _menuLayers w of - [] -> case mouseWheelEventPos mwev of - V2 _ y - | y > 0 -> Just (wheelUpEvent w) - | y < 0 -> Just (wheelDownEvent w) - | otherwise -> Just w - _ -> Just w - -{- | -Resets the world window size, and resizes the fbo that gets the light map drawn into it. - -} +{- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. -} handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World handleResizeEvent sev w = Just . set (config . windowX) (fromIntegral x) @@ -89,57 +79,41 @@ handlePressedMouseButton but w = Just $ w & clickMousePos .~ _mousePos w | otherwise = Just w -wheelUpEvent :: World -> World -wheelUpEvent w = case _carteDisplay w of - True - | rbDown -> w & carteZoom .~ min 0.75 (z+(0.1*z)) - | otherwise -> w & selLocation %~ (`mod` numLocs) . (\i -> i - 1) - _ - | rbDown -> fromMaybe (closeObjScrollUp w) - $ (yourItem w ^? itScrollUp) +handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World +handleMouseWheelEvent mwev w = case _menuLayers w of + [] -> case mouseWheelEventPos mwev of + V2 _ y -> Just $ wheelEvent (fromIntegral y) w + _ -> Just w + +wheelEvent :: Float -> World -> World +wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of + (True, _) + | rbDown -> w & carteZoom %~ min 0.75 . max 0.05 . ((1+y*0.1) * ) + | otherwise -> w & selLocation %~ (`mod` numLocs) . (+ yi) + (_, TopInventory) + | rbDown -> fromMaybe (closeObjScrollDir y w) $ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w)) <*> pure w - | lbDown -> w & cameraZoom +~ 0.1 - | invKeyDown -> swapInvUp $ upInvPos w - | otherwise -> upInvPos w - where + | lbDown -> w & cameraZoom +~ y + | invKeyDown -> swapInvDir yi $ dirInvPos yi w + | otherwise -> dirInvPos yi w + (_, TweakInventory) -> w + (_, _) -> w + where + yi = round $ signum y + numLocs = (fst . IM.findMax $ _seenLocations w) + 1 rbDown = ButtonRight `S.member` _mouseButtons w lbDown = ButtonLeft `S.member` _mouseButtons w invKeyDown = ScancodeCapsLock `S.member` _keys w - z = _carteZoom w - numLocs = (fst . IM.findMax $ _seenLocations w) + 1 -wheelDownEvent :: World -> World -wheelDownEvent w = case _carteDisplay w of - True - | rbDown -> w & carteZoom .~ max 0.05 (z-(0.1*z)) - | otherwise -> w & selLocation %~ (`mod` numLocs) . (+ 1) - False - | rbDown -> fromMaybe (closeObjScrollDown w) - $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w)) <*> pure w - | lbDown -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} - | invKeyDown -> downInvPos $ swapInvUp w - | otherwise -> downInvPos w - where - rbDown = ButtonRight `S.member` _mouseButtons w - lbDown = ButtonLeft `S.member` _mouseButtons w - z = _carteZoom w - invKeyDown = ScancodeCapsLock `S.member` _keys w - numLocs = (fst . IM.findMax $ _seenLocations w) + 1 - -swapInvUp :: World -> World -swapInvUp w = w & creatures . ix (_yourID w) . crInv %~ IM.swapKeys (i `mod` n) ((i + 1) `mod` n) +swapInvDir :: Int -> World -> World +swapInvDir k w = w & creatures . ix (_yourID w) . crInv %~ IM.swapKeys (i `mod` n) ((i + k) `mod` n) where i = _crInvSel $ you w n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w -upInvPos :: World -> World -upInvPos w = stopSoundFrom (CrReloadSound 0) $ w - & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract 1 - where - n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w -downInvPos :: World -> World -downInvPos w = stopSoundFrom (CrReloadSound 0) $ w - & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . (+ 1) +dirInvPos :: Int -> World -> World +dirInvPos i w = stopSoundFrom (CrReloadSound 0) $ w + & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract i where n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index d146f5fbe..42000a222 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -16,7 +16,7 @@ import Dodge.LightSources import Dodge.LevelGen import Dodge.Creature.Inanimate import qualified Data.IntMap.Strict as IM -import Dodge.Event.Test +--import Dodge.Event.Test import Dodge.Event.Menu import SDL @@ -51,14 +51,22 @@ handlePressedKeyInGame scode w | scode == dropItemKey (_keyConfig w) = Just $ youDropItem w | scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w | scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ startReloadingWeapon (you w) w - | scode == testEventKey (_keyConfig w) = Just $ testEvent w +-- | scode == testEventKey (_keyConfig w) = Just $ testEvent w | scode == spaceActionKey (_keyConfig w) = Just $ spaceAction w | scode == rotateCameraPlusKey (_keyConfig w) = Just $ w & cameraRot +~ 0.01 | scode == rotateCameraMinusKey (_keyConfig w) = Just $ w & cameraRot -~ 0.01 | scode == ScancodeF5 = Just $ dropLight w | scode == ScancodeF6 = Just $ dropLight' w + | scode == ScancodeT = Just $ w & inventoryMode %~ toggleInv TweakInventory + | scode == ScancodeC = Just $ w & inventoryMode %~ toggleInv CombineInventory + | scode == ScancodeI = Just $ w & inventoryMode %~ toggleInv InspectInventory handlePressedKeyInGame _ w = Just w +toggleInv :: InventoryMode -> InventoryMode -> InventoryMode +toggleInv x y + | x == y = TopInventory + | otherwise = x + inTerminal :: World -> Bool inTerminal w = case _menuLayers w of diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index e837ce1a8..6cffad420 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -10,16 +10,6 @@ import qualified Data.IntMap.Strict as IM --import System.Random import Control.Lens -checkInvSlotsYou' :: Maybe Item -> World -> Maybe Int -checkInvSlotsYou' it w = fst <$> find cond invListSelFirst - where - cond (_,NoItem) = True - cond (_,it' ) = itNotFull it' && fmap _itName it == Just (_itName it') - youCr = you w - youSel = _crInvSel youCr - invList = _crInv youCr - invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList - checkInvSlotsYou :: Item -> World -> Maybe Int checkInvSlotsYou it w = fst <$> find cond invListSelFirst where @@ -93,6 +83,12 @@ updateCloseObjects w = w & closeActiveObjects .~ unionBy eTest oldCloseFiltered oldClose = filt $ _closeActiveObjects w oldCloseFiltered = intersectBy eTest oldClose currentClose +closeObjScrollDir :: Float -> World -> World +closeObjScrollDir x + | x > 0 = closeObjScrollUp + | x < 0 = closeObjScrollDown + | otherwise = id + closeObjScrollUp :: World -> World closeObjScrollUp = over closeActiveObjects rotU where rotU [] = [] diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 8ccf6fc71..c4ebf7ace 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -42,7 +42,7 @@ launcher = defaultGun , _itEquipPict = pictureWeaponOnAim $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5) , _itHammer = NoHammer , _itEffect = NoItEffect - , _wpAmmo = ShellAmmo + , _wpAmmo = defaultShellAmmo { _amPayload = makeExplosionAt , _amString = "" , _amPjMove = basicAmPjMoves @@ -50,11 +50,23 @@ launcher = defaultGun } } -basicAmPjMoves :: Item -> Creature -> [Projectile -> World -> World] -basicAmPjMoves _ cr = - [reduceSpinBy 0.995 - ,pjEffAtTime 35 $ trySpinByCID (_crID cr) +basicAmPjMoves :: [PjParam] +basicAmPjMoves = + [spinDrag + ,spinStart ] +spinDrag :: PjParam +spinDrag = PjParam + { _pjMoveParam = \_ _ _ -> reduceSpinBy 0.995 + , _pjIntParam = 0 + , _pjDisplayParam = ("SPIN DRAG:" ++ ) . show + } +spinStart :: PjParam +spinStart = PjParam + { _pjMoveParam = \_ _ cr -> pjEffAtTime 35 $ trySpinByCID (_crID cr) + , _pjIntParam = 0 + , _pjDisplayParam = ("SPIN START:" ++ ) . show + } flameLauncher :: Item flameLauncher = launcher & wpAmmo . amPayload .~ makeFlameExplosionAt @@ -74,7 +86,7 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w i = IM.newKey $ _projectiles w pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) dir = _crDir cr - ammoMvs pj w' = foldr ($ pj) w' (_amPjMove am it cr) + ammoMvs pj w' = foldr (\pjP -> (_pjMoveParam pjP) (_pjIntParam pjP) it cr pj) w' (_amPjMove am) theShell = defaultShell { _pjPos = pos , _pjStartPos = pos diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 204fffc8d..748941d72 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -9,7 +9,7 @@ import Dodge.Base import Dodge.Graph import Dodge.Layout.Tree.Polymorphic (applyToRoot) import Dodge.Room.Data -import Dodge.Default +import Dodge.Default.Wall import Geometry import Dodge.Room.Link import qualified IntMapHelp as IM diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index e9a2c1e68..df376d38b 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Render.HUD where import Dodge.Data @@ -8,12 +9,17 @@ import Geometry import Data.Maybe import qualified Data.IntMap as IM +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 = setLayer 1 . setDepth (-0.5) . pictures $ - [ scaler . dShadCol white $ displayHP 0 w - , scaler . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w) + [ winScale w . dShadCol white $ displayHP 0 w + , winScale w . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w) ] ++ selectionText where @@ -21,26 +27,65 @@ hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $ if _carteDisplay w then drawLocations w else drawInventory w - scaler = scale (2 / getWindowX w) (2 / getWindowY w) drawInventory :: World -> [Picture] -drawInventory w = - [ closeObjectTexts w - , drawListCursor (itCol (yourItem w)) iPos w - ] - ++ displayInv 0 w +drawInventory w = case _inventoryMode w of + TopInventory -> [ closeObjectTexts w] + ++ topInvCursor col iPos w + ++ displayInv 0 w + TweakInventory -> + mCurs it w + ++ [cursorAt 120 col 5 iPos w] + ++ displayInv 0 w + ++ displayMidList w (ammoTweakStrings it) "TWEAK" + ++ mCurs it w + CombineInventory -> displayInv 0 w ++ invHead w "COMBINE" + InspectInventory -> displayInv 0 w ++ invHead w "INSPECT" where itCol = fromMaybe (greyN 0.5) . (^? itInvColor) iPos = _crInvSel $ _creatures w IM.! _yourID w + it = yourItem w + col = itCol it + +topInvCursor :: Color -> Int -> World -> [Picture] +topInvCursor col iPos w + | ButtonRight `S.member` _mouseButtons w = + [cursorAt 100 col 5 iPos w + ,openCursorAt 20 col 105 iPos w] + | otherwise = [ openCursorAt 120 col 5 iPos w ] + +ammoTweakStrings :: Item -> [String] +ammoTweakStrings it = case it ^? wpAmmo . amPjMove of + Just l -> map pjTweakString l + _ -> ["NOT TWEAKABLE"] + +mCurs :: Item -> World -> [Picture] +mCurs it w = case it ^? wpAmmo . amParamSel of + Nothing -> [] + Just i -> [openCursorAt 120 white 200 i w] + +pjTweakString :: PjParam -> String +pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj + +displayMidList :: World -> [String] -> String -> [Picture] +displayMidList w strs s = + invHead w s + ++ renderListAt (200,0) (map (,white) strs) w + +invHead :: World -> String -> [Picture] +invHead w s = [winScale w . translate (-150) (150-halfHeight w) + . dShadCol white . scale 0.5 0.5 $ text s + ] displayListTopLeft :: [(String,Color)] -> World -> [Picture] -displayListTopLeft scols w = - map scaler $ zipWith - (translate (15-halfWidth w)) - ( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) ) +displayListTopLeft = renderListAt (0,0) + +renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture] +renderListAt (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 ) - where - scaler = scale (2 / getWindowX w) (2 / getWindowY w) displayInv :: Int -> World -> [Picture] displayInv n w = displayListTopLeft scols w @@ -60,13 +105,15 @@ drawLocations wrld = displayListTopLeft locs wrld iPos = _selLocation wrld locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld - --cZoom = _carteZoom w locTexts = map fst locs bFunc (x,y) (z,w) = pictures - [ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w) - , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w) - , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.035 0.002 (x,y) (0,y) (z,w) + [ 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 (x,y) (0,y) (z,w) displayListCoords :: World -> [Point2] displayListCoords w = map (g . f) [(1::Int)..] @@ -96,24 +143,22 @@ mapWall w wl = else Nothing where t = normalizeV (y -.- x) --- n2 = 2 *.* vNormal t n2 = 20 *.* vNormal t (x,y) = _wlLine 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 + ++ maybeToList maybeLine where colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x) colAndText (Right x) = (white, _btText x) - renderList i (c,t) = scale (2/getWindowX w) (2/getWindowY w) - . tran - . translate (xtran i) (negate (20 * fromIntegral i)) - . scale 0.1 0.1 - . color c - $ text t + 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)) youSel = _crInvSel $ you w freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w @@ -147,22 +192,49 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText ,(sc p' , col) ,(sc p , col) ] - -{- | Add coloured drop shadow. -} +{- | 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 c p - ] + [ color black $ uncurry translate (1.2,-1.2) p + , color c p + ] drawListCursor :: Color -> Int -> World -> Picture -drawListCursor c iPos w = scale (2 / getWindowX w) (2 / getWindowY w) - . translate (105-halfWidth w) (halfHeight w - (20* fromIntegral iPos) - 20) - $ lineCol [(( 100,12.5) ,withAlpha 0 c) - ,((-100,12.5) ,c) - ,((-100,-7.5) ,c) - ,(( 100,-7.5) ,withAlpha 0 c) - ] +drawListCursor c = openCursorAt 120 c 5 + +openCursorAt + :: Float -- ^ Width + -> Color + -> Float -- ^ x offset + -> Int -- ^ y offset (discrete) + -> World + -> Picture +openCursorAt wth col xoff yint w = winScale w + . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint) - 20) + $ lineCol + [(( wth,12.5) ,withAlpha 0 col) + ,(( 0,12.5) ,col) + ,(( 0,-7.5) ,col) + ,(( wth,-7.5) ,withAlpha 0 col) + ] +cursorAt + :: Float -- ^ Width + -> Color + -> Float -- ^ x offset + -> Int -- ^ y offset (discrete) + -> World + -> Picture +cursorAt wth col xoff yint w = winScale w + . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint) - 20) + . color col + $ line + [( wth,12.5) + ,( 0,12.5) + ,( 0,-7.5) + ,( wth,-7.5) + ,( wth,12.5) + ] + displayHP :: Int -> World -> Picture displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $ diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 4f5ac2841..7faa51f6d 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -45,11 +45,12 @@ customMouseCursor w = $ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ] testPic :: World -> [Picture] -testPic w = - [ setDepth (-1) . translate 0 0.8 - . scale 0.001 0.001 . text . show . length . IM.elems - . IM.filter ( (== 3) . _crRad ) $ _creatures w - ] +testPic _ = [] +--testPic w = +-- [ setDepth (-1) . translate 0 0.8 +-- . scale 0.001 0.001 . text . show . length . IM.elems +-- . IM.filter ( (== 3) . _crRad ) $ _creatures w +-- ] crDraw :: World -> Creature -> Picture crDraw w c = (_crPict c c w) diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 76fd089bf..c47bebab1 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -14,7 +14,7 @@ import Dodge.Creature import Dodge.LevelGen.Data --import Dodge.Base import Dodge.RandomHelp -import Dodge.Default +import Dodge.Default.Wall --import Dodge.Path --import Dodge.Layout import Dodge.Layout.Tree.Polymorphic diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index dcee12ef8..50329f16d 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -2,7 +2,7 @@ module Dodge.Room.Placement where import Dodge.Data -import Dodge.Default +import Dodge.Default.Wall import Dodge.LevelGen.Data import Dodge.Room.Data import Dodge.Creature.Inanimate