Cleanup combining code, flatten modules

2024-10-01 10:01:21 +01:00
parent f69d150e00
commit 87cbaf911f
17 changed files with 143 additions and 173 deletions
@@ -3,17 +3,19 @@ module Dodge.Combine (
    combineList,
 ) where

+import Dodge.Combine.Combinations
 import Data.Bifunctor
 import Data.List (sortOn)
 import qualified Data.Map.Strict as M
 import Dodge.Base.You
-import Dodge.Combine.Trie
 import Dodge.Data.Combine
 import Dodge.Data.Universe
 import Dodge.Item.Display
 import Dodge.Item.InventoryColor
 import qualified IntMapHelp as IM
 import SimpleTrie
+import Data.Foldable
+import Data.List (sort)

 invertInventoryToMap :: IM.IntMap Item -> M.Map ItemType [Int]
 invertInventoryToMap =
@@ -22,6 +24,7 @@ invertInventoryToMap =
        mempty

 groupSplitItemAmounts :: M.Map ItemType [Int] -> [((ItAmount, ItemType), [Int])]
+--groupSplitItemAmounts = M.foldrWithKey f []
 groupSplitItemAmounts = M.foldrWithKey f []
  where
    f ibt is = (++) [((fromIntegral i, ibt), take i is) | i <- [1 .. length is]]
@@ -46,3 +49,11 @@ combineList = map f . combineItemListYouX
            , _siOffX = 0
            , _siPayload = CombinableItem is itm []
            }
+
+combinationsTrie :: Trie (ItAmount, ItemType) Item
+{-# INLINE combinationsTrie #-}
+combinationsTrie =
+    foldl'
+        (flip $ uncurry insertInTrie . first sort)
+        emptyTrie
+        itemCombinations
@@ -52,7 +52,7 @@ maxShowX = \case
    _ -> Nothing

 itemCombinationsEdges :: [(CombNode,CombNode,Int)]
-itemCombinationsEdges = concatMap (f . over _2 (_itType)) itemCombinations
+itemCombinationsEdges = concatMap (f . over _2 _itType) itemCombinations
 --itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) bulletCombinations
  where
    f (abts,bt) 
@@ -1,25 +0,0 @@
-module Dodge.Combine.Trie 
-    ( combinationsTrie
-    ) where
-
-import Data.Bifunctor
-import Data.List (sort)
-import Dodge.Combine.Combinations
-import Dodge.Data.Item
-import SimpleTrie
-import Data.Foldable
-
--flatCombinationsTrie :: Trie ItemType Item
--{-# INLINE flatCombinationsTrie #-}
--flatCombinationsTrie = foldl'
--    (flip $ uncurry insertInTrie . first sort)
--    emptyTrie
--    flatItemCombinations
-
-combinationsTrie :: Trie (ItAmount, ItemType) Item
-{-# INLINE combinationsTrie #-}
-combinationsTrie =
-    foldl'
-        (flip $ uncurry insertInTrie . first sort)
-        emptyTrie
-        itemCombinations
@@ -51,8 +51,8 @@ instance Functor (LabelDoubleTree b) where

 instance Bifunctor LabelDoubleTree where
    second = fmap
-    first f (LDT x l r) = LDT x (map (first f . second (first f)) l)
-        (map (first f . second (first f)) r)
+    first f (LDT x l r) = LDT x (map (bimap f (first f)) l)
+        (map (bimap f (first f)) r)

 makeLenses ''DoubleTree
 makeLenses ''LabelDoubleTree
@@ -5,12 +5,10 @@

 module Dodge.Data.Item.Params where

-import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
 import Dodge.Data.ArcStep
--import Dodge.Data.Beam

 data ItemParams
    = NoParams
@@ -20,23 +18,6 @@ data ItemParams
        {_shrinkGunStatus :: ShrinkGunStatus}
    | FlatShieldParams
        {_flatShieldWlMIX :: Maybe Int}
-    | Refracting
-        { _phaseV :: Float
-        , _lasColor :: Color
-        , _lasColor2 :: Color
-        , _lasCycle :: Int
-        , _lasDamage :: Int
-        }
--    | DualBeam
--        { _phaseV :: Float
--        , _lasColor :: Color
--        , _lasColor2 :: Color
--        , _lasCycle :: Int
--        , _lasDamage :: Int
--        , _lasBeam :: BeamType
--        , _subParams :: Maybe ItemParams
--        , _dbGap :: Float
--        }
    | Arcing
        { _currentArc :: Maybe [ArcStep]
        , _arcSize :: Float
@@ -5,7 +5,7 @@ module Dodge.HeldUse
    )
    where

-import Color.Data
+import Color
 import Dodge.Base.Coordinate
 import Dodge.Base.Collide
 import Dodge.Inventory.Lock
@@ -138,22 +138,32 @@ loadMuzzle t@(LDT _ l _) mz = fromMaybe (t,Nothing) $ do
        , Just (mz, usedammo, mag)
        )

-makeMuzzleFlare :: Muzzle -> Item -> Creature -> World -> World
-makeMuzzleFlare mz itm cr = case mz ^. mzFlareType of
+makeMuzzleFlare :: Muzzle -> LabelDoubleTree ComposeLinkType Item -> Creature -> World -> World
+makeMuzzleFlare mz itmtree cr = case mz ^. mzFlareType of
    DefaultFlareType -> id
    PistolFlare -> basicMuzFlare pos dir
    MiniGunFlare -> makeTlsTimeRadColPos 2 100 (V3 1 1 0.5) (pos `v2z` 20)
        . muzFlareAt (V4 10 10 1 3) (pos `v2z` 20) dir
    HeavySmokeFlare -> basicMuzFlare pos dir
-    LasGunFlare -> flareCircleAt (_lasColor $ _itParams itm) 0.8 (pos `v2z` 20)
+    LasGunFlare -> flareCircleAt (getLaserColor itmtree) 0.8 (pos `v2z` 20)
        . (cWorld . lWorld . tempLightSources .:~ 
-            tlsTimeRadColPos 1 100 (xyzV4 . _lasColor $ _itParams itm) (pos `v2z` 10))
+            tlsTimeRadColPos 1 100 (xyzV4 $ getLaserColor itmtree) (pos `v2z` 10))
    TeslaGunFlare -> cWorld . lWorld . tempLightSources .:~ 
            tlsTimeRadColPos 1 100 (V3 0 0 1) (pos `v2z` 10)
  where
