Cleanup combination accessing code

src/Dodge/Combine.hs

@@ -1,95 +1,41 @@
 --{-# LANGUAGE TupleSections #-}
-module Dodge.Combine where
+module Dodge.Combine 
+    ( combinePoss
+    , combineSizes
+    , combineItemListYou
+    , toggleCombineInv
+    , enterCombineInv
+    ) where
+import Dodge.Combine.Combinations
 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
 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')
 
-itemCombinations :: [ (M.Map CombineType Int, Item) ]
-itemCombinations = map (first toMultiset) itemCombinations'
-
 combinationsTrie :: Trie CombineType Item
 combinationsTrie = foldr (uncurry insertInTrie) emptyTrie
-    $ map (first sort) itemCombinations'
+    $ map (first sort) itemCombinations
-
-itemCombinations' :: [([CombineType],Item)]
-itemCombinations' =
-    [ p [PIPE,HARDWARE] (bangStick 1)
-    , p [BANGSTICK 1,TIN] pistol
-    , p [PISTOL, SPRING, HARDWARE] autoPistol
-    , p [AUTOPISTOL, PLANK, HARDWARE] smg
-    , p [AUTOPISTOL, HARDWARE] machinePistol
-    , p [BANGSTICK 1,CAN] revolver
-    , p [REVOLVER, SPRING, HARDWARE] $ revolverX 1
-
-    , p [PIPE,TUBE,HARDWARE] bangCone
-    , p [BANGCONE,PLANK] blunderbuss
-    , p [BLUNDERBUSS,TUBE] grapeShotCannon
-    , p [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1
-    , p [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2
-
-    , p [PIPE,PIPE,HARDWARE] bangCane
-    , p [BANGCANE,PIPE,PIPE] (bangCaneX 2)
-    , 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
-    , p [ELEPHANTGUN,HARDWARE,TIN] amr
-    , p [ELEPHANTGUN,HARDWARE,CAN] sniperRifle
-    , p [BANGROD,PLATE,DRUM,MOTOR] machineGun
-
-    , p [TUBE,TUBE,TUBE,HARDWARE] launcher
-    ] 
-    ++ map (\i -> ([PIPE,BANGSTICK i],bangStick (i+1))) [1..8]
-    ++ map (\i -> ([REVOLVERX i,CAN] ,revolverX (i+1))) [1..5]
-    ++ map (\i -> ([BANGCANEX i,PIPE,PIPE] ,bangCaneX (i+1))) [1..5]
-  where
-    p = (,)
-
-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)
-    . concatMap itemsMultisets
-    . 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 :: IM.IntMap Item -> [([Int],Item)]
-combineItemList'
+combineItemList = mapMaybe (pushOutMaybe . second lookupTypeTrie)
-    = mapMaybe (pushoutmaybe . second lookupTypeTrie)
     . listCombos
-  where
+
-    pushoutmaybe (_,Nothing) = Nothing
+pushOutMaybe :: (a,Maybe b) -> Maybe (a,b)
-    pushoutmaybe (x,Just y)  = Just (x,y)
+pushOutMaybe (_,Nothing) = Nothing
+pushOutMaybe (x,Just y)  = Just (x,y)
 
 listCombos :: IM.IntMap Item -> [([Int], [CombineType])]
 listCombos = concatMap expandOut . invertListInvMult
@@ -98,45 +44,18 @@ 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]
+    f (ct,i,n) = map (\j -> (replicate j i,replicate j ct)) [1..min 4 n]
 
 invertListInvMult :: IM.IntMap Item -> [[(CombineType,Int,Int)]]
-invertListInvMult = powlistN 4 . invertListInv
+invertListInvMult = powlistUpToN 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)]
-itemsMultisets = map mconcat . mapM itemMultisets
-
--- "individual" items can produce multiple multisets if they are in fact
--- a stack of more than one item
-itemMultisets :: (Int,Item) -> [([Int],M.Map CombineType Int)]
-itemMultisets (i,it) = case it ^? itConsumption . itAmount of
-    Nothing -> [ ([i], M.singleton thetype 1 ) ]
-    Just n  -> map (\k -> (replicate k i, M.singleton thetype k)) [1..n]
-  where
-    thetype = _itType it
-
 combineItemListYou :: World -> [([Int],Item)]
-combineItemListYou = combineItemList' . yourInv
+combineItemListYou = combineItemList . yourInv
 
 toggleCombineInv :: World -> World
 toggleCombineInv w = case _inventoryMode w of

src/Dodge/Combine/Combinations.hs

