Fix combination bug

src/Dodge/Combine.hs

@@ -2,11 +2,13 @@
 module Dodge.Combine where
 import Dodge.Base.You
 import Dodge.Data
+import Dodge.Item.Amount
 --import Dodge.Combine.Data
 import Multiset
 import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Weapon.Launcher
 --import Dodge.Item.Craftable
+import SimpleTrie
 
 import Control.Lens
 import Data.Bifunctor
@@ -14,10 +16,17 @@ import qualified Data.IntMap.Strict as IM
 --import qualified Data.IntSet as IS
 import qualified Data.Map.Strict as M
 import Data.Maybe
-import Data.List (scanl')
+import Data.List (sort,scanl')
 
 itemCombinations :: [ (M.Map CombineType Int, Item) ]
-itemCombinations = map (first toMultiset) $
+itemCombinations = map (first toMultiset) itemCombinations'
+
+combinationsTrie :: Trie CombineType Item
+combinationsTrie = foldr (uncurry insertInTrie) emptyTrie
+    $ map (first sort) itemCombinations'
+
+itemCombinations' :: [([CombineType],Item)]
+itemCombinations' =
     [ p [PIPE,HARDWARE] (bangStick 1)
     , p [BANGSTICK 1,TIN] pistol
     , p [PISTOL, SPRING, HARDWARE] autoPistol
@@ -37,6 +46,7 @@ itemCombinations = map (first toMultiset) $
     , p [BANGCANE,TIN] rifle
     , p [RIFLE,SPRING,HARDWARE] autoRifle
     , p [RIFLE,SPRING,CAN] assaultRifle
+    , p [BANGCANE,BANGCANE] miniGun
 
     , p [PIPE,PIPE,PIPE,HARDWARE] bangRod
     , p [BANGROD,PLANK,HARDWARE]  elephantGun
@@ -52,28 +62,65 @@ itemCombinations = map (first toMultiset) $
   where
     p = (,)
 
-combinations :: [(M.Map CombineType Int, CombineType)]
-combinations = map (second _itType) itemCombinations
-
 combineToItem :: M.Map CombineType Int -> Maybe Item
 combineToItem m = lookup m itemCombinations
 
+expandItem :: (Int,Item) -> [(Int,CombineType)]
+expandItem (i,it) = case it ^? itConsumption . itAmount of
+    Nothing -> [(i,_itType it)]
+    Just j  -> replicate j (i,_itType it)
+
 combineItemList :: IM.IntMap Item -> [([Int],Item)]
-combineItemList m = mapMaybe (pushoutmaybe . second combineToItem)
+combineItemList m 
+    = mapMaybe (pushoutmaybe . second combineToItem)
     . concatMap itemsMultisets
     . powlistN 4
     $ IM.toList m
   where
     pushoutmaybe (_,Nothing) = Nothing
     pushoutmaybe (x,Just y)  = Just (x,y)
---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)
 
+lookupTypeTrie :: [CombineType] -> Maybe Item
+lookupTypeTrie = flip lookupTrie combinationsTrie . sort
+
+combineItemList' :: IM.IntMap Item -> [([Int],Item)]
+combineItemList'
+    = mapMaybe (pushoutmaybe . second lookupTypeTrie)
+    . listCombos
+  where
+    pushoutmaybe (_,Nothing) = Nothing
+    pushoutmaybe (x,Just y)  = Just (x,y)
+
+listCombos :: IM.IntMap Item -> [([Int], [CombineType])]
+listCombos = concatMap expandOut . invertListInvMult
+
+expandOut :: [(CombineType,Int,Int)] -> [([Int],[CombineType])]
+expandOut [] = [([],[])]
+expandOut (x:xs) = (<>) <$> f x <*> expandOut xs
+  where
+    f (ct,i,n) = map (\j -> (replicate j i,replicate j ct)) [1..n]
+
+invertListInvMult :: IM.IntMap Item -> [[(CombineType,Int,Int)]]
+invertListInvMult = powlistN 4 . invertListInv
+
+invertListInv :: IM.IntMap Item -> [(CombineType,Int,Int)]
+invertListInv = IM.foldrWithKey
+    (\k it -> ((_itType it, k, itStackAmount it) :) )
+    []
+
+invertInv :: IM.IntMap Item -> M.Map CombineType (IM.IntMap Int)
+invertInv = IM.foldrWithKey
+    (\k it -> M.insertWith IM.union (_itType it) (IM.singleton k (itStackAmount it)))
+    M.empty
+
+expandCounts :: (Int,(Int,a)) -> [[(Int,a)]]
+expandCounts (i,(j,ct)) = [ replicate k (i,ct) | k <- [1..j]]
+
+multisetsWithCounts :: IM.IntMap Item -> [[(Int,(Int,CombineType))]]
+multisetsWithCounts = powlistN 4 . IM.toList . IM.map countAndType
+  where
+    countAndType it = (fromMaybe 1 $ it ^? itConsumption . itAmount
+        , _itType it)
 
 -- multiple multisets produced by a single item stack are combined using the list monad
 itemsMultisets :: [(Int,Item)] -> [([Int],M.Map CombineType Int)]
@@ -88,18 +135,8 @@ itemMultisets (i,it) = case it ^? itConsumption . itAmount of
   where
     thetype = _itType it
 
-itemTypeAmounts :: Item -> [[CombineType]]
-itemTypeAmounts it = case it ^? itConsumption . itAmount of
-    Nothing -> [[thetype]]
-    Just i  -> map (`replicate` thetype) [1 .. i]
-  where
-    thetype = _itType it
-
 combineItemListYou :: World -> [([Int],Item)]
-combineItemListYou = combineItemList . yourInv
+combineItemListYou = combineItemList' . yourInv
-
-combineListYou :: World -> [([Int],CombineType)]
-combineListYou = fmap (second _itType) . combineItemListYou
 
 toggleCombineInv :: World -> World
 toggleCombineInv w = case _inventoryMode w of
@@ -109,10 +146,7 @@ toggleCombineInv w = case _inventoryMode w of
 enterCombineInv :: World -> World
 enterCombineInv w = w & inventoryMode .~ CombineInventory mi
   where
-    mi = 0 <$ listToMaybe (combineListYou w)
+    mi = 0 <$ listToMaybe (combineItemListYou w)
-
-combine :: M.Map CombineType Int -> Maybe CombineType
-combine m = lookup m combinations
 
 combineSizes :: World -> [Int]
 combineSizes = map (ceiling . _itInvSize . snd) . combineItemListYou

src/Dodge/Creature.hs

@@ -177,6 +177,7 @@ testInventory = IM.fromList $ zip [0..]
     , makeTypeCraftNum 3 CAN
     , makeTypeCraftNum 3 TIN
     , makeTypeCraftNum 3 PLANK
+    , makeTypeCraftNum 1 MOTOR
     ]
 stackedInventory :: IM.IntMap Item
 stackedInventory = IM.fromList $ zip [0..] 

src/Dodge/Creature/HandPos.hs

@@ -3,4 +3,4 @@ import Dodge.Data
 import Geometry
 
 crHandPos :: Creature -> Point3
-crHandPos cr = V3 0 0 20
+crHandPos _ = V3 0 0 20

src/Dodge/Default/Weapon.hs

@@ -6,7 +6,7 @@ import Dodge.Item.Draw
 import Picture
 import ShapePicture
 import Shape
-import Geometry.Vector3D
+--import Geometry.Vector3D
 import Geometry
 --import Dodge.TweakBullet
 

src/Dodge/Event.hs

@@ -144,7 +144,7 @@ wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
         & inventoryMode . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
     (_, _) -> w
   where
-    numcombs = length $ combineListYou w
+    numcombs = length $ combineItemListYou w
     yi = round $ signum y
     numLocs = (fst . IM.findMax $ _seenLocations w) + 1
     rbDown = ButtonRight `S.member` _mouseButtons w

src/Dodge/Item/Amount.hs

@@ -0,0 +1,7 @@
+module Dodge.Item.Amount where
+import Dodge.Data
+import Data.Maybe
+import Control.Lens
+
+itStackAmount :: Item -> Int
+itStackAmount it = fromMaybe 1 $ it ^? itConsumption . itAmount

src/Dodge/Item/Weapon/Bezier.hs

@@ -5,7 +5,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.Default.Weapon
 import Dodge.Item.Weapon.Targeting
-import Dodge.Item.Weapon.BulletGuns
+--import Dodge.Item.Weapon.BulletGuns
 import Dodge.Item.Weapon.TriggerType
 import Dodge.Item.Weapon.ExtraEffect
 --import Dodge.Default
@@ -15,7 +15,7 @@ import Dodge.WorldEvent.HitEffect
 import Dodge.RandomHelp
 import Dodge.SoundLogic.LoadSound
 import Geometry
-import ShapePicture
+--import ShapePicture
 
 import Data.Maybe
 import Control.Lens
@@ -46,8 +46,6 @@ bezierGun = defaultGun
         { _ammoMax = 50
         }
     }
