justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Use strict tuples for SPics

Browse Source
This commit is contained in:
justin
2024-10-01 01:20:29 +01:00
parent a98ec80f59
commit 5a4f2711c8
17 changed files with 69 additions and 481 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ghcidOutput
+1 -20
View File
@@ -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
+1
View File
@@ -40,6 +40,7 @@ dependencies:
- random - random
- sdl2 - sdl2
- sdl2-mixer - sdl2-mixer
- strict
- template-haskell - template-haskell
- transformers - transformers
- unordered-containers - unordered-containers
src/Dodge/Button/Draw.hs
+2 -4
View File
@@ -17,20 +17,18 @@ drawSwitch col1 col2 bt
| _btState bt == BtOff = flick $ pi / 4 | _btState bt == BtOff = flick $ pi / 4
| otherwise = flick (negate (pi / 4)) | otherwise = flick (negate (pi / 4))
where where
flick a = flick a = noPic
( mconcat ( mconcat
[ colorSH col1 . upperBox Small Typical 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10 [ 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 $ , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperBox Small Typical 2 $
reverse $ reverse $
rectNSWE 10 0 (-2) 2 rectNSWE 10 0 (-2) 2
] ]
, mempty
) )
defaultDrawButton :: Color -> Button -> SPic defaultDrawButton :: Color -> Button -> SPic
defaultDrawButton col bt = defaultDrawButton col bt = noPic
( translateSHz 15 . colorSH col $ upperBox Small Typical 5 buttonGeometry ( translateSHz 15 . colorSH col $ upperBox Small Typical 5 buttonGeometry
, mempty
) )
where where
buttonGeometry buttonGeometry
src/Dodge/Creature/Picture.hs
+2 -2
View File
@@ -25,7 +25,7 @@ import ShapePicture
basicCrPict :: Creature -> SPic basicCrPict :: Creature -> SPic
basicCrPict cr = uncurryV translateSPxy (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) basicCrPict cr = uncurryV translateSPxy (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
<> (basicCrShape cr, mempty) <> noPic (basicCrShape cr)
--testShape :: Shape --testShape :: Shape
--testShape = translateSHz 10 . rotateSHx 1 . upperCylinder 20 $ polyCirc 2 10 --testShape = translateSHz 10 . rotateSHx 1 . upperCylinder 20 $ polyCirc 2 10
@@ -103,7 +103,7 @@ deadFeet = feet
arms :: Creature -> Shape arms :: Creature -> Shape
{-# INLINE arms #-} {-# INLINE arms #-}
arms cr = arms cr =
fst $ (^. _1) $
translateToRightHand cr aHand translateToRightHand cr aHand
<> translateToLeftHand cr aHand <> translateToLeftHand cr aHand
where where
src/Dodge/Item/Draw/SPic.hs
+30 -143
View File
@@ -5,6 +5,7 @@ module Dodge.Item.Draw.SPic (
itemTreeSPic, itemTreeSPic,
) where ) where
import Data.Strict.Tuple
import Data.Maybe import Data.Maybe
import qualified Linear.Quaternion as Q import qualified Linear.Quaternion as Q
import Dodge.Data.ComposedItem import Dodge.Data.ComposedItem
@@ -58,35 +59,33 @@ ammoMagSPic :: Item -> AmmoMagType -> SPic
ammoMagSPic it = \case ammoMagSPic it = \case
TINMAG -> noPic $ upperPrismPolyTS 1 (reverse $ rectNSWE 0 (- y) (-1) 1) TINMAG -> noPic $ upperPrismPolyTS 1 (reverse $ rectNSWE 0 (- y) (-1) 1)
DRUMMAG -> 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) -- , setLayer MidLayer . color black $ translate3 (V3 0 0 4) $ circleSolid (5 * am)
)
_ -> noPic $ upperPrismPolyTS 1 (reverse $ rectNSWE 0 (- y) (-1) 1) _ -> noPic $ upperPrismPolyTS 1 (reverse $ rectNSWE 0 (- y) (-1) 1)
where where
y = fromIntegral y' * 0.3 y = fromIntegral y' * 0.3
y' = fromMaybe 0 $ it ^? itUse . amagLoadStatus . iaLoaded 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 :: EquipItemType -> Item -> SPic
equipItemSPic et _ = case et of equipItemSPic et _ = case et of
MAGSHIELD -> defSPic MAGSHIELD -> defSPic
FLAMESHIELD -> 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 WRISTARMOUR -> defSPic
INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPolySI 3 $ rectWH 2 2) INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPolySI 3 $ rectWH 2 2)
BRAINHAT -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4) BRAINHAT -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4)
@@ -198,10 +197,10 @@ heldItemSPic ht it = case ht of
FORCEFIELDGUN -> defSPic FORCEFIELDGUN -> defSPic
TORCH -> noPic torchShape TORCH -> noPic torchShape
BANGSTICK i -> noPic $ baseStickShapeX it i -- <> addBullets it 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 BANGCONE -> noPic $ bangConeShape 5
BLUNDERBUSS -> noPic $ bangConeShape 20 BLUNDERBUSS -> noPic $ bangConeShape 20
GRAPECANNON _ -> noPic $ bangConeShape 20 GRAPECANNON _ -> noPic $ bangConeShape 20
@@ -209,12 +208,12 @@ heldItemSPic ht it = case ht of
VOLLEYGUN i -> noPic $ volleyGunShape i -- <> addBullets it VOLLEYGUN i -> noPic $ volleyGunShape i -- <> addBullets it
RIFLE -> noPic baseRifleShape -- <> addBullets it RIFLE -> noPic baseRifleShape -- <> addBullets it
-- REPEATER -> noPic $ baseRifleShape <> addTinClip 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 BANGROD -> noPic baseRodShape -- <> addBullets it
ELEPHANTGUN -> noPic baseAMRShape -- <> 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 SNIPERRIFLE -> noPic baseAMRShape -- <> addBullets it
-- MACHINEGUN -> noPic $ baseAMRShape <> addTinClip it -- MACHINEGUN -> noPic $ baseAMRShape <> addTinClip it
FLAMESPITTER -> flamerPic it FLAMESPITTER -> flamerPic it
@@ -290,97 +289,8 @@ baseCaneShape :: Shape
baseCaneShape = colorSH red $ xCylinderST 3 15 baseCaneShape = colorSH red $ xCylinderST 3 15
baseRifleShape :: Shape 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 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 :: BulletEffect -> Color
--bulletEffectColor x = case x of --bulletEffectColor x = case x of
-- DestroyBullet -> black -- DestroyBullet -> black
@@ -428,12 +338,9 @@ miniGunXPictItem i it = miniGunXPict i spin
+ _warmTime (_heldDelay $ _itUse it) + _warmTime (_heldDelay $ _itUse it)
miniGunXPict :: Int -> Int -> SPic miniGunXPict :: Int -> Int -> SPic
miniGunXPict i spin = miniGunXPict i spin = noPic
( colorSH red (rotateSHx a barrels) ( colorSH red (rotateSHx a barrels)
<> baseRifleShape <> baseRifleShape
, -- <> clip (-1) 0
-- <> clip (-7) 0
mempty
) )
where where
aBarrel = translateSH (V3 15 2 2) baseCaneShape aBarrel = translateSH (V3 15 2 2) baseCaneShape
@@ -452,22 +359,7 @@ baseSMGShape :: Shape
baseSMGShape = colorSH green $ xCylinderST 3 20 baseSMGShape = colorSH green $ xCylinderST 3 20
flamerPic :: Item -> SPic 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 :: Item -> SPic
launcherPic _ = noPic . colorSH cyan $ xCylinderST 5 20 launcherPic _ = noPic . colorSH cyan $ xCylinderST 5 20
@@ -496,14 +388,12 @@ teslaGunPic =
xb = 9 xb = 9
lasGunPic :: Item -> SPic lasGunPic :: Item -> SPic
--lasGunPic it =
lasGunPic _ = lasGunPic _ =
( colorSH blue $ ( colorSH blue $
upperBoxST 4 (rectNESW 3 30 1 0) upperBoxST 4 (rectNESW 3 30 1 0)
<> upperBoxSU 4 (rectNESW (-1) 30 (-3) 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 where
--amFrac = fractionLoadedAmmo it --amFrac = fractionLoadedAmmo it
amFrac = 0.5 amFrac = 0.5
@@ -527,10 +417,7 @@ tractorGunPic :: Item -> SPic
tractorGunPic = lasGunPic tractorGunPic = lasGunPic
flatShieldEquipSPic :: SPic flatShieldEquipSPic :: SPic
flatShieldEquipSPic = flatShieldEquipSPic = noPic . colorSH yellow $ upperBoxMT 10 (rectWH 2 10)
( colorSH yellow $ upperBoxMT 10 (rectWH 2 10)
, mempty
)
headLampShape :: Shape headLampShape :: Shape
headLampShape = headLampShape =
src/Dodge/Item/Grammar.hs
+1 -3
View File
@@ -9,7 +9,7 @@ module Dodge.Item.Grammar (
import Dodge.Item.Orientation import Dodge.Item.Orientation
--import qualified Linear.Quaternion as Q --import qualified Linear.Quaternion as Q
import Geometry.Data --import Geometry.Data
import Control.Applicative import Control.Applicative
import Data.Bifunctor import Data.Bifunctor
@@ -60,8 +60,6 @@ basePartiallyComposedItem' itm = case itm ^. itType of
-- _ -> -- _ ->
where where
noa x y = (x, ILink y orientAttachment) 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)) nolinks x = (itm,x, LTest (const Nothing) (const Nothing))
isolate = (itm,UncomposableIsolateSF, LTest (const Nothing) (const Nothing)) isolate = (itm,UncomposableIsolateSF, LTest (const Nothing) (const Nothing))
src/Dodge/Item/Weapon.hs
-3
View File
@@ -2,8 +2,6 @@
module Dodge.Item.Weapon ( module Dodge.Item.Weapon (
module Dodge.Item.Weapon.TriggerType, module Dodge.Item.Weapon.TriggerType,
module Dodge.Item.Weapon.ExtraEffect, module Dodge.Item.Weapon.ExtraEffect,
-- module Dodge.Item.Weapon.Remote,
module Dodge.Item.Weapon.Grenade,
module Dodge.Item.Weapon.Spawn, module Dodge.Item.Weapon.Spawn,
module Dodge.Item.Weapon.Radar, module Dodge.Item.Weapon.Radar,
module Dodge.Item.Weapon.Utility, module Dodge.Item.Weapon.Utility,
@@ -14,7 +12,6 @@ module Dodge.Item.Weapon (
import Dodge.Item.Weapon.BatteryGuns import Dodge.Item.Weapon.BatteryGuns
import Dodge.Item.Weapon.Drone import Dodge.Item.Weapon.Drone
import Dodge.Item.Weapon.ExtraEffect import Dodge.Item.Weapon.ExtraEffect
import Dodge.Item.Weapon.Grenade
import Dodge.Item.Weapon.Radar import Dodge.Item.Weapon.Radar
import Dodge.Item.Weapon.Spawn import Dodge.Item.Weapon.Spawn
import Dodge.Item.Weapon.TriggerType import Dodge.Item.Weapon.TriggerType
src/Dodge/Item/Weapon/Drone.hs
+1 -2
View File
@@ -20,12 +20,11 @@ droneLauncher =
& itType .~ HELD DRONELAUNCHER & itType .~ HELD DRONELAUNCHER
lasDronesPic :: Item -> SPic lasDronesPic :: Item -> SPic
lasDronesPic _ = lasDronesPic _ = noPic
( colorSH chartreuse $ ( colorSH chartreuse $
prismPoly Small Typical prismPoly Small Typical
(map (+.+.+ V3 10 0 4.5) $ polyCircx 4 5) (map (+.+.+ V3 10 0 4.5) $ polyCircx 4 5)
(map (+.+.+ V3 (-10) 0 4.5) $ polyCircx 4 5) (map (+.+.+ V3 (-10) 0 4.5) $ polyCircx 4 5)
, mempty
) )
aDroneWithItemParams :: aDroneWithItemParams ::
src/Dodge/Item/Weapon/Grenade.hs
-272
View File
@@ -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
+2 -2
View File
@@ -30,12 +30,12 @@ drawSwitchWire col1 col2 bt
| _btState bt == BtOff = flick $ pi/4 | _btState bt == BtOff = flick $ pi/4
| otherwise = flick (negate (pi/4)) | otherwise = flick (negate (pi/4))
where where
flick a = ( mconcat flick a = noPic ( mconcat
[ colorSH col1 . translateSHz 10 . upperBox Small Typical 10 $ reverse $ rectNSWE (-2) (-5) (-10) 10 [ 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 , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperBox Small Typical 2 . reverse
$ rectNSWE 10 0 (-2) 2 $ rectNSWE 10 0 (-2) 2
] ]
, mempty) )
makeSwitchSPic makeSwitchSPic
:: ButtonDraw :: ButtonDraw
src/Dodge/Projectile/Draw.hs
+3 -3
View File
@@ -2,6 +2,7 @@ module Dodge.Projectile.Draw
( drawProjectile ( drawProjectile
) where ) where
import Data.Strict.Tuple
import Dodge.Data.Item.Use.Consumption.Ammo import Dodge.Data.Item.Use.Consumption.Ammo
import Dodge.Data.Projectile import Dodge.Data.Projectile
import Geometry import Geometry
@@ -40,6 +41,5 @@ drawRemoteShell pj
remoteShellShape :: Color -> SPic remoteShellShape :: Color -> SPic
remoteShellShape col = 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
+8 -12
View File
@@ -15,7 +15,7 @@ drawProp' pr = drawProp (_prDraw pr) pr
drawProp :: PropDraw -> Prop -> SPic drawProp :: PropDraw -> Prop -> SPic
drawProp pd = case pd of drawProp pd = case pd of
PropDrawSPic spic -> const spic 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) PropDrawMovingShapeCol sh -> (`drawMovingShapeCol` sh)
PropDoubleLampCover h -> drawDoubleLampCover h PropDoubleLampCover h -> drawDoubleLampCover h
PropVerticalLampCover h -> drawVerticalLampCover h PropVerticalLampCover h -> drawVerticalLampCover h
@@ -42,7 +42,7 @@ propDrawToggle pd pr
| otherwise = drawProp pd pr | otherwise = drawProp pd pr
drawLampCover :: Float -> Prop -> SPic drawLampCover :: Float -> Prop -> SPic
drawLampCover h pr = drawLampCover h pr = noPic
( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $ ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
rotateSH (_prRot pr) $ rotateSH (_prRot pr) $
mconcat mconcat
@@ -52,28 +52,25 @@ drawLampCover h pr =
, aface 2 (-1) 2 , aface 2 (-1) 2
, upperPrismPoly Small Essential 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)] , upperPrismPoly Small Essential 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)]
] ]
, mempty
) )
where where
aface ztran s w = translateSHz ztran . upperPrismPoly Small Essential 1 aface ztran s w = translateSHz ztran . upperPrismPoly Small Essential 1
. reverse $ rectNSWE 3 s w 3 . reverse $ rectNSWE 3 s w 3
drawVerticalLampCover :: Float -> Prop -> SPic drawVerticalLampCover :: Float -> Prop -> SPic
drawVerticalLampCover h pr = drawVerticalLampCover h pr = noPic
( translateSHz h . uncurryV translateSHxy (_prPos pr) $ ( translateSHz h . uncurryV translateSHxy (_prPos pr) $
rotateSHx (_prRot pr) $ rotateSHx (_prRot pr) $
mconcat mconcat
[ translateSHz (-3) . upperPrismPoly Small Essential 1 $ reverse $ rectNSWE 2 (-2) (-5) 5 [ translateSHz (-3) . upperPrismPoly Small Essential 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
] ]
, mempty
) )
drawMovingShape :: Prop -> Shape -> SPic drawMovingShape :: Prop -> SPic -> SPic
drawMovingShape pr = 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 :: Prop -> Shape -> SPic
drawMovingShapeCol pr = drawMovingShapeCol pr =
@@ -84,7 +81,7 @@ drawMovingShapeCol pr =
. colorSH (_prColor pr) . colorSH (_prColor pr)
drawDoubleLampCover :: Float -> Prop -> SPic drawDoubleLampCover :: Float -> Prop -> SPic
drawDoubleLampCover h pr = drawDoubleLampCover h pr = noPic
( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $ ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
rotateSH (_prRot pr) $ rotateSH (_prRot pr) $
mconcat 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]
, 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
+3 -1
View File
@@ -62,7 +62,9 @@ doDrawing' win pdata u = do
-- count mutable vectors setup -- count mutable vectors setup
layerCounts <- UMV.replicate (numLayers * 6) 0 layerCounts <- UMV.replicate (numLayers * 6) 0
-- attempt to poke in parallel -- 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)) <- ((nWins, trueNWalls), (nShapeVs, nIndices, nSilIndices)) <-
MP.bindM3 MP.bindM3
(\_ a b -> return (a, b)) (\_ a b -> return (a, b))
src/Dodge/Render/ShapePicture.hs
+6 -6
View File
@@ -2,6 +2,7 @@ module Dodge.Render.ShapePicture (
worldSPic, worldSPic,
) where ) where
import Data.Strict.Tuple
import Control.Applicative import Control.Applicative
import Dodge.Data.DoubleTree import Dodge.Data.DoubleTree
import Dodge.Data.ComposedItem import Dodge.Data.ComposedItem
@@ -28,7 +29,7 @@ import ShapePicture
worldSPic :: Configuration -> Universe -> SPic worldSPic :: Configuration -> Universe -> SPic
worldSPic cfig u = worldSPic cfig u =
(mempty, extraPics cfig u) (mempty :!: extraPics cfig u)
<> foldup drawProp' (filtOn _prPos _props) <> foldup drawProp' (filtOn _prPos _props)
<> foldup drawProjectile (filtOn _prjPos _projectiles) <> foldup drawProjectile (filtOn _prjPos _projectiles)
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks) <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
@@ -82,7 +83,7 @@ anyTargeting w = fromMaybe mempty $ do
ttree <- lookup WeaponTargetingLink (itmtree ^. ldtRight) ttree <- lookup WeaponTargetingLink (itmtree ^. ldtRight)
_ <- lookup AugmentedHUDLink (ttree ^. ldtLeft) _ <- lookup AugmentedHUDLink (ttree ^. ldtLeft)
<|> lookup AugmentedHUDLink (ttree ^. ldtRight) <|> lookup AugmentedHUDLink (ttree ^. ldtRight)
return (mempty , drawTargeting (ttree ^. ldtValue) w) return . noShape $ drawTargeting (ttree ^. ldtValue) w
drawCreature :: Creature -> SPic drawCreature :: Creature -> SPic
drawCreature cr = case _crType cr of drawCreature cr = case _crType cr of
@@ -102,13 +103,12 @@ drawCreature cr = case _crType cr of
lampCrSPic :: Float -> SPic lampCrSPic :: Float -> SPic
lampCrSPic h = 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 picAtCrPos1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-} --{-# 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 :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
shiftDraw fpos fdir fdraw x = shiftDraw fpos fdir fdraw x =
src/Dodge/Wall/Draw.hs
+1 -4
View File
@@ -9,12 +9,9 @@ drawWall wd = case wd of
DrawForceField -> drawForceField DrawForceField -> drawForceField
drawForceField :: Wall -> SPic drawForceField :: Wall -> SPic
drawForceField wl = drawForceField wl = noShape . setLayer BloomLayer
( mempty
, setLayer BloomLayer
. setDepth 20 . setDepth 20
. color (_wlColor wl) . color (_wlColor wl)
$ thickLine 5 [a, b] $ thickLine 5 [a, b]
)
where where
(a, b) = _wlLine wl (a, b) = _wlLine wl
src/ShapePicture.hs
+4 -3
View File
@@ -13,22 +13,23 @@ module ShapePicture
-- , mirrorSPxz -- , mirrorSPxz
, overPosSP , overPosSP
) where ) where
import ShapePicture.Data import ShapePicture.Data
import Shape import Shape
import Picture import Picture
import Geometry import Geometry
import Data.Strict.Tuple
import Data.Bifunctor import Data.Bifunctor
--import Control.Lens --import Control.Lens
-- should all this be inlined/inlinable? -- should all this be inlined/inlinable?
noPic :: Shape -> SPic noPic :: Shape -> SPic
{-# INLINE noPic #-} {-# INLINE noPic #-}
noPic = (,mempty) noPic = (:!: mempty)
noShape :: Picture -> SPic noShape :: Picture -> SPic
{-# INLINE noShape #-} {-# INLINE noShape #-}
noShape = (mempty,) noShape = (mempty :!:)
--_spShape :: SPic -> Shape --_spShape :: SPic -> Shape
--_spShape = fst --_spShape = fst
src/ShapePicture/Data.hs
+4 -1
View File
@@ -1,4 +1,7 @@
module ShapePicture.Data where module ShapePicture.Data where
import Data.Strict.Tuple
import Picture.Data import Picture.Data
import Shape.Data import Shape.Data
type SPic = (Shape, Picture)
type SPic = Pair Shape Picture