@@ -0,0 +1,40 @@
+module Dodge.Combine.Combinations where
+import Dodge.Data
+import Dodge.Item.Weapon.BulletGuns
+import Dodge.Item.Weapon.Launcher
+itemCombinations :: [([CombineType],Item)]
+itemCombinations =
+    [ p [PIPE,HARDWARE] (bangStick 1)
+    , p [BANGSTICK 1,TIN] pistol
+    , p [PISTOL, SPRING, HARDWARE] autoPistol
+    , p [AUTOPISTOL, PLANK, HARDWARE] smg
+    , p [AUTOPISTOL, HARDWARE] machinePistol
+    , p [BANGSTICK 1,CAN] revolver
+    , p [REVOLVER, SPRING, HARDWARE] $ revolverX 1
+
+    , p [PIPE,TUBE,HARDWARE] bangCone
+    , p [BANGCONE,PLANK] blunderbuss
+    , p [BLUNDERBUSS,TUBE] grapeShotCannon
+    , p [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1
+    , p [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2
+
+    , p [PIPE,PIPE,HARDWARE] bangCane
+    , p [BANGCANE,PIPE,PIPE] (bangCaneX 2)
+    , 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
+    , p [ELEPHANTGUN,HARDWARE,TIN] amr
+    , p [ELEPHANTGUN,HARDWARE,CAN] sniperRifle
+    , p [BANGROD,PLATE,DRUM,MOTOR] machineGun
+
+    , p [TUBE,TUBE,TUBE,HARDWARE] launcher
+    ] 
+    ++ map (\i -> ([PIPE,BANGSTICK i],bangStick (i+1))) [1..8]
+    ++ map (\i -> ([REVOLVERX i,CAN] ,revolverX (i+1))) [1..5]
+    ++ map (\i -> ([BANGCANEX i,PIPE,PIPE] ,bangCaneX (i+1))) [1..5]
+  where
+    p = (,)

src/Dodge/Combine/Data.hs

@@ -1,7 +1,7 @@
 module Dodge.Combine.Data
     (CombineType (..)
-    )
+    ) where
-    where
+-- TODO make this an enum somehow...?
 data CombineType
     = NOTDEFINED
     -- Weapons

src/MaybeHelp.hs

@@ -5,7 +5,7 @@ import Control.Lens
 
 -- | Strict maybe
 data Maybe' a 
-    = Just' {_Just' :: a }
+    = Just' {__Just' :: a }
     | Nothing'
 
 fromJust' :: Maybe' a -> a

src/Multiset.hs

@@ -4,15 +4,42 @@ 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]]
+-- naive solution
-powlistN _ [] = [[]]
+powlistUpToN' :: Int -> [a] ->[[a]]
-powlistN n (x:xs) 
+powlistUpToN' _ [] = [[]]
+powlistUpToN' n (x:xs) 
     | n <=0     = [[]]
-    | otherwise = ((x:) <$> powlistN (n-1) xs) ++ powlistN n xs
+    | otherwise = ((x:) <$> powlistUpToN' (n-1) xs) ++ powlistUpToN' n xs
-powlistN' :: Int -> [a] ->[[a]]
+
-powlistN' k = filter ( ( k >= ) . length ) . subsequences
+-- adapted from
+-- https://stackoverflow.com/questions/21265454/subsequences-of-length-n-from-list-performance/59932616#59932616
+-- uses dynamic programming: the important part is the use of "next" twice
+-- there is a (probably) faster SO answer that produces power lists of size
+-- exactly N, but that answer is harder to adapt
+powlistUpToN :: Int -> [a] -> [[a]]
+powlistUpToN n xs = 
+    let l = length xs
+    in if n > l then [] else concat $ drop (l-n) (subseqsBySize xs)
+  where
+    subseqsBySize [] = [[[]]]
+    subseqsBySize (y:ys) =
+        let next = subseqsBySize ys
+        in zipWith (++) ([]:next) (map (map (y:)) next ++ [[]])
+-- this is the code producing all exactly n length sublists
+combinationsOf :: Int -> [a] -> [[a]]
+combinationsOf 1 as        = map pure as
+combinationsOf k' as@(_:xs) = run (l-1) (k'-1) as $ combinationsOf (k'-1) xs
+  where
+    l = length as
+    run :: Int -> Int -> [a] -> [[a]] -> [[a]]
+    run n k ys cs 
+        | n == k    = map (ys ++) cs
+        | otherwise = map (q:) cs ++ run (n-1) k qs (drop dc cs)
+      where
+        (q:qs) = take (n-k+1) ys
+        dc     = product [(n-k+1)..(n-1)] `div` product [1..(k-1)]
+combinationsOf _ [] = []
 
 -- exponential, so don't use it on long lists
 powlist :: [a] -> [[a]]

src/SimpleTrie.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 module SimpleTrie where
-import Data.Map
+import Data.Map.Strict
 import Control.Lens
 data Trie a b = Trie
     { _trieMVal    :: Maybe b
@@ -22,5 +22,5 @@ insertInTrie (k:ks) x  = trieChildren %~ insertWith f k (singletonTrie ks x)
     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
+lookupTrie []     t = _trieMVal t