+    itm = itmtree ^. ldtValue
    pos = _crPos cr + rotateV (_crDir cr) (_mzPos mz + aimingWeaponZeroPos cr itm)
    dir = _crDir cr + _mzRot mz

+getLaserPhaseV :: LabelDoubleTree ComposeLinkType Item -> Float
+getLaserPhaseV = const 1
+
+getLaserDamage :: LabelDoubleTree ComposeLinkType Item -> LaserType
+getLaserDamage = const (DamageLaser 11)
+
+getLaserColor :: LabelDoubleTree ComposeLinkType Item -> Color
+getLaserColor = const yellow
+
 basicMuzFlare :: Point2 -> Float -> World -> World
 basicMuzFlare pos dir = makeTlsTimeRadColPos 2 100 (V3 1 1 0.5) (pos `v2z` 20)
        . muzFlareAt (V4 10 10 1 3) (pos `v2z` 20) dir
@@ -186,9 +196,9 @@ useLoadedAmmo :: LabelDoubleTree ComposeLinkType Item
    -> (CumulativeMuzzleEffect,World)
 useLoadedAmmo _ _ (cme,w) (_,Nothing) = (cme, w)
 useLoadedAmmo itmtree cr (cme,w) (mzid,Just (mz,x,magtree)) = (,) (cme & cmeSound .~ True) $ 
-        removeAmmoFromMag x mid cr . makeMuzzleFlare mz itm cr $ case _mzEffect mz of
+        removeAmmoFromMag x mid cr . makeMuzzleFlare mz itmtree cr $ case _mzEffect mz of
    MuzzleShootBullet -> shootBullet itmtree cr (mz,x,magtree) w
-    MuzzleLaser -> shootLaser itm cr mz w
+    MuzzleLaser -> shootLaser itmtree cr mz w
    MuzzleTesla -> shootTeslaArc itm cr mz w
    MuzzleTractor -> shootTractorBeam cr w
    MuzzleLauncher -> createProjectile magtree mz itmtree cr w 
@@ -241,18 +251,19 @@ tractorBeamAt pos outpos dir power =
  where
    d = unitVectorAtAngle dir * power

-shootLaser :: Item -> Creature -> Muzzle -> World -> World
-shootLaser itm cr mz w = w 
+shootLaser :: LabelDoubleTree ComposeLinkType Item  -> Creature -> Muzzle -> World -> World
+shootLaser itmtree cr mz w = w 
    & randGen .~ g
    & cWorld . lWorld . lasers
        .:~ LaserStart