-bezierGunSPic :: Item -> SPic
-bezierGunSPic = autoGunPic
 
 shootBezier :: Point2 -> Creature -> World -> World
 shootBezier targetp cr w = w & particles %~ (theBullet :)

src/Dodge/Item/Weapon/BulletGuns.hs

@@ -252,7 +252,8 @@ rifle = bangCane
             {_handlePos =  5
             ,_muzPos    = 25
             }
-        , _dimSPic = const $ noPic $ colorSH red $ upperPrismPoly 3 $ rectXH 25 2
+        , _dimSPic = \it -> noPic $ (colorSH red $ upperPrismPoly 3 $ rectXH 25 2)
+            <> makeClipAt (V3 10 (-2) 0) it
         }
     }
     & itUse . useAim . aimStance .~ TwoHandTwist
@@ -262,6 +263,12 @@ rifle = bangCane
     & itConsumption . reloadType .~ ActiveClear
     & itConsumption . reloadTime .~ 80
 
+makeClipAt :: Point3 -> Item -> Shape
+makeClipAt p it = translateSH p $ upperPrismPoly 1 $ rectNSEW 0 (-y) (-2) 2
+  where
+    y = fromIntegral y' * 0.3
+    y' = fromMaybe 0 $ it ^? itConsumption . ammoLoaded
+
 autoRifle :: Item
 autoRifle = rifle
     & itName .~ "AUTORIFLE"
