Prop reification/splitting
This commit is contained in:
+35
-39
@@ -1,12 +1,8 @@
|
||||
module Dodge.Block.Debris where
|
||||
import Dodge.Material.Sound
|
||||
import Dodge.Prop.Moving
|
||||
import Dodge.WorldEvent.Sound
|
||||
--import Dodge.Zone
|
||||
import Dodge.Base
|
||||
import Dodge.Data
|
||||
--import Dodge.Damage
|
||||
--import ShapePicture
|
||||
import Shape
|
||||
import Geometry
|
||||
import Color
|
||||
@@ -50,7 +46,7 @@ makeDebris = makeDebrisDirected 1 2 (2*pi) 0
|
||||
makeDebrisDirectedHeight :: Float -> Float -> Float -> Float -> Float -> Material
|
||||
-> Color -> Point2 -> World -> World
|
||||
makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w
|
||||
& flip (foldl' (flip $ plNew props pjID)) thedebris
|
||||
& flip (foldl' (flip $ plNew props prID)) thedebris
|
||||
& randGen .~ newg
|
||||
& originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
|
||||
where
|
||||
@@ -62,13 +58,13 @@ makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w
|
||||
spinspeed <- randomR (-0.2,-0.1) & state
|
||||
basedebris <- baseDebris bm
|
||||
return $ basedebris
|
||||
& pjColor .~ col
|
||||
& prColor .~ col
|
||||
& prPos .~ p
|
||||
& pjVel .~ v
|
||||
& pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& pjQuat .~ q
|
||||
& pjVelZ .~ 0
|
||||
& pjPosZ .~ h
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ 0
|
||||
& prPosZ .~ h
|
||||
|
||||
makeDebrisDirected :: Float
|
||||
-> Float
|
||||
@@ -79,7 +75,7 @@ makeDebrisDirected :: Float
|
||||
-> Point2
|
||||
-> World -> World
|
||||
makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
|
||||
& flip (foldl' (flip $ plNew props pjID)) thedebris
|
||||
& flip (foldl' (flip $ plNew props prID)) thedebris
|
||||
& randGen .~ newg
|
||||
& originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
|
||||
where
|
||||
@@ -90,13 +86,13 @@ makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
|
||||
spinspeed <- randomR (-0.2,-0.1) & state
|
||||
basedebris <- baseDebris bm
|
||||
return $ basedebris
|
||||
& pjColor .~ col
|
||||
& prColor .~ col
|
||||
& prPos .~ p
|
||||
& pjVel .~ v
|
||||
& pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& pjQuat .~ q
|
||||
& pjVelZ .~ 0
|
||||
& pjPosZ .~ h
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ 0
|
||||
& prPosZ .~ h
|
||||
|
||||
debrisSize :: Material -> Float
|
||||
debrisSize mt = case mt of
|
||||
@@ -119,45 +115,45 @@ baseDebris mt = case mt of
|
||||
Metal -> do
|
||||
sh <- jaggedShape
|
||||
return $ metalDebris
|
||||
& prDraw .~ (`drawMovingShapeCol` sh)
|
||||
& prDraw .~ PropDrawMovingShapeCol sh
|
||||
Electronics -> baseDebris Metal
|
||||
Flesh -> baseDebris Dirt <&> pjColor .~ red
|
||||
Flesh -> baseDebris Dirt <&> prColor .~ red
|
||||
|
||||
stoneDebris :: Prop
|
||||
stoneDebris = PropZ
|
||||
{_prPos = 0
|
||||
,_pjStartPos = 0
|
||||
,_pjVel = 0
|
||||
,_prDraw = \pr -> drawMovingShapeCol pr (cubeShape 4)
|
||||
,_pjID = 0
|
||||
,_pjUpdate = fallSmallBounceDamage
|
||||
,_pjPosZ = 10
|
||||
,_pjVelZ = 5
|
||||
,_pjTimer = 20
|
||||
,_pjQuat = Q.axisAngle (V3 1 0 0) 0
|
||||
,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
|
||||
,_pjColor = greyN 0.5
|
||||
,_prStartPos = 0
|
||||
,_prVel = 0
|
||||
,_prDraw = PropDrawMovingShapeCol (cubeShape 4)
|
||||
,_prID = 0
|
||||
,_prUpdate = PropFallSmallBounceDamage
|
||||
,_prPosZ = 10
|
||||
,_prVelZ = 5
|
||||
,_prTimer = 20
|
||||
,_prQuat = Q.axisAngle (V3 1 0 0) 0
|
||||
,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
|
||||
,_prColor = greyN 0.5
|
||||
}
|
||||
dirtDebris :: Prop
|
||||
dirtDebris = stoneDebris
|
||||
& pjColor .~ dirtColor
|
||||
& pjUpdate .~ fallSmallBounce
|
||||
& prColor .~ dirtColor
|
||||
& prUpdate .~ PropFallSmallBounce
|
||||
dirtColor :: Color
|
||||
dirtColor = V4 (150/256) ( 75/256) 0 ( 250/256)
|
||||
|
||||
metalDebris :: Prop
|
||||
metalDebris = stoneDebris
|
||||
& prDraw .~ (\pr -> drawMovingShapeCol pr (shardShape 4))
|
||||
& pjUpdate .~ fallSmallBounce
|
||||
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
|
||||
& prUpdate .~ PropFallSmallBounceDamage
|
||||
|
||||
glassDebris :: Prop
|
||||
glassDebris = stoneDebris
|
||||
& prDraw .~ (\pr -> drawMovingShapeCol pr (shardShape 4))
|
||||
& pjUpdate .~ fallSmallBounce
|
||||
& pjColor .~ withAlpha 0.5 cyan
|
||||
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
|
||||
& prUpdate .~ PropFallSmallBounce
|
||||
& prColor .~ withAlpha 0.5 cyan
|
||||
crystalDebris :: Prop
|
||||
crystalDebris = glassDebris
|
||||
& pjColor .~ withAlpha 0.5 aquamarine
|
||||
& prColor .~ withAlpha 0.5 aquamarine
|
||||
|
||||
shardShape :: Float -> Shape
|
||||
shardShape size = translateSHz (-size) $ upperPrismPoly size
|
||||
|
||||
+9
-70
@@ -80,7 +80,13 @@ module Dodge.Data
|
||||
, module Dodge.Data.Laser
|
||||
, module Dodge.Data.TeslaArc
|
||||
, module Dodge.Data.Shockwave
|
||||
, module Dodge.Data.Prop
|
||||
, module Dodge.Data.LinearShockwave
|
||||
, module Dodge.Data.TractorBeam
|
||||
) where
|
||||
import Dodge.Data.TractorBeam
|
||||
import Dodge.Data.LinearShockwave
|
||||
import Dodge.Data.Prop
|
||||
import Dodge.Data.Shockwave
|
||||
import Dodge.Data.TeslaArc
|
||||
import Dodge.Data.Laser
|
||||
@@ -161,10 +167,7 @@ import Dodge.GameRoom
|
||||
import Color
|
||||
import Data.Tile
|
||||
import MaybeHelp
|
||||
--import StreamingHelp.Data
|
||||
|
||||
--import qualified Data.Vector as V
|
||||
import qualified Linear.Quaternion as Q
|
||||
import Control.Lens
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
@@ -230,6 +233,8 @@ data World = World
|
||||
, _shockwaves :: [Shockwave]
|
||||
, _lasers :: [LaserStart]
|
||||
, _lasersToDraw :: [Laser]
|
||||
, _linearShockwaves :: IM.IntMap LinearShockwave
|
||||
, _tractorBeams :: [TractorBeam]
|
||||
, _walls :: IM.IntMap Wall
|
||||
, _wallDamages :: IM.IntMap [Damage]
|
||||
, _doors :: IM.IntMap Door
|
||||
@@ -287,6 +292,7 @@ data World = World
|
||||
, _lSelect :: Point2
|
||||
, _rSelect :: Point2
|
||||
}
|
||||
--deriving (Eq,Ord,Show,Read)
|
||||
data WorldHammer
|
||||
= SubInvHam
|
||||
| DoubleMouseHam
|
||||
@@ -396,72 +402,6 @@ type HitEffect' = Flame
|
||||
-> World
|
||||
-> (World,Maybe Flame)
|
||||
|
||||
data Prop
|
||||
= PropZ
|
||||
{ _prPos :: Point2
|
||||
, _pjStartPos :: Point2
|
||||
, _pjVel :: Point2
|
||||
, _prDraw :: Prop -> SPic
|
||||
, _pjID :: Int
|
||||
, _pjUpdate :: Prop -> World -> World
|
||||
, _pjPosZ :: Float
|
||||
, _pjVelZ :: Float
|
||||
, _pjTimer :: Int
|
||||
, _pjQuat :: Q.Quaternion Float
|
||||
, _pjQuatSpin :: Q.Quaternion Float
|
||||
, _pjColor :: Color
|
||||
}
|
||||
| Drone
|
||||
{ _prPos :: Point2
|
||||
, _pjStartPos :: Point2
|
||||
, _pjVel :: Point2
|
||||
, _prDraw :: Prop -> SPic
|
||||
, _pjID :: Int
|
||||
, _pjUpdate :: Prop -> World -> World
|
||||
}
|
||||
| RecursiveProp
|
||||
{ _prPos :: Point2
|
||||
, _pjID :: Int
|
||||
, _pjDraw :: Prop -> SPic
|
||||
, _pjUpdate :: Prop -> World -> World
|
||||
, _pjProp :: Prop
|
||||
}
|
||||
| ProjectileTimed
|
||||
{ _prPos :: Point2
|
||||
, _pjStartPos :: Point2
|
||||
, _pjVel :: Point2
|
||||
, _prDraw :: Prop -> SPic
|
||||
, _pjID :: Int
|
||||
, _pjUpdate :: Prop -> World -> World
|
||||
, _pjTime :: Int
|
||||
}
|
||||
| ShapeProp
|
||||
{ _prPos :: Point2
|
||||
, _pjID :: Int
|
||||
, _pjRot :: Float
|
||||
, _pjUpdate :: Prop -> World -> World
|
||||
, _prDraw :: Prop -> SPic
|
||||
, _prToggle :: Bool
|
||||
}
|
||||
| Bomb
|
||||
{ _prPos :: Point2
|
||||
, _pjVel :: Point2
|
||||
, _pjZ :: Float
|
||||
, _pjVelZ :: Float
|
||||
, _prDraw :: Prop -> SPic
|
||||
, _pjID :: Int
|
||||
, _pjUpdate :: Prop -> World -> World
|
||||
, _pjPayload :: Point2 -> World -> World
|
||||
, _pjTimer :: Int
|
||||
}
|
||||
| LinearShockwave
|
||||
{ _prDraw :: Prop -> SPic
|
||||
, _prPos :: Point2
|
||||
, _pjID :: Int
|
||||
, _pjUpdate :: Prop -> World -> World
|
||||
, _pjPoints :: [(Point2,Point2)]
|
||||
, _pjTimer :: Int
|
||||
}
|
||||
data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
|
||||
data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
|
||||
deriving (Eq,Ord,Show)
|
||||
@@ -653,7 +593,6 @@ data InPlacement = InPlacement
|
||||
}
|
||||
makeLenses ''World
|
||||
makeLenses ''FloorItem
|
||||
makeLenses ''Prop
|
||||
makeLenses ''Particle
|
||||
makeLenses ''Door
|
||||
makeLenses ''Terminal
|
||||
|
||||
@@ -17,7 +17,6 @@ data Cloud = Cloud
|
||||
, _clAlt :: Float
|
||||
, _clTimer :: Int
|
||||
, _clType :: CloudType
|
||||
-- , _clEffect :: Cloud -> World -> World
|
||||
}
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
data CloudType
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.Data.LinearShockwave where
|
||||
import Geometry.Data
|
||||
import Control.Lens
|
||||
data LinearShockwave = LinearShockwave
|
||||
{ _lwPos :: Point2
|
||||
, _lwID :: Int
|
||||
, _lwPoints :: [(Point2,Point2)]
|
||||
, _lwTimer :: Int
|
||||
}
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
makeLenses ''LinearShockwave
|
||||
@@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.Data.Prop
|
||||
where
|
||||
import Dodge.Data.WorldEffect
|
||||
import Shape.Data
|
||||
import Color
|
||||
import qualified Linear.Quaternion as Q
|
||||
import Geometry.Data
|
||||
import ShapePicture.Data
|
||||
import Control.Lens
|
||||
|
||||
data PropDraw = PropDrawSPic SPic
|
||||
| PropDrawMovingShapeCol Shape
|
||||
| PropDrawMovingShape PropDraw
|
||||
| PropDrawFlatTranslate PropDraw
|
||||
| PropDoubleLampCover Float
|
||||
| PropVerticalLampCover Float
|
||||
| PropLampCover Float
|
||||
| PropDrawToggle PropDraw
|
||||
| PropDrawGib Float
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
data PropUpdate -- = UpdatePropZ
|
||||
= PropUpdateAnd PropUpdate PropUpdate
|
||||
-- | UpdateShapeProp
|
||||
| PropFallSmallBounceDamage
|
||||
| PropFallSmallBounce
|
||||
| PropUpdateId
|
||||
| PropRotate Float
|
||||
| PropSetToggleAnd WdBl PropUpdate
|
||||
| PropUpdates [PropUpdate]
|
||||
| PropUpdateLS Int PrWdLsLs -- Prop -> World -> LightSource -> LightSource
|
||||
| PropUpdatePosition WdP2f
|
||||
| PropUpdateWhen WdBl PropUpdate
|
||||
| PropUpdateIf WdBl PropUpdate PropUpdate
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
data PrWdLsLs = PrWdLsId
|
||||
| PrWdLsSetPosition WdP2f Point3
|
||||
| PrWdLsSetColor Point3
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
data Prop
|
||||
= PropZ
|
||||
{ _prPos :: Point2
|
||||
, _prDraw :: PropDraw
|
||||
, _prUpdate :: PropUpdate
|
||||
, _prStartPos :: Point2
|
||||
, _prVel :: Point2
|
||||
, _prID :: Int
|
||||
, _prPosZ :: Float
|
||||
, _prVelZ :: Float
|
||||
, _prTimer :: Int
|
||||
, _prQuat :: Q.Quaternion Float
|
||||
, _prQuatSpin :: Q.Quaternion Float
|
||||
, _prColor :: Color
|
||||
}
|
||||
| ShapeProp
|
||||
{ _prPos :: Point2
|
||||
, _prDraw :: PropDraw
|
||||
, _prUpdate :: PropUpdate
|
||||
, _prID :: Int
|
||||
, _prRot :: Float
|
||||
, _prToggle :: Bool
|
||||
}
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
makeLenses ''Prop
|
||||
@@ -0,0 +1,13 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.Data.TractorBeam where
|
||||
import Geometry.Data
|
||||
import Control.Lens
|
||||
data TractorBeam = TractorBeam
|
||||
{ _tbPos :: Point2
|
||||
, _tbStartPos :: Point2
|
||||
, _tbVel :: Point2
|
||||
, _tbTime :: Int
|
||||
}
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
makeLenses ''TractorBeam
|
||||
@@ -2,7 +2,6 @@ module Dodge.Data.WorldEffect where
|
||||
import Sound.Data
|
||||
import Geometry.Data
|
||||
import Dodge.Data.SoundOrigin
|
||||
|
||||
data WorldEffect = NoWorldEffect
|
||||
| SetTrigger Bool Int
|
||||
| WorldEffects [WorldEffect]
|
||||
@@ -21,3 +20,9 @@ data MdWdWd = MdWdId
|
||||
| MdSetLSCol Point3
|
||||
| MdFlickerUpdate
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
data WdBl = WdTrig Int
|
||||
| WdBlDoorMoving Int
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
data WdP2f = WdP2f0
|
||||
| WdP2fDoorPosition Int
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
|
||||
@@ -4,18 +4,9 @@ import Geometry
|
||||
defaultProp :: Prop
|
||||
defaultProp = ShapeProp
|
||||
{ _prPos = V2 0 0
|
||||
, _prDraw = const mempty
|
||||
, _pjID = 0
|
||||
, _pjUpdate = const id
|
||||
, _prToggle = True
|
||||
, _pjRot = 0
|
||||
}
|
||||
defaultShapeProp :: Prop
|
||||
defaultShapeProp = ShapeProp
|
||||
{ _prPos = 0
|
||||
, _pjID = 0
|
||||
, _pjRot = 0
|
||||
, _pjUpdate = const id
|
||||
, _prDraw = const mempty
|
||||
, _prDraw = PropDrawSPic mempty
|
||||
, _prID = 0
|
||||
, _prUpdate = PropUpdateId
|
||||
, _prToggle = True
|
||||
, _prRot = 0
|
||||
}
|
||||
|
||||
@@ -49,6 +49,8 @@ defaultWorld = World
|
||||
, _shockwaves = []
|
||||
, _lasers = []
|
||||
, _lasersToDraw = []
|
||||
, _tractorBeams = mempty
|
||||
, _linearShockwaves = mempty
|
||||
, _walls = IM.empty
|
||||
, _wallDamages = IM.empty
|
||||
, _blocks = IM.empty
|
||||
|
||||
@@ -8,9 +8,6 @@ import Dodge.Default.Weapon
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import Picture
|
||||
import ShapePicture
|
||||
import ListHelp (safeHead)
|
||||
--import Shape
|
||||
|
||||
import Data.Maybe
|
||||
import Control.Lens
|
||||
@@ -60,51 +57,16 @@ addBoostShockwave
|
||||
-> Point2
|
||||
-> World
|
||||
-> World
|
||||
addBoostShockwave pjid p v w = w & props %~
|
||||
addBoostShockwave pjid p v w = w & linearShockwaves %~
|
||||
IM.insertWith f pjid thePJ
|
||||
where
|
||||
thePJ = LinearShockwave
|
||||
{ _prDraw = drawBoostShockwave
|
||||
, _prPos = p
|
||||
, _pjID = pjid
|
||||
, _pjUpdate = updateLinearShockwave
|
||||
, _pjPoints = [(p,v)]
|
||||
, _pjTimer = maxT
|
||||
{ _lwPos = p
|
||||
, _lwID = pjid
|
||||
, _lwPoints = [(p,v)]
|
||||
, _lwTimer = maxT
|
||||
}
|
||||
f newVal oldVal = newVal & pjPoints %~ (++ _pjPoints oldVal)
|
||||
|
||||
updateLinearShockwave :: Prop -> World -> World
|
||||
updateLinearShockwave pj w
|
||||
| t < 1 = w & props %~ IM.delete pjid
|
||||
| otherwise = w & props . ix (_pjID pj) . pjTimer -~ 1
|
||||
where
|
||||
pjid = _pjID pj
|
||||
t = _pjTimer pj
|
||||
|
||||
drawBoostShockwave :: Prop -> SPic
|
||||
drawBoostShockwave pj = (,) mempty $ setLayer BloomLayer $ setDepth 20 $ pictures $
|
||||
theArc ++
|
||||
[ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
|
||||
, lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]
|
||||
]
|
||||
where
|
||||
-- drawing half a circle here is not perfect, a slightly smaller arc would fit
|
||||
-- better, but this depends upon the angle formed by the following lines, which
|
||||
-- is not fixed (it varies with speed and angle of last turn)
|
||||
theArc = maybeToList $ do
|
||||
(hp,hv) <- safeHead pvs
|
||||
r <- safeHead xs
|
||||
return $ color (snd $ last lpairs) $ uncurryV translate hp
|
||||
$ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv
|
||||
cols = map (`withAlpha` white) [0,0.05..]
|
||||
lpairs = zip (reverse lps) cols
|
||||
pvs = _pjPoints pj
|
||||
t = _pjTimer pj
|
||||
xs = take t $ drop (20 - t) [1,1.2..]
|
||||
lps = zipWith f pvs xs
|
||||
rps = zipWith g pvs xs
|
||||
f (p,v) x = p +.+ x *.* vNormal v
|
||||
g (p,v) x = p -.- x *.* vNormal v
|
||||
f newVal oldVal = newVal & lwPoints %~ (++ _lwPoints oldVal)
|
||||
|
||||
maxT :: Int
|
||||
maxT = 20
|
||||
|
||||
@@ -29,15 +29,8 @@ import Dodge.Base
|
||||
--import Dodge.Zone
|
||||
import Geometry
|
||||
import Picture
|
||||
import ShapePicture
|
||||
import LensHelp
|
||||
--import Dodge.RandomHelp
|
||||
--import MonadHelp
|
||||
|
||||
--import Data.Maybe
|
||||
--import Data.List (sortOn)
|
||||
--import System.Random
|
||||
--import Data.Tuple
|
||||
import qualified IntMapHelp as IM
|
||||
import qualified Data.Map.Strict as M
|
||||
--import Control.Monad.State
|
||||
@@ -353,8 +346,7 @@ dualRayAt bt itid w col dam phasev pos dir = basicBeamAt itid w col dam phasev p
|
||||
& bmType .~ bt
|
||||
|
||||
aTractorBeam :: Item -> Creature -> World -> World
|
||||
--aTractorBeam _ cr w = w & props %~ tractorBeamAt i spos outpos dir power
|
||||
aTractorBeam _ cr w = w & plNew props pjID (tractorBeamAt spos outpos dir power)
|
||||
aTractorBeam _ cr w = w & tractorBeams .:~ tractorBeamAt spos outpos dir power
|
||||
where
|
||||
cpos = _crPos cr
|
||||
spos = cpos +.+ (_crRad cr + 10) *.* unitVectorAtAngle dir
|
||||
@@ -363,71 +355,13 @@ aTractorBeam _ cr w = w & plNew props pjID (tractorBeamAt spos outpos dir power)
|
||||
outpos = fst $ collidePointWallsFilterStream (const True) cpos xpos w
|
||||
power = _attractionPower . _itParams $ _crInv cr IM.! crSel cr
|
||||
|
||||
tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> Prop
|
||||
tractorBeamAt pos outpos dir power = ProjectileTimed
|
||||
{ _prPos = pos
|
||||
, _pjStartPos = outpos
|
||||
, _pjVel = d
|
||||
, _prDraw = tractorSPic
|
||||
, _pjID = 0
|
||||
, _pjUpdate = updateTractor
|
||||
, _pjTime = 10
|
||||
tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> TractorBeam
|
||||
tractorBeamAt pos outpos dir power = TractorBeam
|
||||
{ _tbPos = pos
|
||||
, _tbStartPos = outpos
|
||||
, _tbVel = d
|
||||
, _tbTime = 10
|
||||
}
|
||||
where
|
||||
d = unitVectorAtAngle dir * power
|
||||
{- |
|
||||
The interaction of this with objects, walls etc needs more thought. -}
|
||||
updateTractor :: Prop -> World -> World
|
||||
updateTractor pj w
|
||||
| _pjTime pj <= 0 = w & props %~ IM.delete i
|
||||
| otherwise = w
|
||||
& props . ix i . pjTime -~ 1
|
||||
& creatures %~ IM.map (tractCr pullVel pos outpos)
|
||||
& floorItems %~ IM.map (tractFlIt pullVel pos outpos)
|
||||
where
|
||||
i = _pjID pj
|
||||
pullVel = _pjVel pj
|
||||
pos = _prPos pj
|
||||
outpos = _pjStartPos pj
|
||||
|
||||
tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem
|
||||
tractFlIt q p1 outpos it
|
||||
| segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
|
||||
| otherwise = it
|
||||
|
||||
tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature
|
||||
tractCr q p1 outpos cr
|
||||
| segOnCirc p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
|
||||
| otherwise = cr
|
||||
|
||||
tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2
|
||||
tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4)
|
||||
where
|
||||
x' = abs y + 1
|
||||
y = errorClosestPointOnLineParam 1 p1 p3 p
|
||||
m | dist p p1 < 350 = 1
|
||||
| otherwise = (400 - dist p p1) / 50
|
||||
g x | x > 5 = (10 - x) / 250
|
||||
| x > 1 = 0.02
|
||||
| x > -1 = x * 0.02
|
||||
| x > -5 = -0.02
|
||||
| otherwise = (x - 10) / 250
|
||||
--p4 = vNormal p5
|
||||
p4 = vNormal $ squashNormalizeV q
|
||||
p3 = p1 +.+ p4
|
||||
|
||||
tractorSPic :: Prop -> SPic
|
||||
tractorSPic pj = (,) mempty $ setLayer BloomNoZWrite $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon
|
||||
[ spos -- not sure if this is anticlockwise...
|
||||
, spos +.+ size *.* (d +.+ n)
|
||||
, xpos +.+ size *.* n
|
||||
, xpos -.- size *.* n
|
||||
, spos +.+ size *.* (d -.- n)
|
||||
]
|
||||
where
|
||||
size = fromIntegral (_pjTime pj)
|
||||
spos = _prPos pj
|
||||
xpos = _pjStartPos pj
|
||||
d = squashNormalizeV $ spos -.- xpos
|
||||
n = vNormal d
|
||||
col = mixColors 0.5 0.5 white blue
|
||||
|
||||
@@ -1,15 +1,9 @@
|
||||
module Dodge.Item.Weapon.Grenade where
|
||||
import Dodge.Zoning.Wall
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
import Picture
|
||||
import Geometry
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import qualified IntMapHelp as IM
|
||||
|
||||
import Control.Lens
|
||||
|
||||
--grenade :: Item
|
||||
--grenade = Item
|
||||
@@ -40,27 +34,27 @@ import Control.Lens
|
||||
-- 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
|
||||
--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 =
|
||||
@@ -72,9 +66,9 @@ grenadePic time =
|
||||
]
|
||||
)
|
||||
|
||||
grenadeDraw :: Float -> Prop -> SPic
|
||||
grenadeDraw dir prop = translateSPz (_pjZ prop) $ uncurryV translateSPf (_prPos prop)
|
||||
$ rotateSP dir $ grenadePic $ _pjTimer prop
|
||||
--grenadeDraw :: Float -> Prop -> SPic
|
||||
--grenadeDraw dir prop = translateSPz (_pjZ prop) $ uncurryV translateSPf (_prPos prop)
|
||||
-- $ rotateSP dir $ grenadePic $ _pjTimer prop
|
||||
|
||||
--throwGrenade
|
||||
-- :: (Point2 -> World -> World) -- ^ Payload
|
||||
|
||||
@@ -0,0 +1,34 @@
|
||||
module Dodge.LinearShockwave.Draw
|
||||
where
|
||||
import Geometry.Vector
|
||||
import Geometry.Data
|
||||
import ListHelp
|
||||
import Dodge.Data.LinearShockwave
|
||||
import Picture
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
drawLinearShockwave :: LinearShockwave -> Picture
|
||||
drawLinearShockwave lw = setLayer BloomLayer $ setDepth 20 $ pictures $
|
||||
theArc ++
|
||||
[ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
|
||||
, lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]
|
||||
]
|
||||
where
|
||||
-- drawing half a circle here is not perfect, a slightly smaller arc would fit
|
||||
-- better, but this depends upon the angle formed by the following lines, which
|
||||
-- is not fixed (it varies with speed and angle of last turn)
|
||||
theArc = maybeToList $ do
|
||||
(hp,hv) <- safeHead pvs
|
||||
r <- safeHead xs
|
||||
return $ color (snd $ last lpairs) $ uncurryV translate hp
|
||||
$ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv
|
||||
cols = map (`withAlpha` white) [0,0.05..]
|
||||
lpairs = zip (reverse lps) cols
|
||||
pvs = _lwPoints lw
|
||||
t = _lwTimer lw
|
||||
xs = take t $ drop (20 - t) [1,1.2..]
|
||||
lps = zipWith f pvs xs
|
||||
rps = zipWith g pvs xs
|
||||
f (p,v) x = p +.+ x *.* vNormal v
|
||||
g (p,v) x = p -.- x *.* vNormal v
|
||||
@@ -0,0 +1,16 @@
|
||||
module Dodge.LinearShockwave.Update
|
||||
where
|
||||
import Dodge.Data
|
||||
import qualified IntMapHelp as IM
|
||||
|
||||
import Control.Lens
|
||||
|
||||
updateLinearShockwave :: LinearShockwave -> World -> World
|
||||
updateLinearShockwave lw w
|
||||
| t < 1 = w & linearShockwaves %~ IM.delete lwid
|
||||
| otherwise = w & linearShockwaves . ix lwid . lwTimer -~ 1
|
||||
where
|
||||
lwid = _lwID lw
|
||||
t = _lwTimer lw
|
||||
|
||||
|
||||
@@ -16,36 +16,35 @@ import ShapePicture
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
|
||||
propLSThen :: (Prop -> World -> World)
|
||||
-> (Prop -> World -> LightSource -> LightSource)
|
||||
propLSThen :: PropUpdate
|
||||
-> PrWdLsLs --(Prop -> World -> LightSource -> LightSource)
|
||||
-> LightSource
|
||||
-> Prop
|
||||
-> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
|
||||
-> Placement
|
||||
propLSThen propf lsf ls prop cont = pt0 (PutLS ls)
|
||||
$ \lspl -> Just $ pt0 (PutProp $ prop & pjUpdate .~ theupdate (fromJust $ _plMID lspl))
|
||||
$ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf])
|
||||
-- theupdate (fromJust $ _plMID lspl))
|
||||
$ cont lspl
|
||||
where
|
||||
theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
|
||||
--theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
|
||||
|
||||
moveLSThen :: (World -> (Point2,Float))
|
||||
moveLSThen :: WdP2f --(World -> (Point2,Float))
|
||||
-> Point3 -- ^ light source offset
|
||||
-> Shape
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
moveLSThen posf off sh = propLSThen propupdate lsupdate thels theprop
|
||||
moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition posf off) thels theprop
|
||||
where
|
||||
propupdate pr w = w
|
||||
& props . ix (_pjID pr) . prPos .~ fst (posf w)
|
||||
& props . ix (_pjID pr) . pjRot .~ snd (posf w)
|
||||
lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
|
||||
--lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
|
||||
thels = defaultLS
|
||||
theprop = ShapeProp
|
||||
{ _prPos = 0
|
||||
, _pjID = 0
|
||||
, _pjRot = 0
|
||||
, _pjUpdate = const id
|
||||
, _prDraw = \pr -> noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropUpdateId
|
||||
--, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
, _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
|
||||
@@ -1,85 +1,35 @@
|
||||
module Dodge.Placement.Instance.LightSource.Cover where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Geometry.Data
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import Geometry
|
||||
import Dodge.Default.Prop
|
||||
|
||||
import Control.Lens
|
||||
|
||||
lampCover :: Float -> Prop
|
||||
lampCover h = ShapeProp
|
||||
{ _prPos = V2 0 0
|
||||
, _pjID = 0
|
||||
, _pjRot = 0
|
||||
, _pjUpdate = rotateProp 0.15
|
||||
, _prDraw = drawLampCover h
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop
|
||||
lampCoverWhen cond pos h = defaultShapeProp
|
||||
lampCoverWhen :: WdBl -> Point2 -> Float -> Prop
|
||||
lampCoverWhen cond pos h = defaultProp
|
||||
{ _prPos = pos
|
||||
, _pjUpdate = setToggle cond `dbArgChain` rotateProp 0.15
|
||||
, _prDraw = drawLampCover h
|
||||
, _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
doubleLampCover :: Float -> Prop
|
||||
doubleLampCover h = defaultShapeProp
|
||||
doubleLampCover h = defaultProp
|
||||
{ _prPos = V2 0 0
|
||||
, _pjUpdate = rotateProp 0.15
|
||||
, _prDraw = drawDoubleLampCover h
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropDoubleLampCover h
|
||||
}
|
||||
|
||||
-- on the current (27/9/21) version of shadow stencilling, this glitches
|
||||
-- slightly when the shadow rotates towards the screen
|
||||
verticalLampCover :: Float -> Prop
|
||||
verticalLampCover h = defaultShapeProp
|
||||
{ _pjUpdate = rotateProp 0.15
|
||||
, _prDraw = drawVerticalLampCover h
|
||||
verticalLampCover h = defaultProp
|
||||
{ _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropVerticalLampCover h
|
||||
}
|
||||
|
||||
rotateProp :: Float -> Prop -> World -> World
|
||||
rotateProp rotAmount pr w = w
|
||||
& props . ix (_pjID pr) . pjRot +~ rotAmount
|
||||
|
||||
setToggle :: (World -> Bool) -> Prop -> World -> World
|
||||
setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w
|
||||
|
||||
drawLampCover :: Float -> Prop -> SPic
|
||||
drawLampCover h pr
|
||||
| not (_prToggle pr) = mempty
|
||||
| otherwise = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSH (_pjRot pr) $ mconcat
|
||||
[ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
||||
, translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
||||
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
||||
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
||||
, upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
|
||||
drawDoubleLampCover :: Float -> Prop -> SPic
|
||||
drawDoubleLampCover h pr =
|
||||
( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSH (_pjRot pr) $ mconcat
|
||||
[ upperPrismPoly 5 $ reverse $ rectNSWE 6 5 (-6) 6
|
||||
, upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
|
||||
, upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
|
||||
, upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)]
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
|
||||
drawVerticalLampCover :: Float -> Prop -> SPic
|
||||
drawVerticalLampCover h pr =
|
||||
( translateSHz h . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSHx (_pjRot pr) $ mconcat
|
||||
[
|
||||
translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
|
||||
@@ -86,7 +86,7 @@ placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
|
||||
placeSpotID ps pt w = case pt of
|
||||
PutTrigger cnd -> plNewID triggers cnd w
|
||||
PutMod mdi -> plNewUpID modifications mdID mdi w
|
||||
PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w
|
||||
PutProp prp -> plNewUpID props prID (mvProp p rot prp) w
|
||||
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
|
||||
PutTerminal tm -> plNewUpID terminals tmID tm w
|
||||
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
|
||||
@@ -150,7 +150,7 @@ addPane wl w l = w & plNew walls wlID (wl & wlLine .~ l)
|
||||
-- wlid = IM.newKey (_walls w)
|
||||
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
|
||||
mvProp p a = (prRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
mvButton :: Point2 -> Float -> Button -> Button
|
||||
mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
module Dodge.PrWdLsLs
|
||||
where
|
||||
import Dodge.WdP2f
|
||||
import Geometry.Vector3D
|
||||
import Dodge.Data
|
||||
import Control.Lens
|
||||
|
||||
doPrWdLsLs :: PrWdLsLs -> Prop -> World -> LightSource -> LightSource
|
||||
doPrWdLsLs x = case x of
|
||||
PrWdLsId -> \_ _ -> id
|
||||
PrWdLsSetPosition y off -> \_ w
|
||||
-> lsParam . lsPos .~ addZ 0 (fst (doWdP2f y w)) +.+.+ rotate3z (snd (doWdP2f y w)) off
|
||||
PrWdLsSetColor c -> \_ _ -> lsParam . lsCol .~ c
|
||||
@@ -0,0 +1,87 @@
|
||||
module Dodge.Prop.Draw
|
||||
where
|
||||
import Geometry.Polygon
|
||||
import Geometry.Data
|
||||
import Dodge.Data.Prop
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import Picture
|
||||
import qualified Quaternion as Q
|
||||
|
||||
drawProp' :: Prop -> SPic
|
||||
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)
|
||||
PropDrawMovingShapeCol sh -> \pr -> drawMovingShapeCol pr sh
|
||||
PropDoubleLampCover h -> drawDoubleLampCover h
|
||||
PropVerticalLampCover h -> drawVerticalLampCover h
|
||||
PropLampCover h -> drawLampCover h
|
||||
PropDrawToggle pd' -> propDrawToggle pd'
|
||||
PropDrawGib x -> noPic . drawGib x
|
||||
PropDrawFlatTranslate x -> \pr
|
||||
-> uncurryV translateSPf (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr
|
||||
|
||||
drawGib :: Float -> Prop -> Shape
|
||||
drawGib x pr = flesh <> skin
|
||||
where
|
||||
flesh = colorSH (dark $ dark red)
|
||||
. translateSHz (negate x)
|
||||
$ upperPrismPoly (2*x) $ square x
|
||||
skin = colorSH (_prColor pr)
|
||||
. translateSH (V3 1 1 (1 - x))
|
||||
$ upperPrismPoly (2*x) $ square x
|
||||
|
||||
propDrawToggle :: PropDraw -> Prop -> SPic
|
||||
propDrawToggle pd pr
|
||||
| not (_prToggle pr) = mempty
|
||||
| otherwise = drawProp pd pr
|
||||
|
||||
drawLampCover :: Float -> Prop -> SPic
|
||||
drawLampCover h pr = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSH (_prRot pr) $ mconcat
|
||||
[ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
||||
, translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
||||
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
||||
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
||||
, upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
|
||||
drawVerticalLampCover :: Float -> Prop -> SPic
|
||||
drawVerticalLampCover h pr =
|
||||
( translateSHz h . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSHx (_prRot pr) $ mconcat
|
||||
[
|
||||
translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
|
||||
drawMovingShape :: Prop -> Shape -> SPic
|
||||
drawMovingShape pr = noPic
|
||||
. translateSHz (_prPosZ pr)
|
||||
. uncurryV translateSHf (_prPos pr)
|
||||
. overPosSH (Q.rotate (_prQuat pr))
|
||||
|
||||
drawMovingShapeCol :: Prop -> Shape -> SPic
|
||||
drawMovingShapeCol pr = noPic
|
||||
. translateSHz (_prPosZ pr)
|
||||
. uncurryV translateSHf (_prPos pr)
|
||||
. overPosSH (Q.rotate (_prQuat pr))
|
||||
. colorSH (_prColor pr)
|
||||
|
||||
drawDoubleLampCover :: Float -> Prop -> SPic
|
||||
drawDoubleLampCover h pr =
|
||||
( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSH (_prRot pr) $ mconcat
|
||||
[ upperPrismPoly 5 $ reverse $ rectNSWE 6 5 (-6) 6
|
||||
, upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
|
||||
, upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
|
||||
, upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)]
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
+32
-47
@@ -1,16 +1,11 @@
|
||||
module Dodge.Prop.Gib where
|
||||
import Dodge.Prop.Moving
|
||||
--import Dodge.Zone
|
||||
import Dodge.Base
|
||||
import Dodge.Data
|
||||
import Dodge.Damage
|
||||
--import ShapePicture
|
||||
import Shape
|
||||
import Geometry
|
||||
import Color
|
||||
import LensHelp
|
||||
import RandomHelp
|
||||
--import Dodge.Base.NewID
|
||||
|
||||
import qualified Quaternion as Q
|
||||
import Data.List (zip4)
|
||||
@@ -19,28 +14,18 @@ import Data.Foldable
|
||||
aGib :: Prop
|
||||
aGib = PropZ
|
||||
{_prPos = 0
|
||||
,_pjStartPos = 0
|
||||
,_pjVel = 0
|
||||
,_prDraw = \pr -> drawMovingShape pr (drawGib 3 pr)
|
||||
,_pjID = 0
|
||||
,_pjUpdate = fallSmallBounce
|
||||
,_pjPosZ = 10
|
||||
,_pjVelZ = 5
|
||||
,_pjTimer = 20
|
||||
,_pjQuat = Q.axisAngle (V3 1 0 0) 0
|
||||
,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
|
||||
,_pjColor = white
|
||||
,_prStartPos = 0
|
||||
,_prVel = 0
|
||||
,_prDraw = PropDrawMovingShape (PropDrawGib 3)
|
||||
,_prID = 0
|
||||
,_prUpdate = PropFallSmallBounce
|
||||
,_prPosZ = 10
|
||||
,_prVelZ = 5
|
||||
,_prTimer = 20
|
||||
,_prQuat = Q.axisAngle (V3 1 0 0) 0
|
||||
,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
|
||||
,_prColor = white
|
||||
}
|
||||
drawGib :: Float -> Prop -> Shape
|
||||
drawGib x pr = flesh <> skin
|
||||
where
|
||||
flesh = colorSH (dark $ dark red)
|
||||
. translateSHz (negate x)
|
||||
$ upperPrismPoly (2*x) $ square x
|
||||
skin = colorSH (_pjColor pr)
|
||||
. translateSH (V3 1 1 (1 - x))
|
||||
$ upperPrismPoly (2*x) $ square x
|
||||
|
||||
|
||||
addCrGibs :: Creature -> World -> World
|
||||
addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of
|
||||
@@ -83,18 +68,18 @@ addGibsAtDir dir minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels
|
||||
|
||||
addGib4 :: Point2 -> Color -> (Point2, Float, Q.Quaternion Float, Float)
|
||||
-> World -> World
|
||||
addGib4 p col (v,zs,q,h) = plNew props pjID (aGib & prPos .~ p +.+ (5 *.* normalizeV v)
|
||||
& pjColor .~ col
|
||||
& pjVel .~ v
|
||||
& pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
||||
& pjQuat .~ q
|
||||
& pjVelZ .~ zs
|
||||
& pjPosZ .~ h
|
||||
addGib4 p col (v,zs,q,h) = plNew props prID (aGib & prPos .~ p +.+ (5 *.* normalizeV v)
|
||||
& prColor .~ col
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ zs
|
||||
& prPosZ .~ h
|
||||
)
|
||||
|
||||
addGibAt :: Float -> Color -> Point2 -> World -> World
|
||||
addGibAt h col p w = w
|
||||
& plNew props pjID gib
|
||||
& plNew props prID gib
|
||||
& randGen .~ newg
|
||||
where
|
||||
(gib,newg) = runState f $ _randGen w
|
||||
@@ -106,16 +91,16 @@ addGibAt h col p w = w
|
||||
let v = s *.* dir
|
||||
return $ aGib
|
||||
& prPos .~ p
|
||||
& pjColor .~ col
|
||||
& pjVel .~ v
|
||||
& pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
||||
& pjQuat .~ q
|
||||
& pjVelZ .~ zs
|
||||
& pjPosZ .~ h
|
||||
& prColor .~ col
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ zs
|
||||
& prPosZ .~ h
|
||||
|
||||
addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
|
||||
addGibAtDir dir h col p w = w
|
||||
& plNew props pjID gib
|
||||
& plNew props prID gib
|
||||
& randGen .~ newg
|
||||
where
|
||||
(gib,newg) = runState f $ _randGen w
|
||||
@@ -126,9 +111,9 @@ addGibAtDir dir h col p w = w
|
||||
let v = s *.* unitVectorAtAngle dir
|
||||
return $ aGib
|
||||
& prPos .~ p
|
||||
& pjColor .~ col
|
||||
& pjVel .~ v
|
||||
& pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
||||
& pjQuat .~ q
|
||||
& pjVelZ .~ zs
|
||||
& pjPosZ .~ h
|
||||
& prColor .~ col
|
||||
& prVel .~ v
|
||||
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
|
||||
& prQuat .~ q
|
||||
& prVelZ .~ zs
|
||||
& prPosZ .~ h
|
||||
|
||||
+17
-42
@@ -1,77 +1,52 @@
|
||||
module Dodge.Prop.Moving
|
||||
( drawMovingShape
|
||||
, drawMovingShapeCol
|
||||
, fallSmallBounceDamage
|
||||
( fallSmallBounceDamage
|
||||
, fallSmallBounce
|
||||
) where
|
||||
--import Dodge.Zone
|
||||
import Dodge.Base
|
||||
import Dodge.Data
|
||||
--import Dodge.Damage
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import Geometry
|
||||
--import Color
|
||||
import LensHelp
|
||||
--import RandomHelp
|
||||
--import Dodge.Base.NewID
|
||||
|
||||
import qualified Quaternion as Q
|
||||
--import Data.List (zip4)
|
||||
--
|
||||
fallSmallBounceDamage :: Prop -> World -> World
|
||||
fallSmallBounceDamage pr w = w
|
||||
& dodamage
|
||||
& props . ix (_pjID pr) %~ fallSmallBounce' w
|
||||
& props . ix (_prID pr) %~ fallSmallBounce' w
|
||||
where
|
||||
p = _prPos pr
|
||||
v = _pjVel pr
|
||||
v = _prVel pr
|
||||
dodamage
|
||||
| _pjPosZ pr < 25 = creatures %~ fmap dodamage'
|
||||
| _prPosZ pr < 25 = creatures %~ fmap dodamage'
|
||||
| otherwise = id
|
||||
dodamage' cr
|
||||
| dist (_crPos cr) p < _crRad cr + 5 = cr & crState . csDamage
|
||||
.:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _pjVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
|
||||
.:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _prVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
|
||||
| otherwise = cr
|
||||
|
||||
fallSmallBounce :: Prop -> World -> World
|
||||
fallSmallBounce pr w = w
|
||||
& props . ix (_pjID pr) %~ fallSmallBounce' w
|
||||
& props . ix (_prID pr) %~ fallSmallBounce' w
|
||||
|
||||
fallSmallBounce' :: World -> Prop -> Prop
|
||||
fallSmallBounce' w pr
|
||||
| newposz < 0 && velz < (-2) = pr
|
||||
& pjVelZ %~ ((*0.5) . negate)
|
||||
& prVelZ %~ ((*0.5) . negate)
|
||||
-- & pjPos +~ (0.5*.* vel)
|
||||
& updateWithVel (0.5 *.* vel)
|
||||
& pjVel %~ (0.5 *.*)
|
||||
& prVel %~ (0.5 *.*)
|
||||
-- & pjPos +~ (0.5*.* vel)
|
||||
| newposz < 0 = pr & pjUpdate .~ const id
|
||||
& pjZ .~ 0
|
||||
| newposz < 0 = pr & prUpdate .~ PropUpdateId
|
||||
& prPosZ .~ 0
|
||||
-- & pjQuat *~ (_pjQuatSpin pr)
|
||||
| otherwise = pr
|
||||
& pjVelZ -~ 1
|
||||
& pjPosZ +~ velz
|
||||
& prVelZ -~ 1
|
||||
& prPosZ +~ velz
|
||||
& updateWithVel vel
|
||||
& pjQuat *~ _pjQuatSpin pr
|
||||
& prQuat *~ _prQuatSpin pr
|
||||
where
|
||||
newposz = _pjPosZ pr + velz
|
||||
velz = _pjVelZ pr
|
||||
vel = _pjVel pr
|
||||
newposz = _prPosZ pr + velz
|
||||
velz = _prVelZ pr
|
||||
vel = _prVel pr
|
||||
pos = _prPos pr
|
||||
updateWithVel v = case bouncePoint (const True) 0.5 pos (pos + v) w of
|
||||
Nothing -> prPos +~ v
|
||||
Just (p,v') -> (prPos .~ p) . (pjVel .~ v')
|
||||
Just (p,v') -> (prPos .~ p) . (prVel .~ v')
|
||||
|
||||
drawMovingShape :: Prop -> Shape -> SPic
|
||||
drawMovingShape pr = noPic
|
||||
. translateSHz (_pjPosZ pr)
|
||||
. uncurryV translateSHf (_prPos pr)
|
||||
. overPosSH (Q.rotate (_pjQuat pr))
|
||||
|
||||
drawMovingShapeCol :: Prop -> Shape -> SPic
|
||||
drawMovingShapeCol pr = noPic
|
||||
. translateSHz (_pjPosZ pr)
|
||||
. uncurryV translateSHf (_prPos pr)
|
||||
. overPosSH (Q.rotate (_pjQuat pr))
|
||||
. colorSH (_pjColor pr)
|
||||
|
||||
@@ -0,0 +1,53 @@
|
||||
module Dodge.Prop.Update
|
||||
where
|
||||
import Dodge.WdP2f
|
||||
import Dodge.PrWdLsLs
|
||||
import Dodge.WorldBool
|
||||
import Dodge.Data
|
||||
import Dodge.Prop.Moving
|
||||
|
||||
import Data.Foldable
|
||||
import Control.Lens
|
||||
|
||||
updateProp :: Prop -> World -> World
|
||||
updateProp pr = case _prUpdate pr of
|
||||
PropFallSmallBounceDamage -> fallSmallBounceDamage pr
|
||||
PropFallSmallBounce -> fallSmallBounce pr
|
||||
PropUpdateId -> id
|
||||
PropRotate x -> rotateProp x pr
|
||||
PropSetToggleAnd wb pu -> propSetToggleAnd wb pu pr
|
||||
PropUpdates pus -> doPropUpdates pr pus
|
||||
PropUpdateLS lsid x -> \w -> w & lightSources . ix lsid %~ doPrWdLsLs x pr w
|
||||
PropUpdatePosition x -> propUpdatePosition x pr
|
||||
PropUpdateWhen t x -> propUpdateIf t x PropUpdateId pr
|
||||
PropUpdateAnd x y -> doPropUpdates pr [x,y]
|
||||
PropUpdateIf t x y -> propUpdateIf t x y pr
|
||||
|
||||
propUpdateIf :: WdBl -> PropUpdate -> PropUpdate -> Prop -> World -> World
|
||||
propUpdateIf wb x y pr w
|
||||
| doWdBl wb w = updateProp (pr & prUpdate .~ x) w
|
||||
| otherwise = updateProp (pr & prUpdate .~ y) w
|
||||
|
||||
|
||||
|
||||
propUpdatePosition :: WdP2f -> Prop -> World -> World
|
||||
propUpdatePosition x pr w = w
|
||||
& props . ix (_prID pr) . prPos .~ fst (doWdP2f x w)
|
||||
& props . ix (_prID pr) . prRot .~ snd (doWdP2f x w)
|
||||
|
||||
doPropUpdates :: Prop -> [PropUpdate] -> World -> World
|
||||
doPropUpdates pr pus w = foldl' f w pus
|
||||
where
|
||||
f w' pu = updateProp (pr & prUpdate .~ pu) w'
|
||||
|
||||
propSetToggleAnd :: WdBl -> PropUpdate -> Prop -> World -> World
|
||||
propSetToggleAnd wb pu pr = setToggle (doWdBl wb) pr . updateProp (pr & prUpdate .~ pu)
|
||||
-- fugly
|
||||
|
||||
setToggle :: (World -> Bool) -> Prop -> World -> World
|
||||
setToggle cond pr w = w & props . ix (_prID pr) . prToggle .~ cond w
|
||||
|
||||
rotateProp :: Float -> Prop -> World -> World
|
||||
rotateProp rotAmount pr w = w
|
||||
& props . ix (_prID pr) . prRot +~ rotAmount
|
||||
|
||||
@@ -1,6 +1,9 @@
|
||||
module Dodge.Render.ShapePicture
|
||||
( worldSPic
|
||||
) where
|
||||
import Dodge.LinearShockwave.Draw
|
||||
import Dodge.Prop.Draw
|
||||
import Dodge.TractorBeam.Draw
|
||||
import Dodge.Shockwave.Draw
|
||||
import Dodge.Tesla.Arc.Draw
|
||||
import Dodge.Laser.Draw
|
||||
@@ -62,7 +65,7 @@ singleSPic = id
|
||||
worldSPic :: Configuration -> World -> SPic
|
||||
worldSPic cfig w
|
||||
= singleSPic (mempty, extraPics cfig w)
|
||||
<> foldup (dbArg _prDraw) (filtOn _prPos _props)
|
||||
<> foldup drawProp' (filtOn _prPos _props)
|
||||
<> foldup drawProjectile (filtOn _prjPos _projectiles)
|
||||
<> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
|
||||
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
|
||||
@@ -129,6 +132,8 @@ cullPoint cfig w p
|
||||
|
||||
extraPics :: Configuration -> World -> Picture
|
||||
extraPics cfig w = pictures (_decorations w)
|
||||
<> concatMapPic drawTractorBeam (_tractorBeams w)
|
||||
<> concatMapPic drawLinearShockwave (_linearShockwaves w)
|
||||
<> concatMapPic drawShockwave (_shockwaves w)
|
||||
<> concatMapPic drawLaser (_lasersToDraw w)
|
||||
<> concatMapPic drawTeslaArc (_teslaArcs w)
|
||||
|
||||
@@ -6,7 +6,6 @@ import Dodge.Data
|
||||
import Dodge.Default.Door
|
||||
import Dodge.Cleat
|
||||
import Dodge.RoomLink
|
||||
import Dodge.Base
|
||||
import Dodge.Tree
|
||||
import Dodge.Default.Room
|
||||
import Dodge.LevelGen.Data
|
||||
@@ -49,7 +48,7 @@ twinSlowDoorRoom w h x = defaultRoom
|
||||
$ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h))
|
||||
$ ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-x) 1) (V2 (-x) h))
|
||||
$ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampheight)))
|
||||
$ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampheight
|
||||
$ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h-1)) lampheight
|
||||
]
|
||||
, _rmBound = ps
|
||||
, _rmName = "twinSlowDoorRoom"
|
||||
@@ -58,13 +57,9 @@ twinSlowDoorRoom w h x = defaultRoom
|
||||
where
|
||||
thewall = switchWallCol red
|
||||
wlSpeed = 0.5
|
||||
addColorChange lsid drid = over pjUpdate $ dbArgChain $ const f
|
||||
where
|
||||
f u | _drStatus (_doors u IM.! drid) == DoorHalfway
|
||||
= u & updatelscol (V3 8 0 0)
|
||||
| otherwise = u & updatelscol 0.7
|
||||
updatelscol c = lightSources . ix lsid . lsParam . lsCol .~ c
|
||||
drmoving i w' = DoorHalfway == _drStatus (_doors w' IM.! i)
|
||||
addColorChange lsid drid = over prUpdate $ PropUpdateAnd $ PropUpdateIf (WdBlDoorMoving drid)
|
||||
(PropUpdateLS lsid (PrWdLsSetColor (V3 8 0 0)))
|
||||
(PropUpdateLS lsid (PrWdLsSetColor 0.7))
|
||||
lampheight = 41
|
||||
ps =
|
||||
[rectNSWE h 0 (-w) w
|
||||
@@ -107,7 +102,7 @@ addButtonSlowDoor x h rm = do
|
||||
openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3*x/2) (-x/2)
|
||||
belowH y = (sndV2 . fst) y < h - 40
|
||||
aboveH y = (sndV2 . fst) y > h + 40
|
||||
amountedlight dr xoff mpl = Just . moveLSThen (getdoorpos (fromJust $ _plMID dr))
|
||||
amountedlight dr xoff mpl = Just . moveLSThen (WdP2fDoorPosition (fromJust $ _plMID dr))
|
||||
(V3 15 xoff 89) (aShape (V2 15 0) (V3 15 xoff 90))
|
||||
$ \plls plpr -> Just $ ptCont (PutWorldUpdate (const $ setmount dr plls plpr))
|
||||
$ const mpl
|
||||
@@ -126,8 +121,6 @@ addButtonSlowDoor x h rm = do
|
||||
$ amountedlight dr2 50
|
||||
$ amountedlight dr2 (-50)
|
||||
Nothing
|
||||
getdoorpos drid w = let Just (a,b) = w ^? doors . ix drid . drPos
|
||||
in (b, argV (a-.-b))
|
||||
col = dim $ light red
|
||||
cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
|
||||
|
||||
|
||||
@@ -0,0 +1,24 @@
|
||||
module Dodge.TractorBeam.Draw
|
||||
where
|
||||
import Dodge.Data.TractorBeam
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
drawTractorBeam :: TractorBeam -> Picture
|
||||
drawTractorBeam = tractorSPic
|
||||
|
||||
tractorSPic :: TractorBeam -> Picture
|
||||
tractorSPic pj = setLayer BloomNoZWrite $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon
|
||||
[ spos -- not sure if this is anticlockwise...
|
||||
, spos +.+ size *.* (d +.+ n)
|
||||
, xpos +.+ size *.* n
|
||||
, xpos -.- size *.* n
|
||||
, spos +.+ size *.* (d -.- n)
|
||||
]
|
||||
where
|
||||
size = fromIntegral (_tbTime pj)
|
||||
spos = _tbPos pj
|
||||
xpos = _tbStartPos pj
|
||||
d = squashNormalizeV $ spos -.- xpos
|
||||
n = vNormal d
|
||||
col = mixColors 0.5 0.5 white blue
|
||||
@@ -0,0 +1,45 @@
|
||||
module Dodge.TractorBeam.Update
|
||||
where
|
||||
import Geometry
|
||||
import Dodge.Data
|
||||
import qualified IntMapHelp as IM
|
||||
import Control.Lens
|
||||
|
||||
updateTractorBeam :: World -> TractorBeam -> (World, Maybe TractorBeam)
|
||||
updateTractorBeam w pj
|
||||
| _tbTime pj <= 0 = (w, Nothing)
|
||||
| otherwise = (w
|
||||
& creatures %~ IM.map (tractCr pullVel pos outpos)
|
||||
& floorItems %~ IM.map (tractFlIt pullVel pos outpos)
|
||||
, Just (pj & tbTime -~ 1))
|
||||
where
|
||||
pullVel = _tbVel pj
|
||||
pos = _tbPos pj
|
||||
outpos = _tbStartPos pj
|
||||
|
||||
tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem
|
||||
tractFlIt q p1 outpos it
|
||||
| segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
|
||||
| otherwise = it
|
||||
|
||||
tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature
|
||||
tractCr q p1 outpos cr
|
||||
| segOnCirc p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
|
||||
| otherwise = cr
|
||||
|
||||
tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2
|
||||
tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4)
|
||||
where
|
||||
x' = abs y + 1
|
||||
y = errorClosestPointOnLineParam 1 p1 p3 p
|
||||
m | dist p p1 < 350 = 1
|
||||
| otherwise = (400 - dist p p1) / 50
|
||||
g x | x > 5 = (10 - x) / 250
|
||||
| x > 1 = 0.02
|
||||
| x > -1 = x * 0.02
|
||||
| x > -5 = -0.02
|
||||
| otherwise = (x - 10) / 250
|
||||
--p4 = vNormal p5
|
||||
p4 = vNormal $ squashNormalizeV q
|
||||
p3 = p1 +.+ p4
|
||||
|
||||
+12
-2
@@ -4,6 +4,9 @@ Module : Dodge.Update
|
||||
Description : Simulation update
|
||||
-}
|
||||
module Dodge.Update ( updateUniverse ) where
|
||||
import Dodge.TractorBeam.Update
|
||||
import Dodge.Prop.Update
|
||||
import Dodge.LinearShockwave.Update
|
||||
import Dodge.Shockwave.Update
|
||||
import Dodge.Tesla.Arc
|
||||
import Dodge.Laser.Update
|
||||
@@ -61,7 +64,7 @@ updateUniverse u = case _menuLayers u of
|
||||
(OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
|
||||
( updateParticles
|
||||
. (radarBlips .~ [])
|
||||
. updateIMl _props _pjUpdate
|
||||
-- . updateIMl _props _pjUpdate
|
||||
. updateLightSources
|
||||
. updateClouds )
|
||||
(_ : _) -> u
|
||||
@@ -100,7 +103,9 @@ functionalUpdate w = checkEndGame
|
||||
. over uvWorld updateBeams
|
||||
. over uvWorld updateLasers
|
||||
. over uvWorld updateTeslaArcs
|
||||
. over uvWorld (updateIMl _props _pjUpdate )
|
||||
. over uvWorld updateTractorBeams
|
||||
. over uvWorld (updateIMl' _linearShockwaves updateLinearShockwave)
|
||||
. over uvWorld (updateIMl' _props updateProp )
|
||||
. over uvWorld (updateIMl' _projectiles updateProjectile)
|
||||
. over uvWorld updateLightSources
|
||||
. over uvWorld updateClouds
|
||||
@@ -238,6 +243,11 @@ updateTeslaArcs w = w' & teslaArcs .~ catMaybes newtas
|
||||
where
|
||||
(w',newtas) = mapAccumR moveTeslaArc w $ _teslaArcs w
|
||||
|
||||
updateTractorBeams :: World -> World
|
||||
updateTractorBeams w = w' & tractorBeams .~ catMaybes newtas
|
||||
where
|
||||
(w',newtas) = mapAccumR updateTractorBeam w $ _tractorBeams w
|
||||
|
||||
|
||||
{- Apply internal particle updates, delete 'Nothing's. -}
|
||||
updateBullets :: World -> World
|
||||
|
||||
@@ -0,0 +1 @@
|
||||
module Dodge.WdP2 where
|
||||
@@ -0,0 +1,12 @@
|
||||
module Dodge.WdP2f
|
||||
where
|
||||
import Geometry.Vector
|
||||
import Dodge.Data
|
||||
import Geometry.Data
|
||||
import Control.Lens
|
||||
|
||||
doWdP2f :: WdP2f -> World -> (Point2,Float)
|
||||
doWdP2f x = case x of
|
||||
WdP2f0 -> const (0,0)
|
||||
WdP2fDoorPosition drid -> \w -> let Just (a,b) = w ^? doors . ix drid . drPos
|
||||
in (b, argV (a-.-b))
|
||||
@@ -0,0 +1,12 @@
|
||||
module Dodge.WorldBool
|
||||
where
|
||||
import Dodge.Data
|
||||
import Data.Maybe
|
||||
import Control.Lens
|
||||
|
||||
doWdBl :: WdBl -> World -> Bool
|
||||
doWdBl wb w = case wb of
|
||||
WdTrig i -> fromMaybe False $ w ^? triggers . ix i
|
||||
WdBlDoorMoving i -> fromMaybe False $ do
|
||||
dr <- w ^? doors . ix i
|
||||
return (DoorHalfway == _drStatus dr)
|
||||
+3
-3
@@ -32,17 +32,17 @@ data ShapeObj = ShapeObj
|
||||
{ _shType :: ShapeType
|
||||
, _shVs :: [ShapeV]
|
||||
}
|
||||
deriving ()
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
|
||||
newtype ShapeType = TopPrism Int
|
||||
deriving (Eq,Ord,Show)
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
|
||||
-- edges are given by four consecutive points
|
||||
data ShapeV = ShapeV
|
||||
{_svPos :: Point3
|
||||
,_svCol :: Point4
|
||||
}
|
||||
deriving (Eq,Ord,Show)
|
||||
deriving (Eq,Ord,Show,Read)
|
||||
pairToSV :: (Point3,Point4) -> ShapeV
|
||||
{-# INLINE pairToSV #-}
|
||||
pairToSV = uncurry ShapeV
|
||||
|
||||
Reference in New Issue
Block a user