Refactor inventory management, add tweak, combine and inspect modes

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

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.  -}
+defaultWorld :: World
-defaultWall :: Wall
+defaultWorld = World
-defaultWall = Wall 
+    { _keys = S.empty
-    { _wlLine = ((0,0),(50,0))
+    , _mouseButtons = S.empty
-    , _wlID = 0
+    , _cameraCenter = (0,0)
-    , _wlColor = greyN 0.6
+    , _cameraRot = 0
-    , _wlSeen = False
+    , _cameraZoom = 1
-    , _wlIsSeeThrough = False
+    , _cameraViewFrom = (0,0)
-    }
+    , _creatures = IM.empty
-{- Indestructible see-through wall.  -}
+    , _creaturesZone = IM.empty
-defaultCrystalWall :: Wall
+    , _creatureGroups = IM.empty
-defaultCrystalWall = Wall 
+    , _clouds = IM.empty
-    { _wlLine = ((0,0),(50,0))
+    , _cloudsZone = IM.empty
-    , _wlID = 0
+    , _itemPositions = IM.empty
-    , _wlColor = withAlpha 0.5 aquamarine
+    , _projectiles = IM.empty
-    , _wlSeen = False
+    , _particles = []
-    , _wlIsSeeThrough = True
+    , _staticWalls = []
-    }
+    , _walls = IM.empty
-{- Door that opens on approach.
+    , _wallsZone = IM.empty
-Pathable.  -}
+    , _forceFields = IM.empty
-defaultAutoDoor :: Wall
+    , _floorItems = IM.empty
-defaultAutoDoor = Door 
+    , _randGen = mkStdGen 2
-    { _wlLine = ((0,0),(50,0))
+    , _mousePos = (0,0)
-    , _wlID = 0
+    , _testString = []
-    , _doorMech = id
+    , _yourID = 0
-    , _wlColor = light $ dim $ dim $ dim yellow
+    , _worldEvents = id
-    , _wlSeen = False
+    , _pressPlates = IM.empty
-    , _wlIsSeeThrough = False
+    , _buttons = IM.empty
-    , _doorPathable = True
+    , _soundQueue = []
-    , _drPositions = DS.singleton ((0,0),(50,0))
+    , _sounds = M.empty
-    }
+    , _corpses = IM.empty
-{-
+    , _decorations = IM.empty
-Non-pathable door.
+    , _storedLevel = Nothing
- -}
+    , _menuLayers = [LevelMenu 1]
-defaultDoor :: Wall
+    , _worldState = M.empty
-defaultDoor = Door 
+    , _worldTriggers = S.empty
-    { _wlLine = ((0,0),(50,0))
+    , _clickMousePos = (0,0)
-    , _wlID = 0
+    , _pathGraph = Data.Graph.Inductive.Graph.empty
-    , _doorMech = id
+    , _pathGraph' = []
-    , _wlColor = light $ dim $ dim $ dim yellow
+    , _pathPoints = IM.empty
-    , _wlSeen = False
+    , _pathInc = M.empty
-    , _wlIsSeeThrough = False
+    , _carteDisplay = False
-    , _doorPathable = False
+    , _carteCenter = (0,0)
-    , _drPositions = DS.singleton ((0,0),(50,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

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))
+    }

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
+    }

src/Dodge/Event.hs

@@ -46,31 +46,21 @@ handleEvent' e = case eventPayload e of
     _                           -> Just
 
 handleMouseMotionEvent :: MouseMotionEventData -> World -> Maybe World
-handleMouseMotionEvent mmev w
+handleMouseMotionEvent mmev w = Just $ w & mousePos .~ 
-    = Just $ w & mousePos .~ (fromIntegral x - 0.5*getWindowX w
+    (fromIntegral x - 0.5*getWindowX w
-                             ,0.5*getWindowY w - fromIntegral y
+    ,0.5*getWindowY w - fromIntegral y
-                             )
+    )
-    where P (V2 x y) = mouseMotionEventPos mmev
+  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
+    Released -> Just $ over mouseButtons (S.delete but) w
-    Pressed  -> handlePressedMouseButton but 
+    Pressed  -> handlePressedMouseButton but $ over mouseButtons (S.insert but) w
-                        $ over mouseButtons (S.insert but) w
+  where 
-    where but = mouseButtonEventButton mbev
+    but = mouseButtonEventButton mbev
 
-handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
+{- | Resets the world window size, and resizes the fbo that gets the light map drawn into it.  -}
-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.
- -}
 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
+handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
-wheelUpEvent w = case _carteDisplay w of
+handleMouseWheelEvent mwev w = case _menuLayers w of
-    True    
+    [] -> case mouseWheelEventPos mwev of
-        | rbDown    -> w & carteZoom .~ min 0.75 (z+(0.1*z))
+        V2 _ y -> Just $ wheelEvent (fromIntegral y) w
-        | otherwise -> w & selLocation %~ (`mod` numLocs) . (\i -> i - 1)
+    _ -> Just w
-    _       
+
-        | rbDown    -> fromMaybe (closeObjScrollUp w) 
+wheelEvent :: Float -> World -> World
-                            $ (yourItem w ^? itScrollUp) 
+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
+        | lbDown -> w & cameraZoom +~ y
-        | invKeyDown -> swapInvUp $ upInvPos w
+        | invKeyDown -> swapInvDir yi $ dirInvPos yi w
-        | otherwise -> upInvPos 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
+swapInvDir :: Int -> World -> World
-wheelDownEvent w = case _carteDisplay w of
+swapInvDir k w = w & creatures . ix (_yourID w) . crInv %~ IM.swapKeys (i `mod` n) ((i + k) `mod` n)
-    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)
   where
     i = _crInvSel $ you w
     n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w
 
-upInvPos :: World -> World
+dirInvPos :: Int -> World -> World
-upInvPos w = stopSoundFrom (CrReloadSound 0) $ w
+dirInvPos i w =  stopSoundFrom (CrReloadSound 0) $ w
-    & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract 1
+    & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract i
-  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)
   where 
     n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w

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

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 [] = []

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 :: [PjParam]
-basicAmPjMoves _ cr = 
+basicAmPjMoves = 
-    [reduceSpinBy 0.995
+    [spinDrag
-    ,pjEffAtTime 35 $ trySpinByCID (_crID cr)
+    ,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

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

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
+    [ winScale w . dShadCol white $ displayHP 0 w
-    , scaler . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString 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 = 
+drawInventory w = case _inventoryMode w of
-    [ closeObjectTexts w
+    TopInventory -> [ closeObjectTexts w]
-    , drawListCursor (itCol (yourItem w)) iPos w
+        ++ topInvCursor col iPos w
-    ]
+        ++ displayInv 0 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 = 
+displayListTopLeft = renderListAt (0,0) 
-    map scaler $ zipWith 
+
-        (translate (15-halfWidth w))
+renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture]
-        ( map (\x -> halfHeight w - (20 * (fromIntegral x+1)))    ([0..]::[Int]) )
+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)
+        [ bline 0.2 0.050 0.010
-        , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w)
+        , bline 0.5 0.045 0.005
-        , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.035 0.002 (x,y) (0,y) (z,w)
+        , 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)
+    renderList i (c,t) = winScale w
-                         . tran
+        . tran
-                         . translate (xtran i) (negate (20 * fromIntegral i))
+        . translate (xtran i) (negate (20 * fromIntegral i))
-                         . scale 0.1 0.1 
+        . scale 0.1 0.1 
-                         . color c 
+        . color c 
-                         $ text t
+        $ 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)
                       ]
-
+{- | Colour picture and add black drop shadow. -}
-{- | Add coloured drop shadow. -}
 dShadCol :: Color -> Picture -> Picture
 dShadCol c p = pictures
-                [ color black $ uncurry translate (1.2,-1.2) p
+    [ color black $ uncurry translate (1.2,-1.2) p
-                , color c p
+    , color c p
-                ]
+    ]
 
 drawListCursor :: Color -> Int -> World -> Picture
-drawListCursor c iPos w = scale (2 / getWindowX w) (2 / getWindowY w)
+drawListCursor c = openCursorAt 120 c 5
-    . translate (105-halfWidth w) (halfHeight w - (20* fromIntegral iPos) - 20)
+
-                 $ lineCol [(( 100,12.5) ,withAlpha 0 c)
+openCursorAt 
-                           ,((-100,12.5) ,c)
+    :: Float    -- ^ Width
-                           ,((-100,-7.5) ,c)
+    -> Color
-                           ,(( 100,-7.5) ,withAlpha 0 c)
+    -> 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) $

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 = 
+testPic _ = []
-    [ setDepth (-1) . translate 0 0.8
+--testPic w = 
-        . scale 0.001 0.001 . text . show . length . IM.elems 
+--    [ setDepth (-1) . translate 0 0.8
-        . IM.filter ( (== 3) . _crRad ) $ _creatures w
+--        . 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)

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

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