Use strict tuples for SPics

ghcidOutput

@@ -1,20 +1 @@
-/home/justin/Haskell/loop/src/Dodge/Item/Draw/SPic.hs:69:5-6: warning: [-Wunused-local-binds]
+All good (605 modules, at 01:05:43)
-    Defined but not used: ‘am’
-   |
-69 |     am = fractionLoadedAmmo (it ^?! itUse . amagLoadStatus)
-   |     ^^
-/home/justin/Haskell/loop/src/Dodge/Item/Draw/SPic.hs:75:1-19: warning: [-Wunused-top-binds]
-    Defined but not used: ‘fractionLoadedAmmo2’
-   |
-75 | fractionLoadedAmmo2 rs = 
-   | ^^^^^^^^^^^^^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:12:1: warning: [-Wunused-imports]
-    The import of ‘Geometry.Data’ is redundant
-   |
-12 | import Geometry.Data
-   | ^^^^^^^^^^^^^^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:63:5: warning: [-Wunused-local-binds]
-    Defined but not used: ‘c’
-   |
-63 |     c x y _ _ _ = Just (x,y)
-   |     ^

package.yaml

@@ -40,6 +40,7 @@ dependencies:
 - random
 - sdl2
 - sdl2-mixer
+- strict
 - template-haskell
 - transformers
 - unordered-containers

src/Dodge/Button/Draw.hs

@@ -17,20 +17,18 @@ drawSwitch col1 col2 bt
     | _btState bt == BtOff = flick $ pi / 4
     | otherwise = flick (negate (pi / 4))
   where
-    flick a =
+    flick a = noPic
         ( mconcat
             [ colorSH col1 . upperBox Small Typical 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10
             , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperBox Small Typical 2 $
                 reverse $
                     rectNSWE 10 0 (-2) 2
             ]
-        , mempty
         )
 
 defaultDrawButton :: Color -> Button -> SPic
-defaultDrawButton col bt =
+defaultDrawButton col bt = noPic
     ( translateSHz 15 . colorSH col $ upperBox Small Typical 5 buttonGeometry
-    , mempty
     )
   where
     buttonGeometry

src/Dodge/Creature/Picture.hs

@@ -25,7 +25,7 @@ import ShapePicture
 
 basicCrPict :: Creature -> SPic
 basicCrPict cr = uncurryV translateSPxy (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) 
-    <> (basicCrShape cr, mempty)
+    <> noPic (basicCrShape cr)
 
 --testShape :: Shape
 --testShape = translateSHz 10 . rotateSHx 1 . upperCylinder 20 $ polyCirc 2 10
@@ -103,7 +103,7 @@ deadFeet = feet
 arms :: Creature -> Shape
 {-# INLINE arms #-}
 arms cr =
-    fst $
+    (^. _1) $
         translateToRightHand cr aHand
             <> translateToLeftHand cr aHand
   where

src/Dodge/Item/Draw/SPic.hs

@@ -5,6 +5,7 @@ module Dodge.Item.Draw.SPic (
     itemTreeSPic,
 ) where
 
+import Data.Strict.Tuple
 import Data.Maybe
 import qualified Linear.Quaternion as Q
 import Dodge.Data.ComposedItem
@@ -58,35 +59,33 @@ ammoMagSPic :: Item -> AmmoMagType -> SPic
 ammoMagSPic it = \case
     TINMAG -> noPic $ upperPrismPolyTS 1 (reverse $ rectNSWE 0 (- y) (-1) 1)
     DRUMMAG -> noPic $ upperPrismPolyTS 1 (reverse $ rectNSWE 0 (- y) (-1) 1)
-    CHEMFUELPOUCH -> (colorSH yellow (upperPrismPolyST 3 $ polyCirc 3 5)
+    CHEMFUELPOUCH -> noPic $ colorSH yellow (upperPrismPolyST 3 $ polyCirc 3 5)
-        , mempty
 --        , setLayer MidLayer . color black $ translate3 (V3 0 0 4) $ circleSolid (5 * am)
-        )
     _ -> noPic $ upperPrismPolyTS 1 (reverse $ rectNSWE 0 (- y) (-1) 1)
   where
     y = fromIntegral y' * 0.3
     y' = fromMaybe 0 $ it ^? itUse . amagLoadStatus . iaLoaded
-    am = fractionLoadedAmmo (it ^?! itUse . amagLoadStatus)
+--    am = fractionLoadedAmmo (it ^?! itUse . amagLoadStatus)
 
-fractionLoadedAmmo :: ReloadStatus -> Float
+--fractionLoadedAmmo :: ReloadStatus -> Float
-fractionLoadedAmmo rs = fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs)
+--fractionLoadedAmmo rs = fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs)
-
+--
-fractionLoadedAmmo2 :: ReloadStatus -> Float
+--fractionLoadedAmmo2 :: ReloadStatus -> Float
-fractionLoadedAmmo2 rs = 
+--fractionLoadedAmmo2 rs = 
-    1 - (1 - fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs)) ** 2
+--    1 - (1 - fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs)) ** 2
 
 equipItemSPic :: EquipItemType -> Item -> SPic
 equipItemSPic et _ = case et of
     MAGSHIELD -> defSPic
     FLAMESHIELD -> defSPic
