diff --git a/src/Dodge/Combine.hs b/src/Dodge/Combine.hs index 85f881163..d405390c1 100644 --- a/src/Dodge/Combine.hs +++ b/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' - -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) + $ map (first sort) itemCombinations lookupTypeTrie :: [CombineType] -> Maybe Item lookupTypeTrie = flip lookupTrie combinationsTrie . sort -combineItemList' :: IM.IntMap Item -> [([Int],Item)] -combineItemList' - = mapMaybe (pushoutmaybe . second lookupTypeTrie) +combineItemList :: IM.IntMap Item -> [([Int],Item)] +combineItemList = mapMaybe (pushOutMaybe . second lookupTypeTrie) . listCombos - where - pushoutmaybe (_,Nothing) = Nothing - pushoutmaybe (x,Just y) = Just (x,y) + +pushOutMaybe :: (a,Maybe b) -> Maybe (a,b) +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 diff --git a/src/Dodge/Combine/Combinations.hs b/src/Dodge/Combine/Combinations.hs new file mode 100644 index 000000000..bf8e6ab22 --- /dev/null +++ b/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 = (,) diff --git a/src/Dodge/Combine/Data.hs b/src/Dodge/Combine/Data.hs index 8ad23d242..076be324a 100644 --- a/src/Dodge/Combine/Data.hs +++ b/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 diff --git a/src/MaybeHelp.hs b/src/MaybeHelp.hs index 11be7d46d..b3093951a 100644 --- a/src/MaybeHelp.hs +++ b/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 diff --git a/src/Multiset.hs b/src/Multiset.hs index ff83472f4..c481912ee 100644 --- a/src/Multiset.hs +++ b/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]] -powlistN _ [] = [[]] -powlistN n (x:xs) +-- naive solution +powlistUpToN' :: Int -> [a] ->[[a]] +powlistUpToN' _ [] = [[]] +powlistUpToN' n (x:xs) | n <=0 = [[]] - | otherwise = ((x:) <$> powlistN (n-1) xs) ++ powlistN n xs -powlistN' :: Int -> [a] ->[[a]] -powlistN' k = filter ( ( k >= ) . length ) . subsequences + | otherwise = ((x:) <$> powlistUpToN' (n-1) xs) ++ powlistUpToN' n xs + +-- 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]] diff --git a/src/SimpleTrie.hs b/src/SimpleTrie.hs index 367cee8eb..d322b2eea 100644 --- a/src/SimpleTrie.hs +++ b/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