Improve combinations algorithm speed

src/Dodge/Combine.hs

@@ -1,4 +1,4 @@
---{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections #-}
 module Dodge.Combine 
     ( combinePoss
     , combineSizes
@@ -18,20 +18,36 @@ import Control.Lens
 import Data.Bifunctor
 import qualified Data.IntMap.Strict as IM
 --import qualified Data.IntSet as IS
---import qualified Data.Map.Strict as M
+import qualified Data.Map.Strict as M
 import Data.Maybe
-import Data.List (sort,scanl')
+import Data.List (sort,scanl',sortOn)
 
-combinationsTrie :: Trie CombineType Item
+combinationsTrie :: Trie (Int,CombineType) Item
 combinationsTrie = foldr (uncurry insertInTrie) emptyTrie
-    $ map (first sort) itemCombinations
+    $ map (first (sortOn snd)) itemCombinations
 
-lookupTypeTrie :: [CombineType] -> Maybe Item
+lookupTypeTrie :: [(CombineType,Int,Int)] -> Maybe ([Int],Item)
-lookupTypeTrie = flip lookupTrie combinationsTrie . sort
+lookupTypeTrie = undefined
+
+lookupItems' :: [(CombineType,Int,Int)] -> [ ([Int],Item) ]
+lookupItems' xs = lookupItems (sortOn (\(ct,_,_) -> ct) xs) combinationsTrie
+
+lookupItems :: [(CombineType,Int,Int)] -> Trie (Int,CombineType) Item -> [ ([Int],Item) ]
+lookupItems [] t = maybeToList $ fmap ([],) $ _trieMVal t
+lookupItems ((ct,i,n):xs) t = do
+    n' <- [1..min n 4]
+    let is = replicate n' i
+    concatMap (map (first (is ++)) . lookupItems xs) $ maybeToList (_trieChildren t M.!? (n',ct))
+
+--lookupTypeTrie' :: [CombineType] -> Maybe Item
+--lookupTypeTrie' = flip lookupTrie combinationsTrie . sort
 
 combineItemList :: IM.IntMap Item -> [([Int],Item)]
-combineItemList = mapMaybe (pushOutMaybe . second lookupTypeTrie)
+combineItemList = undefined
-    . listCombos
+
+--combineItemList :: IM.IntMap Item -> [([Int],Item)]
+--combineItemList = mapMaybe (pushOutMaybe . second lookupTypeTrie)
+--    . listCombos
 
 pushOutMaybe :: (a,Maybe b) -> Maybe (a,b)
 pushOutMaybe (_,Nothing) = Nothing
@@ -54,8 +70,10 @@ invertListInv = IM.foldrWithKey
     (\k it -> ((_itType it, k, itStackAmount it) :) )
     []
 
+combineItemListYou' :: World -> [([Int],Item)]
+combineItemListYou' = combineItemList . yourInv
 combineItemListYou :: World -> [([Int],Item)]
-combineItemListYou = combineItemList . yourInv
+combineItemListYou = concatMap lookupItems' . invertListInvMult . yourInv
 
 toggleCombineInv :: World -> World
 toggleCombineInv w = case _inventoryMode w of

src/Dodge/Combine/Combinations.hs

@@ -1,40 +1,43 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Combine.Combinations where
 import Dodge.Data
 import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Weapon.Launcher
-itemCombinations :: [([CombineType],Item)]
+itemCombinations :: [([(Int,CombineType)],Item)]
 itemCombinations =
-    [ p [PIPE,HARDWARE] (bangStick 1)
+    [ po [PIPE, HARDWARE]             (bangStick 1)
-    , p [BANGSTICK 1,TIN] pistol
+    , po [BANGSTICK 1, TIN]         pistol
-    , p [PISTOL, SPRING, HARDWARE] autoPistol
+    , po [PISTOL, SPRING, HARDWARE] autoPistol
-    , p [AUTOPISTOL, PLANK, HARDWARE] smg
+    , po [AUTOPISTOL, PLANK, HARDWARE] smg
-    , p [AUTOPISTOL, HARDWARE] machinePistol
+    , po [AUTOPISTOL, HARDWARE] machinePistol
-    , p [BANGSTICK 1,CAN] revolver
+    , po [BANGSTICK 1,CAN] revolver
-    , p [REVOLVER, SPRING, HARDWARE] $ revolverX 1
+    , po [REVOLVER, SPRING, HARDWARE] $ revolverX 1
 
-    , p [PIPE,TUBE,HARDWARE] bangCone
+    , po [PIPE,TUBE,HARDWARE] bangCone
-    , p [BANGCONE,PLANK] blunderbuss
+    , po [BANGCONE,PLANK] blunderbuss
-    , p [BLUNDERBUSS,TUBE] grapeShotCannon
+    , po [BLUNDERBUSS,TUBE] grapeShotCannon
-    , p [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1
+    , po [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1
-    , p [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2
+    , po [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2
 
-    , p [PIPE,PIPE,HARDWARE] bangCane
+    , p [p 2 PIPE,o HARDWARE] bangCane
-    , p [BANGCANE,PIPE,PIPE] (bangCaneX 2)
+    , p [p 2 PIPE,o BANGCANE] (bangCaneX 2)
-    , p [BANGCANE,TIN] rifle
+    , po [BANGCANE,TIN] rifle
-    , p [RIFLE,SPRING,HARDWARE] autoRifle
+    , po [RIFLE,SPRING,HARDWARE] autoRifle
-    , p [RIFLE,SPRING,CAN] assaultRifle
+    , po [RIFLE,SPRING,CAN] assaultRifle
-    , p [BANGCANE,BANGCANE] miniGun
+    , po [BANGCANE,BANGCANE] miniGun
 
-    , p [PIPE,PIPE,PIPE,HARDWARE] bangRod
+    , p [p 3 PIPE,o HARDWARE] bangRod
-    , p [BANGROD,PLANK,HARDWARE]  elephantGun
+    , po [BANGROD,PLANK,HARDWARE]  elephantGun
-    , p [ELEPHANTGUN,HARDWARE,TIN] amr
+    , po [ELEPHANTGUN,HARDWARE,TIN] amr
-    , p [ELEPHANTGUN,HARDWARE,CAN] sniperRifle
+    , po [ELEPHANTGUN,HARDWARE,CAN] sniperRifle
-    , p [BANGROD,PLATE,DRUM,MOTOR] machineGun
+    , po [BANGROD,PLATE,DRUM,MOTOR] machineGun
 
-    , p [TUBE,TUBE,TUBE,HARDWARE] launcher
+    , p [p 3 TUBE,o HARDWARE] launcher
     ] 
-    ++ map (\i -> ([PIPE,BANGSTICK i],bangStick (i+1))) [1..8]
+    ++ map (\i -> po [PIPE,BANGSTICK i] $ bangStick (i+1)) [1..8]
-    ++ map (\i -> ([REVOLVERX i,CAN] ,revolverX (i+1))) [1..5]
+    ++ map (\i -> po [REVOLVERX i,CAN]  $ revolverX (i+1)) [1..5]
-    ++ map (\i -> ([BANGCANEX i,PIPE,PIPE] ,bangCaneX (i+1))) [1..5]
+    ++ map (\i -> p [o (BANGCANEX i),p 2 PIPE] $ bangCaneX (i+1)) [1..5]
   where
     p = (,)
+    po xs it = (map o xs,it)
+    o = (1,)