-    FRONTARMOUR ->
+    FRONTARMOUR -> defSPic
-        ( mempty
+--        ( mempty
-        , setDepth 20 $
+--        , setDepth 20 $
-            fold
+--            fold
-                [ color yellow $ thickArc 0 (pi / 2) 10 5
+--                [ color yellow $ thickArc 0 (pi / 2) 10 5
-                , color yellow $ thickArc (3 * pi / 2) (2 * pi) 10 5
+--                , color yellow $ thickArc (3 * pi / 2) (2 * pi) 10 5
-                ]
+--                ]
-        )
+--        )
     WRISTARMOUR -> defSPic
     INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPolySI 3 $ rectWH 2 2)
     BRAINHAT -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4)
@@ -198,10 +197,10 @@ heldItemSPic ht it = case ht of
     FORCEFIELDGUN -> defSPic
     TORCH -> noPic torchShape
     BANGSTICK i -> noPic $ baseStickShapeX it i -- <> addBullets it
-    PISTOL -> noPic $ baseStickShape <> addTinClip it
+    PISTOL -> noPic $ baseStickShape
-    MACHINEPISTOL -> noPic $ baseStickShape <> addTinClip it
+    MACHINEPISTOL -> noPic $ baseStickShape
-    AUTOPISTOL -> noPic $ baseStickShape <> addTinClip it
+    AUTOPISTOL -> noPic $ baseStickShape
-    SMG -> noPic $ baseSMGShape <> addTinClip it
+    SMG -> noPic $ baseSMGShape
     BANGCONE -> noPic $ bangConeShape 5
     BLUNDERBUSS -> noPic $ bangConeShape 20
     GRAPECANNON _ -> noPic $ bangConeShape 20
@@ -209,12 +208,12 @@ heldItemSPic ht it = case ht of
     VOLLEYGUN i -> noPic $ volleyGunShape i -- <> addBullets it
     RIFLE -> noPic baseRifleShape -- <> addBullets it
 --    REPEATER -> noPic $ baseRifleShape <> addTinClip it
-    AUTORIFLE -> noPic $ baseRifleShape <> addTinClip it
+    AUTORIFLE -> noPic $ baseRifleShape
-    BURSTRIFLE -> noPic $ baseRifleShape <> addTinClip it
+    BURSTRIFLE -> noPic $ baseRifleShape
     BANGROD -> noPic baseRodShape -- <> addBullets it
     ELEPHANTGUN -> noPic baseAMRShape -- <> addBullets it
-    AMR -> noPic $ baseAMRShape <> addTinClip it
+    AMR -> noPic $ baseAMRShape
-    AUTOAMR -> noPic $ baseAMRShape <> addTinClip it
+    AUTOAMR -> noPic $ baseAMRShape
     SNIPERRIFLE -> noPic baseAMRShape -- <> addBullets it
 --    MACHINEGUN -> noPic $ baseAMRShape <> addTinClip it
     FLAMESPITTER -> flamerPic it
@@ -290,97 +289,8 @@ baseCaneShape :: Shape
 baseCaneShape = colorSH red $ xCylinderST 3 15
 
 baseRifleShape :: Shape
---baseRifleShape = colorSH red $ upperPrismPoly 3 $ rectXH 25 2
---baseRifleShape = colorSH red . rotateSHq (V3 0 1 0) (pi/2) . upperCylinder 25 $ polyCirc 3 2
---baseRifleShape = colorSH red $ xCylinder 4 2 25
 baseRifleShape = colorSH red $ xCylinderST 3 25
 
