Implement combining of items

src/Dodge/Combine.hs

@@ -1,18 +1,21 @@
 {-# LANGUAGE TupleSections #-}
 module Dodge.Combine where
+import Dodge.Base.You
 import Dodge.Data
 --import Dodge.Combine.Data
 import Dodge.Combine.Combinations
 import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Craftable
 
+import Control.Lens
 import Data.Bifunctor
---import qualified Data.IntMap.Strict as IM
+import qualified Data.IntMap.Strict as IM
 --import qualified Data.IntSet as IS
 import qualified Data.Map.Strict as M
+import Data.Maybe
 
-pureCombine :: [ (M.Map CombineType Int, Item) ]
+itemCombinations :: [ (M.Map CombineType Int, Item) ]
-pureCombine = map (first toMultiset)
+itemCombinations = map (first toMultiset)
     [ p [PIPE,HARDWARE] bangStick
     , p [LONGPIPE,HARDWARE] bangCane
     , p [VERYLONGPIPE,HARDWARE] bangRod
@@ -21,3 +24,30 @@ pureCombine = map (first toMultiset)
     ]
   where
     p = (,)
+
+combineToItem :: M.Map CombineType Int -> Maybe Item
+combineToItem m = lookup m itemCombinations
+
+combineItemList :: IM.IntMap CombineType -> [([Int],Item)]
+combineItemList m = mapMaybe (pushoutmaybe . second (combineToItem . toMultiset) . unzip)
+    . powlistN 4
+    $ IM.toList m
+  where
+    pushoutmaybe (_,Nothing) = Nothing
+    pushoutmaybe (x,Just y)  = Just (x,y)
+
+combineItemListYou :: World -> [([Int],Item)]
+combineItemListYou = combineItemList . fmap _itCombineType . yourInv
+
+combineListYou :: World -> [([Int],CombineType)]
+combineListYou = combineList . fmap _itCombineType . yourInv
+
+toggleCombineInv :: World -> World
+toggleCombineInv w = case _inventoryMode w of
+    CombineInventory _ -> w & inventoryMode .~ TopInventory
+    _ -> w & enterCombineInv
+
+enterCombineInv :: World -> World
+enterCombineInv w = w & inventoryMode .~ CombineInventory mi
+  where
+    mi = const 0 <$> listToMaybe (combineListYou w)

src/Dodge/Combine/Combinations.hs

@@ -43,4 +43,3 @@ combinations = map (first toMultiset)
     , ( [ PIPE, PIPE ] , LONGPIPE )
     , ( [ LONGPIPE, PIPE ] , VERYLONGPIPE )
     ]
-

src/Dodge/Creature.hs

@@ -17,6 +17,7 @@ import Dodge.Item.Weapon.Grenade
 import Dodge.Item.Weapon.Booster
 import Dodge.Item.Weapon.Utility
 import Dodge.Item.Weapon.Drone
+import Dodge.Item.Craftable
 --import Dodge.Creature.ReaderUpdate
 --import Dodge.Creature.AlertLevel
 --import Dodge.Creature.SetTarget
@@ -171,6 +172,10 @@ startInventory = IM.fromList $ zip [0..] startInvList
 stackedInventory :: IM.IntMap Item
 stackedInventory = IM.fromList $ zip [0..] 
     [spreadGun
+    , pipe
+    , makeTypeCraft LONGPIPE
+    , makeTypeCraft VERYLONGPIPE
+    , makeTypeCraft HARDWARE
     ,rewindGun
     ,tractorGun
     ,longGun

src/Dodge/Creature/Action.hs

@@ -14,6 +14,7 @@ module Dodge.Creature.Action
     , copyInvItemToFloor
     , youDropItem
     , pickUpItem
+    , pickUpItemID
     )
     where
 import Dodge.Path
@@ -221,21 +222,6 @@ youDropItem w = case yourItem w ^? _Just . itCurseStatus of
 copyInvItemToFloor :: Creature -> Int -> World -> World
 copyInvItemToFloor cr i = copyItemToFloor (_crPos cr) (_crInv cr IM.! i)
 