@@ -557,19 +564,7 @@ pistol = defaultGun
         }
     , _itTweaks = defaultBulletSelTweak
     }
---pistolPic :: Item -> SPic
---pistolPic it = noPic $ colorSH green (prismPoly 
---        (map (addZ 3) $ rectNESW 3 3 (-3) (-3))
---        (map (addZ 0) $ rectNESW 5 3 (-5) (-7))
---    )
---    <> translateSH (V3 (-4) 5.5 4) (rotateSH pi $ bulletClip am)
---  where
---    am = _ammoLoaded $ _itConsumption it
 
-bulletClip :: Int -> Shape
-bulletClip x = rotateSHx (negate $ pi/4) . upperPrismPoly 2 $ rectNESW 3 0 (3 - 0.25 * am) (-5)
-  where
-    am = fromIntegral x
 
 hvAutoGun :: Item
 hvAutoGun = defaultAutoGun 
@@ -600,17 +595,6 @@ hvAutoGun = defaultAutoGun
         ,"*     " ++ fromMaybe "    " (maybeRateStatus it) ++ "  *"
         ]
     }
-hvAutoGunPic :: Item -> SPic
-hvAutoGunPic it = 
-    ( colorSH orange (prismPoly
-        (map (addZ 5) $ rectNESW 3 12 (-3) (-8))
-        (map (addZ 0) $ rectNESW 5 12 (-5) (-12))
-        )
-    <> bulletClip am
-    , mempty
-    )
-  where
-    am = _ammoLoaded $ _itConsumption it
 autoPistol :: Item
 autoPistol = pistol 
     & itUse . useMods .~ (ammoCheckI : pistolAfterHamMods)
@@ -657,19 +641,9 @@ ltAutoGun = defaultAutoGun
         }
     , _itTweaks = defaultBulletSelTweak
     }
-ltAutoGunPic :: Item -> SPic
-ltAutoGunPic it = 
-    ( colorSH green $ prismPoly 
-        (map (addZ 5) $ mirrorXAxis [V2 (-2) 3, V2 5 3, V2 10 0])
-        (map (addZ 0) $ mirrorXAxis [V2 (-5) 5, V2 5 5, V2 10 0])
-        <> bulletClip am
-    , mempty
-    )
-  where
-    am = _ammoLoaded $ _itConsumption it
 miniGun :: Item
 miniGun = defaultAutoGun 
