diff --git a/ghcidOutput b/ghcidOutput index 6e700010e..87e88579c 100644 --- a/ghcidOutput +++ b/ghcidOutput @@ -1,20 +1 @@ -/home/justin/Haskell/loop/src/Dodge/Item/Draw/SPic.hs:69:5-6: warning: [-Wunused-local-binds] - 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) - | ^ +All good (605 modules, at 01:05:43) diff --git a/package.yaml b/package.yaml index 0c1c30453..0c3d3fefd 100644 --- a/package.yaml +++ b/package.yaml @@ -40,6 +40,7 @@ dependencies: - random - sdl2 - sdl2-mixer +- strict - template-haskell - transformers - unordered-containers diff --git a/src/Dodge/Button/Draw.hs b/src/Dodge/Button/Draw.hs index 0f81963cb..959e016d7 100644 --- a/src/Dodge/Button/Draw.hs +++ b/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 diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 01da4f4a6..8841a6697 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/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 diff --git a/src/Dodge/Item/Draw/SPic.hs b/src/Dodge/Item/Draw/SPic.hs index 2de48f163..bc18ff486 100644 --- a/src/Dodge/Item/Draw/SPic.hs +++ b/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) - , mempty + CHEMFUELPOUCH -> noPic $ colorSH yellow (upperPrismPolyST 3 $ polyCirc 3 5) -- , 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 rs = fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs) - -fractionLoadedAmmo2 :: ReloadStatus -> Float -fractionLoadedAmmo2 rs = - 1 - (1 - fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs)) ** 2 +--fractionLoadedAmmo :: ReloadStatus -> Float +--fractionLoadedAmmo rs = fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs) +-- +--fractionLoadedAmmo2 :: ReloadStatus -> Float +--fractionLoadedAmmo2 rs = +-- 1 - (1 - fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs)) ** 2 equipItemSPic :: EquipItemType -> Item -> SPic equipItemSPic et _ = case et of MAGSHIELD -> defSPic FLAMESHIELD -> defSPic - FRONTARMOUR -> - ( mempty - , setDepth 20 $ - fold - [ color yellow $ thickArc 0 (pi / 2) 10 5 - , color yellow $ thickArc (3 * pi / 2) (2 * pi) 10 5 - ] - ) + FRONTARMOUR -> defSPic +-- ( mempty +-- , setDepth 20 $ +-- fold +-- [ color yellow $ thickArc 0 (pi / 2) 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 - MACHINEPISTOL -> noPic $ baseStickShape <> addTinClip it - AUTOPISTOL -> noPic $ baseStickShape <> addTinClip it - SMG -> noPic $ baseSMGShape <> addTinClip it + PISTOL -> noPic $ baseStickShape + MACHINEPISTOL -> noPic $ baseStickShape + AUTOPISTOL -> noPic $ baseStickShape + 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 - BURSTRIFLE -> noPic $ baseRifleShape <> addTinClip it + AUTORIFLE -> noPic $ baseRifleShape + BURSTRIFLE -> noPic $ baseRifleShape BANGROD -> noPic baseRodShape -- <> addBullets it ELEPHANTGUN -> noPic baseAMRShape -- <> addBullets it - AMR -> noPic $ baseAMRShape <> addTinClip it - AUTOAMR -> noPic $ baseAMRShape <> addTinClip it + AMR -> noPic $ baseAMRShape + 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 _ = - ( 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 +flamerPic _ = noPic . colorSH yellow $ xCylinderST 5 18 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) - , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 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 amFrac = 0.5 @@ -527,10 +417,7 @@ tractorGunPic :: Item -> SPic tractorGunPic = lasGunPic flatShieldEquipSPic :: SPic -flatShieldEquipSPic = - ( colorSH yellow $ upperBoxMT 10 (rectWH 2 10) - , mempty - ) +flatShieldEquipSPic = noPic . colorSH yellow $ upperBoxMT 10 (rectWH 2 10) headLampShape :: Shape headLampShape = diff --git a/src/Dodge/Item/Grammar.hs b/src/Dodge/Item/Grammar.hs index 9d03e1795..e2074686d 100644 --- a/src/Dodge/Item/Grammar.hs +++ b/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)) diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 92ab95e16..6e935f3ef 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/Drone.hs b/src/Dodge/Item/Weapon/Drone.hs index c1a88cae5..722ae6df2 100644 --- a/src/Dodge/Item/Weapon/Drone.hs +++ b/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 :: diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs deleted file mode 100644 index 0d5170008..000000000 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ /dev/null @@ -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 diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index d10897437..816f6216a 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/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 diff --git a/src/Dodge/Projectile/Draw.hs b/src/Dodge/Projectile/Draw.hs index 1967fe879..5dfdb7072 100644 --- a/src/Dodge/Projectile/Draw.hs +++ b/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 - , setLayer BloomNoZWrite . setDepth 4.5 . color col $ circleSolid 3 - ) + shellShape + :!: ( setLayer BloomNoZWrite . setDepth 4.5 . color col $ circleSolid 3) diff --git a/src/Dodge/Prop/Draw.hs b/src/Dodge/Prop/Draw.hs index f36473084..90ffc1377 100644 --- a/src/Dodge/Prop/Draw.hs +++ b/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 - . translateSHz (_prPosZ pr) - . uncurryV translateSHxy (_prPos pr) - . overPosSH (Q.rotate (_prQuat pr)) + translateSPz (_prPosZ pr) + . uncurryV translateSPxy (_prPos pr) + . overPosSP (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 ) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 5d7e5f95a..8b4696c0f 100644 --- a/src/Dodge/Render.hs +++ b/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)) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index ffcff1788..9aab6011e 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ 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 - , 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 #-} -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 = diff --git a/src/Dodge/Wall/Draw.hs b/src/Dodge/Wall/Draw.hs index 5bfaf89ba..63825fc2f 100644 --- a/src/Dodge/Wall/Draw.hs +++ b/src/Dodge/Wall/Draw.hs @@ -9,12 +9,9 @@ drawWall wd = case wd of DrawForceField -> drawForceField drawForceField :: Wall -> SPic -drawForceField wl = - ( mempty - , setLayer BloomLayer +drawForceField wl = noShape . setLayer BloomLayer . setDepth 20 . color (_wlColor wl) $ thickLine 5 [a, b] - ) where (a, b) = _wlLine wl diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index 4596c1621..963cc64c5 100644 --- a/src/ShapePicture.hs +++ b/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 diff --git a/src/ShapePicture/Data.hs b/src/ShapePicture/Data.hs index 8abbd9a00..eaa0381d9 100644 --- a/src/ShapePicture/Data.hs +++ b/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