Fix combination bug

2021-12-06 02:33:36 +00:00
parent 22e3256da3
commit 40195d033c
12 changed files with 122 additions and 100 deletions
@@ -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
-
-combineListYou :: World -> [([Int],CombineType)]
-combineListYou = fmap (second _itType) . combineItemListYou
+combineItemListYou = combineItemList' . yourInv

 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)
-
-combine :: M.Map CombineType Int -> Maybe CombineType
-combine m = lookup m combinations
+    mi = 0 <$ listToMaybe (combineItemListYou w)

 combineSizes :: World -> [Int]
 combineSizes = map (ceiling . _itInvSize . snd) . combineItemListYou
@@ -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..] 
@@ -3,4 +3,4 @@ import Dodge.Data
 import Geometry

 crHandPos :: Creature -> Point3
-crHandPos cr = V3 0 0 20
+crHandPos _ = V3 0 0 20
@@ -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

@@ -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
@@ -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
@@ -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 :)
@@ -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 _
@@ -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
@@ -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
@@ -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
@@ -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