---addBullets :: Item -> Shape
---addBullets itm = fromMaybe mempty $ do
---    x <- itm ^? itUse . heldConsumption . laSource . _InternalSource . iaLoaded
---    hit <- itm ^? itType . iyBase . ibtHeld
---    ps <- fmap (take x) $ ammoPosition itm hit ^? amPosDirs
---    return $ foldMap (uncurry (drawBullet itm)) ps
-
----- why is this duplicated?
---drawBullet :: Item -> Point3 -> Q.Quaternion Float -> Shape
---drawBullet itm p q =
---    translateSH p $
---        overPosSH (Q.rotate q) $
---            colorSH
---                midcol
---                ( upperPrismPolyTS 0.2 $
---                    reverse
---                        (rectNSWE 0.2 (- 0.2) (-1) 1)
---                )
---                <> tip
---                <> foot
---  where
---    midcol =
---        maybe
---            black
---            bulletEffectColor
---            (itm ^? itUse . heldConsumption . laAmmoType . amBullet . buEffect)
---    tip = fromMaybe mempty $ do
---        ebt <- itm ^? itUse . heldConsumption . laAmmoType . amBullet . buSpawn
---        return $
---            colorSH (bulletPayloadColor ebt) $
---                upperPrismPolyTS 0.2 $
---                    reverse $
---                        rectNSWE 0.2 (- 0.2) 1 2
---    foot = fromMaybe mempty $ do
---        ebt <- itm ^? itUse . heldConsumption . laAmmoType . amBullet . buTrajectory
---        return $
---            colorSH (bulletTrajColor ebt) $
---                upperPrismPolyTS 0.2 $
---                    reverse $
---                        rectNSWE 0.2 (- 0.2) (-2) (-1)
-
-addTinClip :: Item -> Shape
-addTinClip _ = mempty
---addTinClip :: Item -> Shape
---addTinClip itm = fromMaybe mempty $ do
---    hit <- itm ^? itType . iyBase . ibtHeld
---    let ap = ammoPosition itm hit
---    p <- ap ^? amposPos
---    d <- ap ^? amposDir
---    return $ translateSH p $ overPosSH (Q.rotate d) $ makeTinClip itm
---
---makeTinClip :: Item -> Shape
---makeTinClip it =
---    colorSH
---        midcol
---        ( upperPrismPolyTS
---            1
---            ( reverse $
---                rectNSWE 0 (- y) (-1) 1
---            )
---        )
---        <> tips
---        <> tails
---  where
---    midcol =
---        maybe
---            black
---            bulletEffectColor
---            (it ^? itUse . heldConsumption . laAmmoType . amBullet . buEffect)
---    y = fromIntegral y' * 0.3
---    y' = fromMaybe 0 $ it ^? itUse . heldConsumption . laSource . _InternalSource . iaLoaded
---    tips = fromMaybe mempty $ do
---        ebt <- it ^? itUse . heldConsumption . laAmmoType . amBullet . buSpawn
---        return $
---            colorSH (bulletPayloadColor ebt) $
---                upperPrismPolyTS 1.1 $
---                    reverse $
---                        rectNSWE 0 (- y) 1 2
---    tails = fromMaybe mempty $ do
---        ebt <- it ^? itUse . heldConsumption . laAmmoType . amBullet . buTrajectory
---        return $
---            colorSH (bulletTrajColor ebt) $
---                upperPrismPolyTS 1.1 $
---                    reverse $
---                        rectNSWE 0 (- y) (-2) (-1)
-
 --bulletEffectColor :: BulletEffect -> Color
 --bulletEffectColor x = case x of
 --    DestroyBullet -> black
@@ -428,12 +338,9 @@ miniGunXPictItem i it = miniGunXPict i spin
                 + _warmTime (_heldDelay $ _itUse it)
 
 miniGunXPict :: Int -> Int -> SPic
-miniGunXPict i spin =
+miniGunXPict i spin = noPic
     ( colorSH red (rotateSHx a barrels)
         <> baseRifleShape
-    , --        <> clip (-1) 0
-      --        <> clip (-7) 0
-      mempty
     )
   where
     aBarrel = translateSH (V3 15 2 2) baseCaneShape
@@ -452,22 +359,7 @@ baseSMGShape :: Shape
 baseSMGShape = colorSH green $ xCylinderST 3 20
 
 flamerPic :: Item -> SPic
---flamerPic it =
+flamerPic _ = noPic . colorSH yellow $ xCylinderST 5 18
-flamerPic _ =
-    ( colorSH yellow $
---        translateSHxy tx ty (upperPrismPolyST tz $ polyCirc 3 r)
---            <> 
-        xCylinderST 5 18
-        , mempty
-    --, color black $ translate3 (V3 tx ty (tz + 0.01)) $ circleSolid (r * am)
---    , color black $ translate3 (V3 tx ty (tz + 0.01)) $ circleSolid (r * 0.5)
-    )
---  where
---    tx = 4
---    ty = - 6
---    tz = 3
---    r = 5
---    am = fractionLoadedAmmo2 it
 
 launcherPic :: Item -> SPic
 launcherPic _ = noPic . colorSH cyan $ xCylinderST 5 20
@@ -496,14 +388,12 @@ teslaGunPic =
     xb = 9
 
 lasGunPic :: Item -> SPic