-    { _itName = "MINI-G"
+    { _itName = "MINIGUN"
     , _itType = MINIGUN
     , _itConsumption = defaultAmmo 
         { _aoType = basicBullet
@@ -809,14 +783,6 @@ spreadGun = defaultGun
 --    , _itFloorPict = spreadGunPic
     , _itTweaks = defaultBulletSelTweak
     }
-spreadGunPic :: Item -> SPic
-spreadGunPic it = 
-    ( colorSH green (upperPrismPoly 5 $ map toV2[(-3,0),(3,6),(3,-6)])
-    <> bulletClip am
-    , mempty
-    )
-  where
-    am = _ammoLoaded $ _itConsumption it
 multGun :: Item
 multGun = defaultGun 
     { _itName = "MULTGUN"
@@ -855,21 +821,6 @@ multGun = defaultGun
         }
     , _itTweaks = defaultBulletSelTweak
     }
-multGunSPic :: Item -> SPic
-multGunSPic it = 
-    ( colorSH red (
-        upperPrismPoly 2 (rectNESW 4 8 (-4) (-12)) <>
-        translateSHf 8 0 (concatMap barrel [12,7,2,-3,-8] <> 
-            upperPrismPoly 2 (map toV2 [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)])
-            )
-    ) <> bulletClip am
-    , mempty
-    )
-  where
-    barrel y = prismPoly 
-        (map (addZ 5) $ rectNSEW y (y-4) 2   0 )
-        (map (addZ 0) $ rectNSEW y (y-4) 2 (-2))
-    am = _ammoLoaded $ _itConsumption it
 longGun :: Item
 longGun = defaultGun 
     { _itName = "LONGGUN"
@@ -901,11 +852,6 @@ longGun = defaultGun
     , _itAttachment = ItScope (V2 0 0) 0 1 False
     , _itEffect = itemLaserScopeEffect
     }
-longGunSPic :: Item -> SPic
-longGunSPic _ =
-    ( colorSH orange $ upperPrismPoly 5 $ rectXH 25 2
-    , mempty
-    )
 
 zoomLongGun :: Float -> Creature -> Item -> Item
 zoomLongGun x _

src/Dodge/Item/Weapon/TriggerType.hs

@@ -53,7 +53,7 @@ import Dodge.Reloading
 import Dodge.WorldEvent
 import Dodge.RandomHelp
 import Dodge.Inventory.Lock
-import Dodge.Creature.HandPos
+--import Dodge.Creature.HandPos
 --import Dodge.Default
 import Sound.Data
 import Geometry

src/Dodge/Render/HUD.hs

@@ -156,7 +156,7 @@ combineListStringPictures w = case concatMap (itemText . snd) . combineItemListY
     xs -> xs
 
 combineListLnks :: World -> [(Int,[Int])]
-combineListLnks = zip [0..] . map fst . combineListYou
+combineListLnks = zip [0..] . map fst . combineItemListYou
 
 ammoTweakStrings :: Maybe Item -> [String]
 ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of

src/Multiset.hs

@@ -1,13 +1,18 @@
 {-# LANGUAGE TupleSections #-}
 module Multiset where
 import qualified Data.Map.Strict as M
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
 import Control.Monad
+import Data.List (subsequences)
 
 powlistN :: Int -> [a] ->[[a]]
 powlistN _ [] = [[]]
 powlistN n (x:xs) 
     | n <=0     = [[]]
     | otherwise = ((x:) <$> powlistN (n-1) xs) ++ powlistN n xs
+powlistN' :: Int -> [a] ->[[a]]
+powlistN' k = filter ( ( k >= ) . length ) . subsequences
 
 -- exponential, so don't use it on long lists
 powlist :: [a] -> [[a]]
@@ -15,3 +20,8 @@ powlist = filterM (const [True,False])
 
 toMultiset :: Ord a => [a] -> M.Map a Int
 toMultiset = foldr (uncurry (M.insertWith (+)) . (, 1)) M.empty
+
+invertIntMap :: Ord a => IM.IntMap a -> M.Map a IS.IntSet
+invertIntMap = IM.foldrWithKey 
+    (\k x -> M.insertWith IS.union x (IS.singleton k))
+    M.empty

src/SimpleTrie.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE TemplateHaskell #-}
+module SimpleTrie where
+import Data.Map
+import Control.Lens
+data Trie a b = Trie
+    { _trieMVal    :: Maybe b
+    , _trieChildren :: Map a (Trie a b)
+    }
+makeLenses ''Trie
+
+emptyTrie :: Trie a b
+emptyTrie = Trie Nothing empty
+
+singletonTrie :: Ord a => [a] -> b -> Trie a b
+singletonTrie (k:ks) x = Trie Nothing $ singleton k $ singletonTrie ks x
+singletonTrie [] x = Trie (Just x) empty
+
+insertInTrie :: Ord a => [a] -> b -> Trie a b -> Trie a b
+insertInTrie [] x      = trieMVal .~ Just x
+insertInTrie (k:ks) x  = trieChildren %~ insertWith f k (singletonTrie ks x)
+  where
+    f _ = insertInTrie ks x
+
+lookupTrie :: Ord a => [a] -> Trie a b -> Maybe b
+lookupTrie []     t = _trieMVal t
+lookupTrie (k:ks) t = _trieChildren t !? k >>= lookupTrie ks