-{- | Pick up a specific item. -}
-pickUpItem :: Int -> FloorItem -> World -> World
-pickUpItem cid flit w = case maybeInvSlot of
-    Nothing -> w
-    Just i  -> w
-        & soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing
-        & updateItLocation i
-        & floorItems %~ IM.delete (_flItID flit)
-        & creatures . ix cid . crInv %~ IM.insertWith (const $ itAmount +~ 1) i it
-  where 
-    it = _flIt flit
-    maybeInvSlot = checkInvSlotsYou it w
-    updateItLocation invid w' = case _itID it of 
-        Nothing -> w'
-        Just j  -> w' & itemPositions . ix j .~ InInv 0 invid
 
 sizeSelf :: Float -> Creature -> World -> Maybe World
 sizeSelf x cr w 
@@ -259,3 +245,23 @@ sizeSelf x cr w
     raddist = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR)
     cid  = _crID cr
     cpos = _crPos cr
+
+pickUpItemID :: Int -> Int -> World -> World
+pickUpItemID cid flid w = pickUpItem cid (_floorItems w IM.! flid) w
+
+
+{- | Pick up a specific item. -}
+pickUpItem :: Int -> FloorItem -> World -> World
+pickUpItem cid flit w = case maybeInvSlot of
+    Nothing -> w
+    Just i  -> w
+        & soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing
+        & updateItLocation i
+        & floorItems %~ IM.delete (_flItID flit)
+        & creatures . ix cid . crInv %~ IM.insertWith (const $ itAmount +~ 1) i it
+  where 
+    it = _flIt flit
+    maybeInvSlot = checkInvSlotsYou it w
+    updateItLocation invid w' = case _itID it of 
+        Nothing -> w'
+        Just j  -> w' & itemPositions . ix j .~ InInv 0 invid

src/Dodge/Data.hs

@@ -167,7 +167,7 @@ data MenuOption
 data InventoryMode
     = TopInventory
     | TweakInventory
-    | CombineInventory
+    | CombineInventory {_combineInvSel :: Maybe Int}
     | InspectInventory
     | LockedInventory
   deriving (Eq, Ord, Show)
@@ -940,3 +940,4 @@ makeLenses ''LSParam
 makeLenses ''ItemParams
 makeLenses ''ItemTweaks
 makeLenses ''Maybe'
+makeLenses ''InventoryMode

src/Dodge/Event.hs

@@ -13,6 +13,7 @@ module Dodge.Event
     ( handleEvent
     ) where
 import Dodge.Event.Keyboard
+import Dodge.Combine
 --import Dodge.Event.Menu
 import Dodge.Data
 import Dodge.Base
@@ -21,10 +22,14 @@ import Dodge.PreloadData
 --import Dodge.Creature.Action
 import Dodge.SoundLogic
 import Dodge.Inventory
+import Dodge.Inventory.PickUp
 --import Geometry
 --import Preload.Update
 import qualified IntMapHelp as IM
+import ListHelp
+import Dodge.FloorItem
 
+--import Data.Monoid
 import Data.Maybe
 import Control.Lens
 --import Data.Maybe
@@ -92,8 +97,23 @@ handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe
 handlePressedMouseButton but w
     | but == ButtonMiddle || _carteDisplay (_uvWorld w) 
                 = Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
+    | but == ButtonLeft = case _inventoryMode (_uvWorld w) of
+        CombineInventory mi -> Just $ fromMaybe w $ do -- ugly
+            i <- mi
+            return $ over uvWorld (doCombine i) w
+        _ -> Just w
     | otherwise = Just w
 
+doCombine :: Int -> World -> World
+doCombine i w = case combineItemListYou w !? i of
+    Nothing -> w
+    Just (is,it) -> enterCombineInv
+        . uncurry (putItemInInvID yid)
+        . copyItemToFloorID (_crPos $ you w) it
+        $ foldr (rmInvItem yid) w is & enterCombineInv
+  where
+    yid = _yourID w
+
 handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe
 handleMouseWheelEvent mwev w = case _menuLayers w of
     [] -> case mouseWheelEventPos mwev of
@@ -117,14 +137,29 @@ wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
         | invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeInvSel yi w
         | rbDown ->     w & changeTweakParam yi
         | otherwise ->  w & moveTweakSel yi
+    (_, CombineInventory _) -> w 
+        & inventoryMode . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
     (_, _) -> w
   where