---lasGunPic it =
 lasGunPic _ =
     ( colorSH blue $
         upperBoxST 4 (rectNESW 3 30 1 0)
             <> upperBoxSU 4 (rectNESW (-1) 30 (-3) 0)
-            <> upperBoxSU 1 (rectNESW 3 30 (-3) 0)
+            <> upperBoxSU 1 (rectNESW 3 30 (-3) 0))
-    , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0
+    :!: (setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0)
-    )
   where
     --amFrac = fractionLoadedAmmo it
     amFrac = 0.5
@@ -527,10 +417,7 @@ tractorGunPic :: Item -> SPic
 tractorGunPic = lasGunPic
 
 flatShieldEquipSPic :: SPic
-flatShieldEquipSPic =
+flatShieldEquipSPic = noPic . colorSH yellow $ upperBoxMT 10 (rectWH 2 10)
-    ( colorSH yellow $ upperBoxMT 10 (rectWH 2 10)
-    , mempty
-    )
 
 headLampShape :: Shape
 headLampShape =

src/Dodge/Item/Grammar.hs

@@ -9,7 +9,7 @@ module Dodge.Item.Grammar (
 
 import Dodge.Item.Orientation
 --import qualified Linear.Quaternion as Q
-import Geometry.Data
+--import Geometry.Data
 import Control.Applicative
 import Data.Bifunctor
 
@@ -60,8 +60,6 @@ basePartiallyComposedItem' itm = case itm ^. itType of
 --    _ -> 
   where
     noa x y = (x, ILink y orientAttachment)
-    c x y _ _ _ = Just (x,y)
---    rhs = Q.axisAngle (V3 1 0 0) 0
     nolinks x = (itm,x, LTest (const Nothing) (const Nothing))
     isolate = (itm,UncomposableIsolateSF, LTest (const Nothing) (const Nothing))
 

src/Dodge/Item/Weapon.hs

@@ -2,8 +2,6 @@
 module Dodge.Item.Weapon (
     module Dodge.Item.Weapon.TriggerType,
     module Dodge.Item.Weapon.ExtraEffect,
---    module Dodge.Item.Weapon.Remote,
-    module Dodge.Item.Weapon.Grenade,
     module Dodge.Item.Weapon.Spawn,
     module Dodge.Item.Weapon.Radar,
     module Dodge.Item.Weapon.Utility,
@@ -14,7 +12,6 @@ module Dodge.Item.Weapon (
 import Dodge.Item.Weapon.BatteryGuns
 import Dodge.Item.Weapon.Drone
 import Dodge.Item.Weapon.ExtraEffect
-import Dodge.Item.Weapon.Grenade
 import Dodge.Item.Weapon.Radar
 import Dodge.Item.Weapon.Spawn
 import Dodge.Item.Weapon.TriggerType

src/Dodge/Item/Weapon/Drone.hs

@@ -20,12 +20,11 @@ droneLauncher =
         & itType .~ HELD DRONELAUNCHER
 
 lasDronesPic :: Item -> SPic
-lasDronesPic _ =
+lasDronesPic _ = noPic
     ( colorSH chartreuse $
         prismPoly Small Typical
             (map (+.+.+ V3 10 0 4.5) $ polyCircx 4 5)
             (map (+.+.+ V3 (-10) 0 4.5) $ polyCircx 4 5)
-    , mempty
     )
 
 aDroneWithItemParams ::

src/Dodge/Item/Weapon/Grenade.hs

@@ -1,272 +0,0 @@
-module Dodge.Item.Weapon.Grenade where
-import Dodge.Data
-import Picture
-import Geometry
-import ShapePicture
-import Shape
-
---grenade :: Item
---grenade = Item
---    { _itName = "GRENADE " ++ show fuseTime
---    , _itType = GRENADE 
---    , _itInvSize = 1
---    , _itDimension = defaultItemDimension
---    , _itCurseStatus = Uncursed
---    , _itConsumption = ItemItselfConsumable 1
-----    , _itMaxStack = 8
---    , _itFloorPict = \_ -> (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
---    , _twMaxRange = 150
---    , _twAccuracy = 30
---    , _itUse = ruseRate 25  (\_ -> throwGrenade makeExplosionAt) upHammer
---        [ useTimeCheck
---        ]
---        & useAim . aimZoom .~ defaultItZoom {_itZoomMax = f fuseTime, _itZoomMin = f fuseTime}
-----    , _itZoom       = defaultItZoom
---    , _itEquipPict = pictureWeaponOnAim' $ \_ -> grenadePic fuseTime
---    , _itID = Nothing
---    , _itAttachment = ItFuse fuseTime
---    , _itInvColor = white
---    , _itInvDisplay = basicItemDisplay
---    , _itEffect = NoItEffect
---    , _itScroll = changeFuse
---    }
---  where 
---    fuseTime = 50
---    f x = 50 / fromIntegral x
-
---moveGrenade :: Prop -> World -> World
---moveGrenade pj w
---    | _pjTimer pj <= 0 = w 
---        & props %~ IM.delete pID 
---        & _pjPayload pj (_prPos (_props w IM.! pID)) 
---                                                            -- this should maybe
---                                                            -- be wallsAlongLine
---                                                            -- or something vvv
---    | otherwise = case bounceBall 1 oldPos newPos 4 $ wlsNearPoint newPos w of
---        Nothing -> w & props . ix pID %~ normalUpdate
---        Just (p,v)  -> w
---            & soundStart (Tap 0) p tapQuietS Nothing
---            & props . ix pID %~ ( ( prPos .~ p ) . ( pjTimer -~ 1 ) . (pjVel .~ v) )
---  where 
---    pID = _pjID pj
---    normalUpdate = (pjTimer -~ 1) 
---        . (pjZ %~ (max 0 . (+ _pjVelZ pj))) 
---        . (pjVelZ -~ 0.1)
---        . ( prPos .~ newPos )
---    oldPos = _prPos pj
---    newPos = _pjVel pj +.+ oldPos
-
-grenadePic :: Int -> SPic
-grenadePic time = 
-    ( colorSH (dark $ dark green) $ upperPrismPolyHalf Small Typical 5 $ polyCirc 3 5
-    , color green $ arc (degToRad $ (179 * fromIntegral time / 50) - 180 ) 
-                            (degToRad $ 180 - (179 * fromIntegral time / 50) ) 
-                            5
-    )
-
---grenadeDraw :: Float -> Prop -> SPic
---grenadeDraw dir prop = translateSPz (_pjZ prop) $ uncurryV translateSPf (_prPos prop) 
---    $ rotateSP dir $ grenadePic $ _pjTimer prop
-
---throwGrenade 
---    :: (Point2 -> World -> World)   -- ^ Payload
---    -> Creature
---    -> World 
---    -> World
---throwGrenade thePayload cr w = setWp $ removePict $ over props addG w
---  where 
---    n = _crID cr
---    addG = IM.insert i $ Bomb 
---        { _prPos = p
---        , _pjZ = 10
---        , _pjVelZ = 2
---        , _pjVel = v
---        , _prDraw = grenadeDraw dir
---        , _pjID = i
---        , _pjUpdate = moveGrenade
---        , _pjPayload = thePayload
---        , _pjTimer   = fuseTime
---        }
---    j = crSel cr
---    removePict = id -- set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> (,) emptySH blank
---    i = IM.newKey $ _props w
---    v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w)
---    v | magV v' > 6 = 6 *.* normalizeV v'
---      | otherwise   = v'
---    p' = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr) 0)
---    p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr-4) 0)
---      | otherwise             = p'
---    dir = argV v 
---    setWp :: World -> World
---    setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20
---    fuseTime = _atFuseTime $ _itAttachment $ _crInv cr IM.! j
-
---throwArmReset :: Int -> ItEffect
---throwArmReset x = ItInvEffect {_ieInv = f ,_ieCounter = x }
---  where 
---    f itm cr = creatures . ix (_crID cr) . crInv %~ IM.adjust counterDown i
---      where
---        i = _ipInvID $ _itPos itm
---    counterDown it 
---        | _ieCounter (_itEffect it) == 0 = it 
---            & itUse . useHammer .~ HammerUp 
-----            & itEquipPict .~ pictureWeaponAim (\_ -> grenadePic 50)
---        | otherwise = it & itEffect . ieCounter -~ 1
-
---flameGrenade :: Item
---flameGrenade = grenade {
---     _itName = "FLMGREN " ++ show fuseTime
---     , _itUse = \_ -> throwGrenade makeFlameExplosionAt
---    }
---  where 
---    fuseTime = 50 :: Int
---
---teslaGrenade :: Item
---teslaGrenade = grenade {
---     _itName = "TLSGREN " ++ show fuseTime
---     , _itUse = \_ -> throwGrenade makeTeslaExplosionAt
---    }
---  where 
---    fuseTime = 50 :: Int
---
---retireRemoteBomb :: Int -> Int -> Int -> World -> World
---retireRemoteBomb itid 0 pjid w = w
---    & pointToItem (_itemPositions w IM.! itid) %~ 
---        ( (itAttachment . scopePos .~ V2 0 0)
---        . (itZoom .~ defaultItZoom)
---        . (itUse .~ const throwRemoteBomb)
---        )
---    & props %~ IM.delete pjid
---retireRemoteBomb itid t pjid w = setScope w 
---    & props . ix pjid . pjUpdate .~ (\_ -> retireRemoteBomb itid (t-1) pjid)
---  where
---    setScope w' = case _itemPositions w' IM.! itid of
---        InInv cid invid -> w' 
---            & creatures . ix cid . crInv . ix invid . itAttachment 
---                    . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
---        _   -> w'
---    pos = fromMaybe (V2 0 0) $ w ^? props . ix pjid . pjPos
-
--- TODO hive out movement and share with moveGrenade
---moveRemoteBomb :: Int -> Int -> Int -> World -> World
---moveRemoteBomb itid time pID w 
---    | time < -4 = updatePicture
---                $ set (props .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (f time) pID)
---                    w
---    | time < 2 = case hitWl of
---            Just (p,_) -> soundStart (Tap 0) p tapQuietS Nothing $ halfV updatedWorld
---            _      -> halfV updatedWorld
---    | otherwise = case hitWl of
---            Just (p,_) -> soundStart (Tap 0) p tapQuietS Nothing updatedWorld
---            _      -> updatedWorld
---  where 
---    updatedWorld = w
---        & updateV 
---        & props . ix pID . prPos .~ finalPos
---        & updatePicture
---        & props . ix pID . pjUpdate .~ (\_ -> moveRemoteBomb itid (time-1) pID)
---    pj     = _props w IM.! pID
---    oldPos = _prPos pj
---    newPos = _pjVel pj +.+ oldPos
---    -- this is hacky, should use a version of collidePointWalls' that collides
---    -- circles and walls
---    invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
---    hitWl  = bounceBall 1 oldPos newPos 4 $ wlsNearPoint newPos w
---    finalPos = maybe newPos (invShift . fst) hitWl
---    setV v = set (props . ix pID . pjVel) v
---    updateV = maybe id (setV . snd) hitWl
---    halfV = props . ix pID . pjVel %~ (0.5 *.*)
---    f x | x < -369 = -10
---        | otherwise = x - 1
---    updatePicture = 
---        set (props . ix pID . prDraw)
---            (\_ -> (,) mempty $ setDepth 20 $ uncurryV translate newPos $ remoteBombPic time)
-
-
-
---defaultThrowable :: Item
---defaultThrowable = grenade
---remoteBomb :: Item
---remoteBomb = defaultThrowable
---    { _itName = "REMOTEBOMB"
---    , _itType = REMOTEBOMB
---    , _itMaxStack = 1
---    , _itFloorPict = \_ -> (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2 
---        [(-3,-3),(-3,3),(3,3),(3,-3)]
---    , _twMaxRange = 150
---    , _twAccuracy = 30
---    , _itUse = ruseRate 25 (const throwRemoteBomb) upHammer
---        [ hammerCheckI ]
---    , _itAttachment = ItScope (V2 0 0) 0 1 True
---    , _itEquipPict = pictureWeaponOnAim' $ \_ -> (,) emptySH remoteBombUnarmedPic
---    }
-
-
-throwRemoteBomb :: Creature -> World -> World
-throwRemoteBomb = undefined
---throwRemoteBomb cr w = undefined
---    setLocation 
---    $ removePict 
---    $ resetFire 
-----    $ resetName 
---    $ over props addG w
---  where 
---    cid = _crID cr
---    addG = IM.insert i $ Projectile 
---        { _prPos = p
---        , _pjStartPos = p
---        , _pjVel = v
---        , _prDraw = const mempty
---        , _pjID = i
---        , _pjUpdate = \_ -> moveRemoteBomb itid 50 i
---        }
---    i = IM.newKey $ _props w
---    v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w)
---    v   | magV v' > 6 = 6 *.* normalizeV v'
---        | otherwise   = v'
---    j = crSel cr
-----    resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTE"
---    removePict = id -- set (creatures . ix cid . crInv . ix j . itEquipPict) $ \ _ _ -> mempty
---    resetFire = set (creatures . ix cid . crInv . ix j . itUse . rUse) 
---        $ \_ -> explodeRemoteBomb itid i
---    p' = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr) 0)
---    p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr-4) 0)
---      | otherwise             = p'
---    maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
---    setLocation :: World -> World
---    setLocation w' = case maybeitid of
---        Nothing -> w' & creatures . ix cid . crInv . ix j . itID ?~ newitid
---                      & itemPositions %~ IM.insert newitid (InInv cid j)
---        _ -> w'
---    newitid = IM.newKey $ _itemPositions w
---    itid = fromMaybe newitid maybeitid
-
---explodeRemoteBomb :: Int -> Int -> Creature -> World -> World
---explodeRemoteBomb itid pjid cr w
---    = set (props . ix pjid . pjUpdate) (\_ -> retireRemoteBomb itid 30 pjid)
-----        $ set (props . ix pjid . pjDraw) (\_ -> blank)
---        $ set (creatures . ix cid . crInv . ix j . itUse . rUse) (\_ -> const id)
-----        $ resetName
---        $ resetPict
-----        $ resetScope
---        $ makeExplosionAt (_prPos (_props w IM.! pjid)) w
---        -- - $ makeShrapnelBombAt (_pjPos (_props w IM.! pjid)) w
---  where 
---    cid = _crID cr
-----    resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEBOMB"
---    resetPict = id --set (creatures . ix cid . crInv . ix j . itEquipPict ) 
---                   -- (pictureWeaponAim $ \_ -> (,) emptySH remoteBombUnarmedPic)
-----    resetScope = creatures . ix cid . crInv . ix j . itScope . _Just . scopePos .~ (0,0)
---    j = crSel $ _creatures w IM.! cid
---remoteBombPic 
---    :: Int -- ^ time
---    -> Picture
---remoteBombPic _ = pictures 
---    [ color (dark $ dark orange) $ circleSolid 5
---    ]
-
-remoteBombUnarmedPic :: Picture
-remoteBombUnarmedPic = color (dark $ dark orange) $ circleSolid 5
-
---retireRemoteBomb :: Int -> Int -> Int -> World -> World
---retireRemoteBomb = retireRemoteProj $ const throwRemoteBomb

