Add files, move towards joining items in inventory

src/Dodge/Combine.hs

@@ -4,64 +4,67 @@ module Dodge.Combine (
     combineList',
 ) where
 
-import Dodge.Item.SlotsTaken
-import Dodge.Data.Universe
-import Dodge.Data.Combine
-import Dodge.Item.Display
-import Dodge.Item.InventoryColor
 import Color
 --import Dodge.Data.SelectionList
-import qualified Data.IntSet as IS
+
 import Control.Lens
 import Control.Monad
 import Data.Bifunctor
+import qualified Data.IntSet as IS
 import Data.List (sortOn)
 import Data.Map.Merge.Strict
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import Dodge.Base.You
 import Dodge.Combine.Trie
+import Dodge.Data.Combine
+import Dodge.Data.Universe
+import Dodge.Item.Display
+import Dodge.Item.InventoryColor
+import Dodge.Item.SlotsTaken
 --import Dodge.Data.World
-import Dodge.Item.Amount
+--import Dodge.Item.Amount
 import Dodge.Module
 import qualified IntMapHelp as IM
 import SimpleTrie
 
-invertInventory :: IM.IntMap Item -> [(ItemBaseType, ItAmount, Int)]
-invertInventory =
-    IM.foldrWithKey
-        (\k it -> ((_iyBase $ _itType it, itStackAmount it, k) :))
-        []
+--invertInventory :: IM.IntMap Item -> [(ItemBaseType, ItAmount, Int)]
+--invertInventory =
+--    IM.foldrWithKey
+--        (\k it -> ((_iyBase $ _itType it, itStackAmount it, k) :))
+--        []
 
 invertInventoryToMap :: IM.IntMap Item -> M.Map ItemBaseType [Int]
 invertInventoryToMap =
     IM.foldrWithKey
-        (\k it -> (M.insertWith (++) (_iyBase $ _itType it) (replicate (fromIntegral $ itStackAmount it) k)))
+        (\k it -> (M.insertWith (++) (_iyBase $ _itType it) [k]))
         mempty
 
-splitItAmounts :: [(ItemBaseType, ItAmount, Int)] -> [((ItAmount, ItemBaseType), (ItAmount, Int))]
-splitItAmounts = concatMap f
-  where
-    f (x, n, y) = [((i, x), (i, y)) | i <- [1 .. n]]
+--splitItAmounts :: [(ItemBaseType, ItAmount, Int)] -> [((ItAmount, ItemBaseType), (ItAmount, Int))]
+--splitItAmounts = concatMap f
+--  where
+--    f (x, n, y) = [((i, x), (i, y)) | i <- [1 .. n]]
 
 groupSplitItemAmounts :: M.Map ItemBaseType [Int] -> [((ItAmount, ItemBaseType), [Int])]
 groupSplitItemAmounts = M.foldrWithKey f []
   where
-    f ibt is = (++) [((fromIntegral i, ibt), take i is) | i <- [1..length is]]
+    f ibt is = (++) [((fromIntegral i, ibt), take i is) | i <- [1 .. length is]]
 
-flatSplitItAmounts :: [(ItemBaseType, ItAmount, Int)] -> [((ItAmount, ItemBaseType), [Int])]
-flatSplitItAmounts = concatMap f
-  where
-    f (x, n, y) = [((i, x), replicate (fromIntegral i) y) | i <- [1 .. n]]
+--flatSplitItAmounts :: [(ItemBaseType, ItAmount, Int)] -> [((ItAmount, ItemBaseType), [Int])]
+--flatSplitItAmounts = concatMap f
+--  where
+--    f (x, n, y) = [((i, x), replicate (fromIntegral i) y) | i <- [1 .. n]]
 
-lookupItems :: IM.IntMap Item -> [([(ItAmount, Int)], Item)]
-lookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . splitItAmounts . invertInventory
+--lookupItems :: IM.IntMap Item -> [([(ItAmount, Int)], Item)]
+--lookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . splitItAmounts . invertInventory
+
+flatLookupItems :: IM.IntMap Item -> [([[Int]], Item)]
+flatLookupItems =
+    flip multiLookupTrieI combinationsTrie . sortOn fst . groupSplitItemAmounts
+        . invertInventoryToMap
 