+    numcombs = length $ combineListYou w
     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
 
+-- nice idea, but the chain of setters and getters seems prohibitive
+--scrollOver :: Foldable t
+--    => ASetter s s Int Int  -- index setter
+--    -> Getting (First (t a)) s (t a) -- pointer to object of size
+--    -> Float -- direction
+--    -> s -> s
+--scrollOver theset theget y w = case w ^? theget of
+--    Just t  -> w & theset %~ ( (`mod` length t) . (subtract y'))
+--    Nothing -> w
+--  where
+--    y' = round $ signum y
+
 moveTweakSel :: Int -> World -> World
 moveTweakSel i w = case yourItem w ^? _Just . itTweaks . tweakParams of
     Just l -> w & creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))

src/Dodge/Event/Keyboard.hs

@@ -3,6 +3,7 @@ module Dodge.Event.Keyboard
     ( handleKeyboardEvent
     ) where
 import Dodge.Data
+import Dodge.Combine
 import Dodge.Save
 import Dodge.Base
 import Dodge.Reloading
@@ -50,7 +51,7 @@ handlePressedKeyInGame scode w = case scode of
     ScancodeR   -> Just $ fromMaybe w $ startReloadingWeapon (you w) w
     ScancodeT   -> Just $ testEvent w
     ScancodeX   -> Just $ w & inventoryMode %~ toggleInv TweakInventory
-    ScancodeC   -> Just $ w & inventoryMode %~ toggleInv CombineInventory
+    ScancodeC   -> Just $ toggleCombineInv w
     ScancodeI   -> Just $ w & inventoryMode %~ toggleInv InspectInventory
     _           -> Just w
 

src/Dodge/FloorItem.hs

@@ -1,5 +1,6 @@
 module Dodge.FloorItem 
     (copyItemToFloor
+    ,copyItemToFloorID
     ) where
 import Dodge.Data
 import Dodge.Base
@@ -12,7 +13,11 @@ import Data.Maybe
 
 {- | Copy an item to the floor. -}
 copyItemToFloor :: Point2 -> Item -> World -> World
-copyItemToFloor pos it w = w'
+copyItemToFloor pos it = snd . copyItemToFloorID pos it
+
+{- | Copy an item to the floor, returns the floor item's id. -}
+copyItemToFloorID :: Point2 -> Item -> World -> (Int, World)
+copyItemToFloorID pos it w = (,) flid $ w'
     & floorItems %~ IM.insert flid theflit
     & updateLocation 
   where

src/Dodge/Inventory.hs

@@ -19,6 +19,7 @@ module Dodge.Inventory
     where
 import Dodge.Data
 import Dodge.Inventory.CloseObject
+import Dodge.Inventory.CheckSlots
 import Dodge.Base
 import Dodge.Base.Collide
 import Geometry
@@ -32,25 +33,6 @@ import Data.Maybe
 --import System.Random
 import Control.Lens
 
--- | checks whether or not an item will fit in your inventory
--- if so return Just the next slot to be used
-checkInvSlotsYou :: Item -> World -> Maybe Int
-checkInvSlotsYou it w
-    | crNumFreeSlots ycr >= _itInvSize it 
-                = Just $ maybe 0 ((+1) . fst) $ IM.lookupMax inv
-    | otherwise = Nothing
-  where 
-    ycr = you w
-    inv = _crInv ycr
-
-crNumFreeSlots :: Creature -> Int
-crNumFreeSlots cr = _crInvCapacity cr - invSize (_crInv cr)
-
-crInvSize :: Creature -> Int
-crInvSize = invSize . _crInv
-
-invSize :: IM.IntMap Item -> Int
-invSize = sum . fmap _itInvSize
 
 -- | after this the item at the inventory position will no longer exist
 rmInvItem :: Int      -- ^ Creature id
@@ -87,6 +69,7 @@ closeObjectSize e = case e of
     Left flit -> _itInvSize $ _flIt flit
     Right _  -> 1
 
+
 selNumPos :: Int -> World -> Int
 selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w))
   where

src/Dodge/Item/Weapon/BulletGuns.hs

@@ -125,8 +125,31 @@ bangStick = defaultGun
         }
     , _itTweaks = defaultBulletSelTweak
     }