src/Dodge/LevelGen/Switch.hs

@@ -30,12 +30,12 @@ drawSwitchWire col1 col2 bt
     | _btState bt == BtOff = flick $ pi/4
     | otherwise = flick (negate (pi/4))
   where
-    flick a = ( mconcat
+    flick a = noPic ( mconcat
         [ colorSH col1 . translateSHz 10 . upperBox Small Typical 10 $ reverse $ rectNSWE (-2) (-5) (-10) 10
         , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperBox Small Typical 2 . reverse 
             $ rectNSWE 10 0 (-2) 2
         ]   
-        , mempty)
+        )
 
 makeSwitchSPic
     :: ButtonDraw

src/Dodge/Projectile/Draw.hs

@@ -2,6 +2,7 @@ module Dodge.Projectile.Draw
     ( drawProjectile
     ) where
 
+import Data.Strict.Tuple
 import Dodge.Data.Item.Use.Consumption.Ammo
 import Dodge.Data.Projectile
 import Geometry
@@ -40,6 +41,5 @@ drawRemoteShell pj
 
 remoteShellShape :: Color -> SPic
 remoteShellShape col =
-    ( shellShape
+     shellShape
-    , setLayer BloomNoZWrite . setDepth 4.5 . color col $ circleSolid 3
+    :!: ( setLayer BloomNoZWrite . setDepth 4.5 . color col $ circleSolid 3)
-    )

