Improve item combination algorithm

src/Dodge/Combine.hs

@@ -27,33 +27,52 @@ import Data.Map.Merge.Strict
 import Data.Maybe
 import Data.List (scanl',sortOn,sort)
 
-combinationsTrie :: Trie (Int,ItemBaseType) Item
+combinationsTrie :: Trie (IcAmount,ItemBaseType) Item
 combinationsTrie = foldr 
-    (uncurry insertInTrie . first (sortOn snd)) 
+    (uncurry insertInTrie . first sort) 
     emptyTrie
     itemCombinations
 
+invertInventory :: IM.IntMap Item -> [(ItemBaseType,IcAmount,Int)]
+invertInventory = IM.foldrWithKey
+    (\k it -> ((_iyBase $ _itType it, itStackAmount it,k) :) )
+    []
+splitIcAmounts :: [(ItemBaseType,IcAmount,Int)] -> [((IcAmount,ItemBaseType),(IcAmount,Int))]
+splitIcAmounts = concatMap f
+  where
+    f (x,n,y) = [((i,x),(i,y)) | i <- [1..n]]
+
+lookupItems' :: IM.IntMap Item -> [([(IcAmount,Int)],Item)]
+lookupItems' = flip multiLookupTrieI combinationsTrie . sortOn fst . splitIcAmounts . invertInventory
+
+combineItemListYou :: World -> [([Int],Item)]
+combineItemListYou = map (first f) . lookupItems' . yourInv
+  where
+    f = concatMap g
+    g (amount,i) = replicate (_toInt amount) i
+    
+
 -- this can probably be improved by going through accessing the combinations
 -- trie going through each combine type in your inventory in order, rather than
 -- creating all multisets of combine types.
 
-lookupItems :: [(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,Int)] 
+lookupItems :: [(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,IcAmount)] 
     -> [ ([(M.Map ModuleSlot ItemModuleType,Int)],Item) ]
 lookupItems xs = lookupItemsUsingTrie (sortOn (\(_,ct,_,_) -> ct) xs) combinationsTrie
 
-lookupItemsUsingTrie :: [(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,Int)] 
+lookupItemsUsingTrie :: [(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,IcAmount)] 
-    -> Trie (Int,ItemBaseType) Item 
+    -> Trie (IcAmount,ItemBaseType) Item 
     -> [ ([(M.Map ModuleSlot ItemModuleType,Int)],Item) ]
 lookupItemsUsingTrie [] t = maybeToList $ ([],) <$> _trieMVal t
 lookupItemsUsingTrie ((mods,ct,i,n):xs) t = do
     n' <- [1..min n 4]
-    let is = replicate n' (mods,i)
+    let is = replicate (_toInt n') (mods,i)
     concatMap (map (first (is ++)) . lookupItemsUsingTrie xs) $ maybeToList (_trieChildren t M.!? (n',ct))
 
-invertListInvMult :: IM.IntMap Item -> [[(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,Int)]]
+invertListInvMult :: IM.IntMap Item -> [[(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,IcAmount)]]
 invertListInvMult = powlistUpToN 4 . invertListInv
 
-invertListInv :: IM.IntMap Item -> [(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,Int)]
+invertListInv :: IM.IntMap Item -> [(M.Map ModuleSlot ItemModuleType,ItemBaseType,Int,IcAmount)]
 invertListInv = IM.foldrWithKey
     (\k it -> ((_iyModules $ _itType it,_iyBase $ _itType it, k, itStackAmount it) :) )
     []
@@ -61,8 +80,8 @@ invertListInv = IM.foldrWithKey
 -- gives a list of indices-item pairs.
 -- Note that within the pair, indices can be repeated if two or more of an item
 -- are needed
-combineItemListYou :: World -> [([Int],Item)]
+combineItemListYou'' :: World -> [([Int],Item)]
-combineItemListYou = map (second fst) . combineItemListYou'
+combineItemListYou'' = map (second fst) . combineItemListYou'
 
 combineItemListYou' :: World -> [([Int],(Item,[String]))]
 combineItemListYou' = map addModules . concatMap lookupItems . invertListInvMult . yourInv

src/Dodge/Combine/Combinations.hs

@@ -14,7 +14,7 @@ import LensHelp
 
 --import Data.Maybe
 
-itemCombinations :: [([(Int,ItemBaseType)],Item)]
+itemCombinations :: [([(IcAmount,ItemBaseType)],Item)]
 itemCombinations =
     [ po [PIPE, HARDWARE]             (bangStick 1)
     , po [BANGSTICK 1, TIN]         pistol

src/Dodge/Creature.hs

@@ -213,6 +213,23 @@ inventoryX c = case c of
         , makeTypeCraftNum 1 DRUM
         , makeTypeCraftNum 1 MOTOR
         ]
+    'F' ->
+        [ makeTypeCraftNum 5 PIPE
+        , makeTypeCraftNum 5 TUBE
+        , makeTypeCraftNum 5 HARDWARE
+        , makeTypeCraftNum 5 TIN
+        , makeTypeCraftNum 5 CAN
+        , makeTypeCraftNum 5 SPRING
+        , makeTypeCraftNum 5 PUMP
+        , makeTypeCraftNum 5 MAGNET
+        , makeTypeCraftNum 5 PLANK
+        , makeTypeCraftNum 5 PLATE
+        , makeTypeCraftNum 5 DRUM
+        , makeTypeCraftNum 5 MOTOR
+        , makeTypeCraftNum 5 TRANSFORMER
+        , makeTypeCraftNum 5 PRISM
+        , makeTypeCraftNum 5 LIGHTER
+        ]
     _ -> []
 
 testInventory :: IM.IntMap Item

src/Dodge/Data.hs

@@ -22,7 +22,9 @@ module Dodge.Data
     , module Dodge.Config.Data
     , module Dodge.Equipment.Data
     , module MaybeHelp
+    , module Dodge.Data.ItemAmount
     ) where
+import Dodge.Data.ItemAmount
 import Dodge.ShortShow
 import Dodge.Creature.State.Data
 import Dodge.Creature.Stance.Data
@@ -469,6 +471,8 @@ data Equipment = Equipment
 
 _itUseAimStance :: Item -> AimStance
 _itUseAimStance = _aimStance . _useAim . _itUse
+
+
 data ItemConsumption
     = LoadableAmmo
         { _laType  :: AmmoType
@@ -483,7 +487,7 @@ data ItemConsumption
         , _wpCharge     :: Int
         }
     | ItemItselfConsumable
-        { _itAmount   :: Int
+        { _icAmount   :: IcAmount
         }
     | NoConsumption
 data Item = Item

src/Dodge/Data/ItemAmount.hs

@@ -0,0 +1,7 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Dodge.Data.ItemAmount where
+
+newtype IcAmount = IcAmount {_toInt :: Int}
+  deriving (Eq,Ord,Num,Integral,Real,Enum)
+instance Show IcAmount where
+    show (IcAmount i) = 'x':show i

src/Dodge/Default.hs

@@ -167,7 +167,7 @@ defaultItZoom :: ItZoom
 defaultItZoom = ItZoom 20 0.2 1
 defaultConsumable :: Item
 defaultConsumable = defaultItem
-    { _itConsumption = ItemItselfConsumable  {_itAmount = 1}
+    { _itConsumption = ItemItselfConsumable  {_icAmount = 1}
     , _itInvColor = blue
     , _itDimension = defItDimCol blue
     }

src/Dodge/Default/Item.hs

@@ -53,7 +53,7 @@ basicItemDisplay it = Prelude.take (itSlotsTaken it) $
             Nothing' -> show (_laLoaded am)
             Just' x  -> show x ++ "R" ++ show (_laLoaded am)
         Just am@ChargeableAmmo{} -> show $ _wpCharge am
-        Just x@ItemItselfConsumable{} -> "x" ++ show (_itAmount x)
+        Just x@ItemItselfConsumable{} -> show (_icAmount x)
         Just NoConsumption -> ""
         Nothing -> ""
     theparam = fromMaybe []

src/Dodge/FloorItem.hs

@@ -28,7 +28,7 @@ copyItemToFloorID pos it w = (,) flid $ w'
         _ -> id
     flid = IM.newKey $ _floorItems w
     theflit = FlIt 
-        {_flIt = it & itConsumption . itAmount %~ const 1
+        {_flIt = it & itConsumption . icAmount %~ const 1
         ,_flItPos = p'
         ,_flItRot = rot
         ,_flItID = flid

src/Dodge/Inventory.hs

@@ -52,8 +52,8 @@ rmInvItem :: Int      -- ^ Creature id
     -> Int      -- ^ Inventory position
     -> World 
     -> World
-rmInvItem cid invid w = case w ^? creatures . ix cid . crInv . ix invid . itConsumption . itAmount of
+rmInvItem cid invid w = case w ^? creatures . ix cid . crInv . ix invid . itConsumption . icAmount of
-    Just x | x > 1 -> w & creatures . ix cid . crInv . ix invid . itConsumption . itAmount %~ subtract 1
+    Just x | x > 1 -> w & creatures . ix cid . crInv . ix invid . itConsumption . icAmount %~ subtract 1
     _ -> w & creatures . ix cid . crInv %~ f
         & creatures . ix cid . crInvSel %~ g
         & creatures . ix cid . crLeftInvSel %~ g'

src/Dodge/Inventory/Add.hs

@@ -11,7 +11,7 @@ putItemInInvID cid flid w = fromMaybe w
     $ tryPutItemInInv cid (_floorItems w IM.! flid) w
 
 putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item
-putItemInInvSlot = IM.insertWith (const $ itConsumption . itAmount +~ 1)
+putItemInInvSlot = IM.insertWith (const $ itConsumption . icAmount +~ 1)
 
 {- | Pick up a specific item. -}
 tryPutItemInInv :: Int -> FloorItem -> World -> Maybe World

src/Dodge/Inventory/ItemSpace.hs

@@ -8,6 +8,6 @@ import Control.Lens
 --import Data.Maybe
 
 itSlotsTaken :: Item -> Int
-itSlotsTaken it = case it ^? itConsumption . itAmount of
+itSlotsTaken it = case it ^? itConsumption . icAmount of
     Nothing -> moduleSizes it + ceiling (_itInvSize it)
     Just i  -> moduleSizes it + ceiling (_itInvSize it * fromIntegral i)

src/Dodge/Item/Amount.hs

@@ -3,5 +3,5 @@ import Dodge.Data
 import Data.Maybe
 import Control.Lens
 
-itStackAmount :: Item -> Int
+itStackAmount :: Item -> IcAmount
-itStackAmount it = fromMaybe 1 $ it ^? itConsumption . itAmount
+itStackAmount it = fromMaybe 1 $ it ^? itConsumption . icAmount

src/Dodge/Item/Craftable.hs

@@ -13,7 +13,7 @@ makeTypeCraftNum :: Int -> ItemBaseType -> Item
 makeTypeCraftNum i ct = defaultCraftable
     { _itInvSize = 0.5
     , _itCurseStatus = Uncursed
-    , _itConsumption = ItemItselfConsumable i
+    , _itConsumption = ItemItselfConsumable $ IcAmount i
     }
     & itType . iyBase .~ ct
 

src/SimpleTrie.hs

@@ -32,3 +32,11 @@ multiLookupTrie  xs t@(Trie my ch)
         case M.lookup z ch of
             Nothing -> multiLookupTrie zs t
             Just t' -> map (_1 %~ (z:)) (multiLookupTrie zs t') ++ multiLookupTrie zs t
+
+multiLookupTrieI :: Ord a => [(a,c)] -> Trie a b -> [([c],b)]
+multiLookupTrieI  xs t@(Trie my ch)
+    | null xs || null ch = maybe [] (\y -> [([],y)]) my
+    | otherwise = let ((z1,z2):zs) = xs in
+        case M.lookup z1 ch of
+            Nothing -> multiLookupTrieI zs t
+            Just t' -> map (_1 %~ (z2:)) (multiLookupTrieI zs t') ++ multiLookupTrieI zs t