+bangCane,bangRod :: Item
 bangCane = bangStick
+    { _itParams = BulletShooter
+        { _muzVel = 0.8
+        , _rifling = 0.9
+        , _bore = 2
+        , _gunBarrels = SingleBarrel 0.05
+        }
+    , _itFloorPict = autoGunPic
+    } & itUse . useAim . aimSpeed .~ 0.4
+      & itUse . useAim . aimRange .~ 1
+      & itUse . useAim . aimStance .~ TwoHandTwist
+      & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5}
 bangRod = bangCane
+    { _itParams = BulletShooter
+        { _muzVel = 0.8
+        , _rifling = 1
+        , _bore = 2
+        , _gunBarrels = SingleBarrel 0.05
+        }
+    , _itFloorPict = longGunSPic
+    } & itUse . useAim . aimSpeed .~ 0.2
+      & itUse . useAim . aimRange .~ 1
+      & itUse . useAim . aimStance .~ TwoHandTwist
+      & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5}
 
 pistol :: Item
 pistol = defaultGun 

src/Dodge/Render/HUD.hs

@@ -4,15 +4,17 @@ module Dodge.Render.HUD
     ) where
 import Dodge.Data
 import Dodge.WinScale
+import Dodge.Combine
 import Dodge.Base
 import Dodge.Base.Window
-import Dodge.Combine.Combinations
+--import Dodge.Combine.Combinations
 import Dodge.Inventory
 import Dodge.Render.Connectors
 import Dodge.Render.List
 import Picture
 import Geometry
 import Padding
+import ListHelp
 
 --import Data.Foldable
 import Data.Maybe
@@ -20,6 +22,7 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Set as S
 import Control.Lens
 import SDL (MouseButton (..))
+--import Data.List
 --import Data.Bifunctor
 
 hudDrawings :: Configuration -> World -> Picture
@@ -36,6 +39,7 @@ subInventoryDisplay cfig w = case _inventoryMode w of
     LockedInventory -> mempty -- topInvCursor col cursPos cfig w
     TopInventory -> pictures
         [ --closeObjectTexts cfig w 
+        selcursor
         ]
     TweakInventory -> pictures
         [ mCurs it cfig w
@@ -43,9 +47,17 @@ subInventoryDisplay cfig w = case _inventoryMode w of
         , cursorsZ cfig cursPos it
         , displayMidList cfig (ammoTweakStrings it) "TWEAK"
         ]
-    CombineInventory -> 
+    CombineInventory mi -> pictures
-        displayMidList cfig (combineListStrings w) "COMBINE"
+        [ invHead cfig "COMBINE"
---        invHead cfig "COMBINE"
+        , listTextPicturesAt 150 60 cfig $ map text $ combineListStrings w
+        , fromMaybe mempty $ do
+            i <- mi
+            return $ listCursorAt 150 60 cfig i white 10 1
+        , fromMaybe mempty $ do
+            i <- mi
+            lnks <- combineListLnks w !? i
+            return $ uncurry (lnkMidPosInvSels cfig w) lnks
+        ]
     InspectInventory -> invHead cfig "INSPECT"
   where 
     itCol = fromMaybe (greyN 0.5) . (^? _Just . itInvColor)
@@ -53,6 +65,24 @@ subInventoryDisplay cfig w = case _inventoryMode w of
     it = yourItem w
     col = itCol it
     cursPos = invSelPos w
+    selcursor 
+        | IM.null inv && null (_closeObjects w) = mempty
+        | otherwise   = listCursorAt 0 0 cfig curpos white curx cury
+    inv = _crInv cr
+    curpos = invSelPos w
+    curx   = 10
+    cury   = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
+    cr = _creatures w IM.! 0
+
+lnkMidPosInvSels :: Configuration -> World -> Int -> [Int] -> Picture
+lnkMidPosInvSels cfig w i is = winScale cfig . color white 
+    .  concatMap
+    (zConnect rp) $ map (lp . flip selNumPos w) is
+  where
+    lp ipos = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
+    rp = (V2 (155 - hw) ( hh - (20 * fromIntegral i + 77.5)))
+    hh = halfHeight cfig
+    hw = halfWidth  cfig
 
 cursorsZ :: Configuration -> Int -> Maybe Item -> Picture
 cursorsZ cfig ipos it = case it ^? _Just . itTweaks . tweakSel of