-flatLookupItems :: IM.IntMap Item -> [([[Int]],Item)]
-flatLookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . groupSplitItemAmounts
-    . invertInventoryToMap
 --flatLookupItems :: IM.IntMap Item -> [([[Int]],Item)]
---flatLookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . flatSplitItAmounts 
+--flatLookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . flatSplitItAmounts
 --    . invertInventory
 
 combineItemListYouX :: World -> [([Int], Item)]
@@ -80,21 +83,22 @@ combineList w = case combineList' w of
 combineList' :: World -> [SelectionItem CombinableItem]
 combineList' = map f . combineListInfo
   where
-    f (is,(strs,itm)) = SelectionItem
-        { _siPictures = basicItemDisplay itm 
-        , _siHeight = itSlotsTaken itm
-        , _siIsSelectable = True
-        , _siColor = itemInvColor itm
-        , _siOffX = 0
-        , _siOffY = 0
-        , _siPayload = CombinableItem is itm strs
-        }
+    f (is, (strs, itm)) =
+        SelectionItem
+            { _siPictures = basicItemDisplay itm
+            , _siHeight = itSlotsTaken itm
+            , _siIsSelectable = True
+            , _siColor = itemInvColor itm
+            , _siOffX = 0
+            , _siOffY = 0
+            , _siPayload = CombinableItem is itm strs
+            }
 
 combineListInfo :: World -> [([Int], ([String], Item))]
 combineListInfo w = filter f . map (cmm inv) $ combineItemListYouX w
   where
     inv = yourInv w
-    f (is,(_,itm)) = _itType itm `notElem` fmap _itType (IM.restrictKeys inv (IS.fromList is))
+    f (is, (_, itm)) = _itType itm `notElem` fmap _itType (IM.restrictKeys inv (IS.fromList is))
 
 cmm :: IM.IntMap Item -> ([Int], Item) -> ([Int], ([String], Item))
 cmm inv (is, itm) = (is, itm & itType . iyModules %%~ flip combineModuleMaps mms)

src/Dodge/Combine/Combinations.hs

@@ -6,7 +6,7 @@ module Dodge.Combine.Combinations
     , bulletWeapons
     ) where
 
-import Data.Bifunctor
+--import Data.Bifunctor
 import Dodge.Item.Ammo
 import Dodge.Data.Item
 import Dodge.Item

src/Dodge/Data/ComposedItem.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Dodge.Data.ComposedItem
+  where
+import Control.Lens
+import Data.Aeson
+import Data.Aeson.TH
+
+
+data ComposedItem = WeaponCI
+    | BulletAmmoCI
+    | UncomposableCI
+    deriving (Eq,Ord,Show,Read)
+
+makeLenses ''ComposedItem
+deriveJSON defaultOptions ''ComposedItem

src/Dodge/Data/DoubleTree.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Dodge.Data.DoubleTree
+  where
+
+import Control.Lens
+import Data.Aeson
+import Data.Aeson.TH
+
+
+data DoubleTree a = DT {_dtValue :: a,_dtLeft :: [DoubleTree a],_dtRight :: [DoubleTree a]}
+    deriving (Eq,Ord,Show,Read)
+
+makeLenses ''DoubleTree
+deriveJSON defaultOptions ''DoubleTree

src/Dodge/Default/Weapon.hs