-            { _lpType = DamageLaser . _lasDamage $ _itParams itm
-            , _lpPhaseV = _phaseV $ _itParams itm
+            { _lpType = getLaserDamage itmtree
+            , _lpPhaseV = getLaserPhaseV itmtree
            , _lpPos = pos
            , _lpDir = dir
-            , _lpColor = _lasColor $ _itParams itm
+            , _lpColor = getLaserColor itmtree
            }
  where
+    itm = itmtree ^. ldtValue
    pos = _crPos cr + rotateV (_crDir cr) (_mzPos mz + aimingWeaponZeroPos cr itm)
    (a,g) = randomR (-inacc,inacc) $ _randGen w
    inacc = _mzInaccuracy mz
@@ -412,12 +423,12 @@ doGenFloat (UniRandFloat x y) g = randomR (x,y) g
 --             & itUse . heldParams . rifling .~ rifl

 mcShootLaser :: Item -> Machine -> World -> World
-mcShootLaser it mc = cWorld . lWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
+mcShootLaser _ mc = cWorld . lWorld . lasers .:~ lasRayAt yellow dam phasev pos dir
  where
    pos = _mcPos mc +.+ 20 *.* unitVectorAtAngle dir
    dir = mc ^?! mcType . _McTurret . tuDir
-    phasev = _phaseV . _itParams $ it
-    dam = _lasDamage $ _itParams it
+    phasev = 1
+    dam = 11

 -- | assumes that the item is held
 shootTeslaArc :: Item -> Creature -> Muzzle -> World -> World
@@ -84,6 +84,7 @@ showAttachItem t itm = case t of

 showEquipItem :: EquipItemType -> String
 showEquipItem eit = case eit of
+    INVISIBILITYEQUIPMENT esite -> "INVISIBILITY " ++ show esite
    _ -> show eit

 showAutoRechargeProgress :: LeftConsumption -> String
@@ -27,7 +27,7 @@ itemTreeSPic (LDT (itm, _) l r) =
 itemRotTreeSPic :: Item -> (ItemLink, LabelDoubleTree ItemLink ComposedItem) -> SPic
 itemRotTreeSPic par (il, t) = fromMaybe mempty $ do
    (p, q) <- _iatOrient il par (_iatType il) itm
-    return $ (translateSP p $ overPosSP (Q.rotate q) $ itemTreeSPic t)
+    return . translateSP p . overPosSP (Q.rotate q) $ itemTreeSPic t
  where
    itm = t ^. ldtValue . _1

@@ -178,22 +178,22 @@ heldItemSPic ht it = case ht of
    FORCEFIELDGUN -> defSPic
    TORCH -> noPic torchShape
    BANGSTICK i -> noPic $ baseStickShapeX it i -- <> addBullets it
-    PISTOL -> noPic $ baseStickShape
-    MACHINEPISTOL -> noPic $ baseStickShape
-    AUTOPISTOL -> noPic $ baseStickShape
-    SMG -> noPic $ baseSMGShape
+    PISTOL -> noPic baseStickShape
+    MACHINEPISTOL -> noPic baseStickShape
+    AUTOPISTOL -> noPic baseStickShape
+    SMG -> noPic baseSMGShape
    BANGCONE -> noPic $ bangConeShape 5
    BLUNDERBUSS -> noPic $ bangConeShape 20
    GRAPECANNON _ -> noPic $ bangConeShape 20
    MINIGUNX i -> miniGunXPictItem i it
    VOLLEYGUN i -> noPic $ volleyGunShape i -- <> addBullets it
    RIFLE -> noPic baseRifleShape -- <> addBullets it
-    AUTORIFLE -> noPic $ baseRifleShape
-    BURSTRIFLE -> noPic $ baseRifleShape
+    AUTORIFLE -> noPic baseRifleShape
+    BURSTRIFLE -> noPic baseRifleShape
    BANGROD -> noPic baseRodShape -- <> addBullets it
    ELEPHANTGUN -> noPic baseAMRShape -- <> addBullets it
-    AMR -> noPic $ baseAMRShape
-    AUTOAMR -> noPic $ baseAMRShape
+    AMR -> noPic baseAMRShape
+    AUTOAMR -> noPic baseAMRShape
    SNIPERRIFLE -> noPic baseAMRShape -- <> addBullets it
    --    MACHINEGUN -> noPic $ baseAMRShape <> addTinClip it
    FLAMESPITTER -> flamerPic it
@@ -360,11 +360,12 @@ teslaGunPic =

 lasGunPic :: Item -> SPic
 lasGunPic _ =
-    ( colorSH blue $
-        upperBoxST 4 (rectNESW 3 30 1 0)
+    colorSH
+        blue
+        ( upperBoxST 4 (rectNESW 3 30 1 0)
            <> upperBoxSU 4 (rectNESW (-1) 30 (-3) 0)
            <> upperBoxSU 1 (rectNESW 3 30 (-3) 0)
-    )
+        )
        :!: (setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0)
  where
    --amFrac = fractionLoadedAmmo it
@@ -73,7 +73,7 @@ ammoComposedItem' itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
            ,noa (AmmoTargetingSF atype) AmmoTargetingLink
            ,noa (AmmoPayloadSF atype) AmmoPayloadLink
            ,noa (AmmoEffectSF atype) AmmoEffectLink
-            ,noa (RemoteScreenSF) RemoteScreenLink
+            ,noa RemoteScreenSF RemoteScreenLink
            ] 
            []
        )