@@ -64,8 +94,12 @@ cursorsZ cfig ipos it = case it ^? _Just . itTweaks . tweakSel of
     hw = halfWidth  cfig
     sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
 
+
 combineListStrings :: World -> [String]
-combineListStrings = map (show . snd) . combineList . fmap _itCombineType . yourInv
+combineListStrings = map (show . snd) . combineListYou
+
+combineListLnks :: World -> [(Int,[Int])]
+combineListLnks = zip [0..] . map fst . combineListYou
 
 ammoTweakStrings :: Maybe Item -> [String]
 ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
@@ -107,12 +141,8 @@ invHead cfig s = winScale cfig
 displayInv :: Int -> Configuration -> World -> Picture
 displayInv n cfig w = listTextPicturesAt 0 0 cfig invlist
     <> equipcursor
-    <> selcursor
     <> closeobjectcursor
   where
-    selcursor 
-        | IM.null inv && null (_closeObjects w) = mempty
-        | otherwise   = listCursorAt 0 0 cfig curpos white curx cury
     closeobjectcursor = case selectedCloseObject w of
         Nothing -> mempty
         Just (i,_) -> listCursorAt 50 0 cfig (selNumPos i w) blue 15 (invSelSize i w)
@@ -124,9 +154,9 @@ displayInv n cfig w = listTextPicturesAt 0 0 cfig invlist
         0 -> [color invDimColor . text $ "  INVENTORY FULL"]
         1 -> [color invDimColor . text $ "  +1 FREE SLOT"]
         x -> [color invDimColor . text $ "  +" ++ show x ++ " FREE SLOTS"]
-    curpos = invSelPos w
+    --curpos = invSelPos w
-    curx   = 10
+    --curx   = 10
-    cury   = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
+    --cury   = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
     equipcursor = case _crLeftInvSel cr of
         Nothing -> mempty
         Just invid -> openCursorAt 20 yellow 0 0 (selNumPos invid w) cfig

src/Dodge/Render/List.hs

@@ -35,14 +35,14 @@ listCursorAt xoff yoff cfig yint col cursxsize cursysize = winScale cfig
 
 listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture
 listTextPictureAt xoff yoff cfig yint = winScale cfig
-    . translate (xoff + 15 - hw) (yoff + hh - (20 * (fromIntegral yint+1)))
+    . translate (xoff + 15 - hw) (negate yoff + hh - (20 * (fromIntegral yint+1)))
     . scale 0.1 0.1
   where
     hw = halfWidth  cfig
     hh = halfHeight cfig
 
 renderListAt :: Float -> Float -> Configuration -> [(String,Color)] -> Picture
-renderListAt tx ty cfig = listTextPicturesAt tx ty cfig . map (\(str,col) -> color col $ text str)
+renderListAt tx ty cfig = listTextPicturesAt tx (negate ty) cfig . map (\(str,col) -> color col $ text str)
 --    concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig) [0..]
 
 --TODO put the following functions in an appropriate place

src/ListHelp.hs

@@ -3,6 +3,7 @@ module ListHelp
     ,initOrNull
     , insertOver
     , swapIndices
+    , (!?)
     )where
 import Data.List
 
@@ -15,3 +16,18 @@ insertOver i x xs = take i xs ++ x : drop (i+1) xs
 
 swapIndices :: Int -> Int -> [a] -> [a]
 swapIndices i j xs = insertOver i (xs !! j) . insertOver j (xs !! i) $ xs
+
+--copied from Data.List.Extra:
+-- | A total variant of the list index function `(!!)`.
+--
+-- > [2,3,4] !? 1    == Just 3
+-- > [2,3,4] !? (-1) == Nothing
+-- > []      !? 0    == Nothing
+(!?) :: [a] -> Int -> Maybe a
+xs !? n
+  | n < 0     = Nothing
+             -- Definition adapted from GHC.List
+  | otherwise = foldr (\x r k -> case k of
+                                   0 -> Just x
+                                   _ -> r (k-1)) (const Nothing) xs n
+{-# INLINABLE (!?) #-}