@@ -1,71 +0,0 @@
-module Dodge.Default.Weapon where
-
---import Control.Lens
---import qualified Data.Map.Strict as M
---import Dodge.Data.Hammer
---import Dodge.Data.Item
---import Dodge.Default.Item
---import Dodge.Item.Weapon.Bullet
---import Dodge.Reloading.Action
---import Picture
-
---
---defaultLoadable :: HeldConsumption
---defaultLoadable =
---    LoadableAmmo
---        { _laAmmoType = GenericAmmo
---        , _laMax = 15
---        , _laLoaded = 0
---        , _laPrimed = True
---        , _laCycle = [loadEject 10, loadInsert 10, loadPrime 10]
---        , _laProgress = Nothing
---        }
---
-----defaultBulletLoadable :: HeldConsumption
-----defaultBulletLoadable = defaultLoadable & laAmmoType .~ basicBullet
---
---defaultChargeable :: LeftConsumption
---defaultChargeable = ChargeableAmmo 100 100
-
-
---
---
---luseInstantNoH :: Luse -> ItemUse
---luseInstantNoH f =
---    defaultlUse
---        & lUse .~ f
---        & useDelay .~ NoDelay
-
----- TODO change this
---defaultLeftItem :: Item
---defaultLeftItem =
---    defaultWeapon
---        & itUse .~ defaultlUse
-
---
---
---defaultItemValue :: ItemValue
---defaultItemValue = ItemValue 10 MundaneItem
---
---defaultCraftable :: Item
---defaultCraftable =
---    defaultItem
---        { _itInvColor = green
---        }
---
---defBulletShooter :: ItemParams
---defBulletShooter =
---    BulletShooter
---        { _muzVel = 1
---        , _rifling = 0.8
---        , _bore = 2
---        , _gunBarrels = SingleBarrel 0
---        , _recoil = 0
---        , _torqueAfter = 0
---        , _randomOffset = 0
---        }
---
-----defaultAutoGun :: Item
-----defaultAutoGun =
-----    defaultBulletWeapon
-----        & itUse . useAim . aimStance .~ TwoHandTwist

src/Dodge/Item/Amount.hs

@@ -1,8 +0,0 @@
-module Dodge.Item.Amount where
-
-import Control.Lens
-import Data.Maybe
-import Dodge.Data.Item
-
-itStackAmount :: Item -> ItAmount
-itStackAmount it = 1 -- fromMaybe 1 $ it ^? itUse . useAmount

src/Dodge/Item/Grammar.hs

@@ -0,0 +1,52 @@
+module Dodge.Item.Grammar
+    where
+import Data.Maybe
+import ListHelp
+import Dodge.Data.Item
+import Dodge.Data.DoubleTree
+import Dodge.Data.ComposedItem
+import TreeHelp
+
+type PCI = (ComposedItem, [ComposedItem])
+
+baseComposedItem :: ItemBaseType -> PCI
+baseComposedItem ibt = case ibt of
+    HELD BURSTRIFLE -> (WeaponCI, [BulletAmmoCI])
+    AMMOMAG TINMAG -> (BulletAmmoCI, [])
+    _ -> (UncomposableCI, [])
+
+joinItems :: DoubleTree PCI -> DoubleTree PCI -> Maybe (DoubleTree PCI)
+joinItems t@(DT (px,cx) ls' rs') s@(DT (py,_) _ _)
+    | py `elem` cx = Just (DT (px, delete py cx) ls' (rs' ++ [s]))
+    | otherwise = checkdepth t s
+  where
+    checkdepth a a'@(DT b ls rs) = fromMaybe (checktop a a') $ do
+        c <- safeHead ls
+        d <- checkdepth a c
+        return $ Just $ DT b (d:ls) rs
+    checktop a@(DT (pa,_) _ _) (DT (pb,cb) ls rs)
+        | pa `elem` cb = Just (DT (pb, delete pa cb) (a:ls) rs)
+        | otherwise = Nothing
+
+joinItems' :: Tree PCI -> Tree PCI -> Maybe (Tree PCI)
+joinItems' t@(Node (px,cx) xs) s@(Node (py,_) _)
+--    | fst y `elem` cx = Just (Node (px, delete y cx) (xs ++ [s]))
+    | py `elem` cx = Just (Node (px, delete py cx) (xs ++ [s]))
+    | otherwise = checkdepth t s
+  where
+    checkdepth a a'@(Node b cs) = fromMaybe (checktop a a') $ do
+        c <- safeHead cs
+        d <- checkdepth a c
+        return $ Just $ Node b (d:cs)
+    checktop a@(Node (pa,_) _) (Node (pb,cb) bs)
+        | pa `elem` cb = Just (Node (pb, delete pa cb) (a:bs))
+        | otherwise = Nothing
+
+joinItemsInList :: (a -> a -> Maybe a) -> [a] -> [a]
+joinItemsInList f xs = snd $ h (xs,[])
+  where
+    h ([],zs) = ([],zs)
+    h ((y:ys), []) = h (ys, [y])
+    h ((y:ys),(z:zs)) = case f y z of
+        Nothing -> h (ys, (y:z:zs))
+        Just w -> h ((w:ys),zs)