@@ -125,7 +125,7 @@ invLDT'' =
        . fmap (singleLDT . basePartiallyComposedItem')

 invLDT' :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItem]
-invLDT' = map (first _iatType . second (\(x,y,_) -> (x,y))) . invLDT''
+invLDT' = map (bimap _iatType (\(x,y,_) -> (x,y))) . invLDT''

 -- this assumes the creature inventory is well formed, specifically the
 -- location ids
@@ -7,16 +7,10 @@ module Dodge.Item.Held.BatteryGuns

 import Dodge.SoundLogic.ExternallyGeneratedSounds
 import Dodge.Default.Item
--import Dodge.Base
--import Dodge.Data.Beam
-import Color
 import Control.Lens
--import qualified Data.Map.Strict as M
 import Dodge.Data.Item
--import Dodge.Reloading.Action
 import Dodge.Tesla.ItemParams
 import Geometry.Data
--import qualified IntMapHelp as IM

 sparkGun :: Item
 sparkGun =
@@ -54,14 +48,14 @@ lasGun =
        & itUse . heldAim . aimMuzzles . ix 0 . mzInaccuracy .~ 0
        & itUse . heldAim . aimMuzzles . ix 0 . mzFlareType .~ LasGunFlare
        & itUse . heldAim . aimMuzzles . ix 0 . mzEffect .~ MuzzleLaser
-        & itParams
-            .~ Refracting
-                { _phaseV = 1
-                , _lasColor = yellow
-                , _lasColor2 = yellow
-                , _lasCycle = 0
-                , _lasDamage = 11
-                }
+--        & itParams
+--            .~ Refracting
+--                { _phaseV = 1
+--                , _lasColor = yellow
+--                , _lasColor2 = yellow
+--                , _lasCycle = 0
+--                , _lasDamage = 11
+--                }
        & itDimension . dimRad .~ 10
        & itDimension . dimCenter .~ V3 15 0 0
        & itUse . heldAim . aimWeight .~ 6
@@ -19,7 +19,7 @@ orientByLink itm lt = case (_itType itm,lt) of
    _ -> (0,Q.axisAngle (V3 1 0 0) 0)

 orientAttachment :: Item -> ComposeLinkType -> Item -> Maybe (Point3, Q.Quaternion Float)
-orientAttachment par lnk ch = Just (t1 + (Q.rotate q1 t2), q1 * q2)
+orientAttachment par lnk ch = Just (t1 + Q.rotate q1 t2, q1 * q2)
  where
    (t1,q1) = orientByLink par lnk
    (t2,q2) = orientChild ch
@@ -103,8 +103,8 @@ drawCreature cr = case _crType cr of

 lampCrSPic :: Float -> SPic
 lampCrSPic h =
-    ( colorSH blue . upperBox Small Typical h $ rectWH 5 5)
-    :!: (setLayer BloomLayer (setDepth h . color white $ circleSolid 3))
+     colorSH blue (upperBox Small Typical h $ rectWH 5 5)
+    :!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)

 picAtCrPos1 :: Picture -> Creature -> SPic
 --{-# INLINE picAtCrPos #-}
@@ -1,4 +1,3 @@
-{-# LANGUAGE TupleSections #-}
 module ShapePicture
    ( module ShapePicture.Data
    , translateSP
@@ -28,7 +28,7 @@ fdiv :: Int -> Int -> String -> String
 fdiv x y s = removeDot (take 3 (show ((fromIntegral x / fromIntegral y)::Float))) ++ s

 removeDot :: String -> String
-removeDot (a:b:'.':[]) = a:b:[]
+removeDot [a,b,'.'] = [a,b]
 removeDot xs = xs

 k,m,g,t,p :: Int