src/Dodge/Prop/Draw.hs

@@ -15,7 +15,7 @@ drawProp' pr = drawProp (_prDraw pr) pr
 drawProp :: PropDraw -> Prop -> SPic
 drawProp pd = case pd of
     PropDrawSPic spic -> const spic
-    PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (fst $ drawProp pd' pr)
+    PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (drawProp pd' pr)
     PropDrawMovingShapeCol sh -> (`drawMovingShapeCol` sh)
     PropDoubleLampCover h -> drawDoubleLampCover h
     PropVerticalLampCover h -> drawVerticalLampCover h
@@ -42,7 +42,7 @@ propDrawToggle pd pr
     | otherwise = drawProp pd pr
 
 drawLampCover :: Float -> Prop -> SPic
-drawLampCover h pr =
+drawLampCover h pr = noPic
     ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
         rotateSH (_prRot pr) $
             mconcat
@@ -52,28 +52,25 @@ drawLampCover h pr =
                 , aface 2 (-1) 2
                 , upperPrismPoly Small Essential 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)]
                 ]
-    , mempty
     )
   where
     aface ztran s w = translateSHz ztran . upperPrismPoly Small Essential 1
         . reverse $ rectNSWE 3 s w 3
 
 drawVerticalLampCover :: Float -> Prop -> SPic