src/Dodge/Item/SlotsTaken.hs

@@ -2,7 +2,7 @@ module Dodge.Item.SlotsTaken (
     itSlotsTaken,
 ) where
 
-import Control.Lens
+--import Control.Lens
 import Dodge.Data.Item
 import Dodge.Module
 

src/Dodge/Projectile/Update.hs

@@ -7,7 +7,6 @@ import qualified Data.Map.Strict as M
 import Data.Maybe
 import Dodge.Base
 import Dodge.Data.World
-import Dodge.Default.Weapon
 import Dodge.EnergyBall
 import Dodge.Item.Location
 import Dodge.Item.Weapon.Launcher

src/Dodge/Render/HUD.hs

@@ -33,7 +33,7 @@ import Dodge.Tweak.Show
 import Geometry
 import qualified IntMapHelp as IM
 import Justify
-import ListHelp
+--import ListHelp
 import Padding
 import Picture
 import SDL (MouseButton (..))
@@ -198,7 +198,7 @@ combineInventoryExtra sss cfig w = fromMaybe mempty $ do
                 return $
                     lnkMidPosInvSelsCol cfig w j col lnks
                         <> foldMap invcursor lnks
-                        <> combineCounts cfig w lnks
+--                        <> combineCounts cfig w lnks
             ]
   where
     invcursor i = fromMaybe mempty $ do
@@ -233,23 +233,23 @@ displayTerminal tid cfig w = fromMaybe mempty $ do
         | hasfoc = clockCycle 10 (V.fromList ["_", "."]) w
         | otherwise = []
 
-combineCounts :: Configuration -> World -> [Int] -> Picture
-combineCounts cfig w = foldMap f . group
-  where
---    f (i : is) = fromMaybe mempty $ do
---        _ <- yourInv w ^? ix i . itUse . useAmount
---        sss <- w ^? hud . hudElement . diSections
---        --p <- selNumTextEndPos cfig (invDisplayParams w) sss 0 i
---        col <- selSecSelCol 0 i sss
---        yint <- selSecYint 0 i sss
---        --return $ color col $ uncurryV translate p . scale 0.1 0.1 . text $ ('-' : show (length is + 1))
---        return
---            . translateScreenPos cfig (invDisplayParams w ^. ldpPos)
---            . color col
---            . drawListElement 0 1 15 yint
---            . text
---            $ ('-' : show (length is + 1))
-    f _ = mempty
+--combineCounts :: Configuration -> World -> [Int] -> Picture
+--combineCounts cfig w = foldMap f . group
+--  where
+----    f (i : is) = fromMaybe mempty $ do
+----        _ <- yourInv w ^? ix i . itUse . useAmount
+----        sss <- w ^? hud . hudElement . diSections
+----        --p <- selNumTextEndPos cfig (invDisplayParams w) sss 0 i
+----        col <- selSecSelCol 0 i sss
+----        yint <- selSecYint 0 i sss
+----        --return $ color col $ uncurryV translate p . scale 0.1 0.1 . text $ ('-' : show (length is + 1))
+----        return
+----            . translateScreenPos cfig (invDisplayParams w ^. ldpPos)
+----            . color col
+----            . drawListElement 0 1 15 yint
+----            . text
+----            $ ('-' : show (length is + 1))
+--    f _ = mempty
 
 lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
 lnkMidPosInvSelsCol cfig w i col = foldMap f