-drawVerticalLampCover h pr =
+drawVerticalLampCover h pr = noPic
     ( translateSHz h . uncurryV translateSHxy (_prPos pr) $
         rotateSHx (_prRot pr) $
             mconcat
                 [ translateSHz (-3) . upperPrismPoly Small Essential 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
                 ]
-    , mempty
     )
 
-drawMovingShape :: Prop -> Shape -> SPic
+drawMovingShape :: Prop -> SPic -> SPic
 drawMovingShape pr =
-    noPic
+        translateSPz (_prPosZ pr)
-        . translateSHz (_prPosZ pr)
+        . uncurryV translateSPxy (_prPos pr)
-        . uncurryV translateSHxy (_prPos pr)
+        . overPosSP (Q.rotate (_prQuat pr))
-        . overPosSH (Q.rotate (_prQuat pr))
 
 drawMovingShapeCol :: Prop -> Shape -> SPic
 drawMovingShapeCol pr =
@@ -84,7 +81,7 @@ drawMovingShapeCol pr =
         . colorSH (_prColor pr)
 
 drawDoubleLampCover :: Float -> Prop -> SPic
-drawDoubleLampCover h pr =
+drawDoubleLampCover h pr = noPic
     ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
         rotateSH (_prRot pr) $
             mconcat
@@ -93,5 +90,4 @@ drawDoubleLampCover h pr =
                 , upperPrismPoly Small Essential 1 [V2 0 (-1), V2 6 5, V2 (-6) 5]
                 , upperPrismPoly Small Essential 1 [V2 0 1, V2 (-6) (-5), V2 6 (-5)]
                 ]
-    , mempty
     )

src/Dodge/Render.hs

@@ -62,7 +62,9 @@ doDrawing' win pdata u = do
     -- count mutable vectors setup
     layerCounts <- UMV.replicate (numLayers * 6) 0
     -- attempt to poke in parallel
-    let (ws, wp) = wallSPics <> worldSPic cfig u
+    let wswp = wallSPics <> worldSPic cfig u
+        ws = wswp ^. _1
+        wp = wswp ^. _2
     ((nWins, trueNWalls), (nShapeVs, nIndices, nSilIndices)) <-
         MP.bindM3
             (\_ a b -> return (a, b))

src/Dodge/Render/ShapePicture.hs

@@ -2,6 +2,7 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
+import Data.Strict.Tuple
 import Control.Applicative
 import Dodge.Data.DoubleTree
 import Dodge.Data.ComposedItem
@@ -28,7 +29,7 @@ import ShapePicture
 
 worldSPic :: Configuration -> Universe -> SPic
 worldSPic cfig u =
-    (mempty, extraPics cfig u)
+    (mempty :!: extraPics cfig u)
         <> foldup drawProp' (filtOn _prPos _props)
         <> foldup drawProjectile (filtOn _prjPos _projectiles)
         <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
@@ -82,7 +83,7 @@ anyTargeting w = fromMaybe mempty $ do
     ttree <- lookup WeaponTargetingLink (itmtree ^. ldtRight)
     _ <- lookup AugmentedHUDLink (ttree ^. ldtLeft)
         <|> lookup AugmentedHUDLink (ttree ^. ldtRight)
-    return (mempty , drawTargeting (ttree ^. ldtValue) w)
+    return . noShape $ drawTargeting (ttree ^. ldtValue) w
     
 drawCreature :: Creature -> SPic
 drawCreature cr = case _crType cr of
@@ -102,13 +103,12 @@ drawCreature cr = case _crType cr of
 
 lampCrSPic :: Float -> SPic
 lampCrSPic h =
-    ( colorSH blue . upperBox Small Typical h $ rectWH 5 5
+    ( colorSH blue . upperBox Small Typical h $ rectWH 5 5)
-    , setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
+    :!: (setLayer BloomLayer (setDepth h . color white $ circleSolid 3))
-    )
 
 picAtCrPos1 :: Picture -> Creature -> SPic
 --{-# INLINE picAtCrPos #-}
-picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic
+picAtCrPos1 thePic cr = (:!:) mempty $ tranRot (_crPos cr) (_crDir cr) thePic
 
 shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
 shiftDraw fpos fdir fdraw x =

src/Dodge/Wall/Draw.hs

@@ -9,12 +9,9 @@ drawWall wd = case wd of
     DrawForceField -> drawForceField
 
 drawForceField :: Wall -> SPic
-drawForceField wl =
+drawForceField wl = noShape . setLayer BloomLayer
-    ( mempty
-    , setLayer BloomLayer
         . setDepth 20
         . color (_wlColor wl)
         $ thickLine 5 [a, b]
-    )
   where
     (a, b) = _wlLine wl

src/ShapePicture.hs

@@ -13,22 +13,23 @@ module ShapePicture
 --    , mirrorSPxz
     , overPosSP
     ) where
+
 import ShapePicture.Data
 import Shape
 import Picture
 import Geometry
-
+import Data.Strict.Tuple
 import Data.Bifunctor
 --import Control.Lens
 
 -- should all this be inlined/inlinable?
 noPic :: Shape -> SPic
 {-# INLINE noPic #-}
-noPic = (,mempty)
+noPic = (:!: mempty)
 
 noShape :: Picture -> SPic
 {-# INLINE noShape #-}
-noShape = (mempty,)
+noShape = (mempty :!:)
 
 --_spShape :: SPic -> Shape
 --_spShape = fst

src/ShapePicture/Data.hs

@@ -1,4 +1,7 @@
 module ShapePicture.Data where
+
+import Data.Strict.Tuple
 import Picture.Data
 import Shape.Data
-type SPic =  (Shape, Picture)
+
+type SPic = Pair Shape Picture