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

Tweak turrets

Browse Source
This commit is contained in:
justin
2022-07-28 13:46:22 +01:00
parent 8aeabf3f6c
commit ec4ff84c46
10 changed files with 337 additions and 308 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Update.hs
-2
View File
@@ -7,7 +7,6 @@ import Dodge.Creature.State
import Dodge.Data.World import Dodge.Data.World
import Dodge.Humanoid import Dodge.Humanoid
import Dodge.Lampoid import Dodge.Lampoid
import Dodge.Turretoid
import LensHelp import LensHelp
import System.Random import System.Random
@@ -15,7 +14,6 @@ updateCreature :: Creature -> World -> World
updateCreature cr = case _crType cr of updateCreature cr = case _crType cr of
Lampoid{} -> updateLampoid cr Lampoid{} -> updateLampoid cr
Humanoid{} -> updateHumanoid cr Humanoid{} -> updateHumanoid cr
Turretoid{} -> updateTurretoid cr
Barreloid{} -> updateBarreloid cr Barreloid{} -> updateBarreloid cr
NonDrawnCreature -> id NonDrawnCreature -> id
src/Dodge/Data/Creature/Misc.hs
-1
View File
@@ -68,7 +68,6 @@ data CreatureType
} }
| Barreloid {_barrelType :: BarrelType} | Barreloid {_barrelType :: BarrelType}
| Lampoid {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int} | Lampoid {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int}
| Turretoid
| NonDrawnCreature | NonDrawnCreature
deriving (Eq, Ord, Show, Read) deriving (Eq, Ord, Show, Read)
src/Dodge/HeldUse.hs
+1 -1
View File
@@ -490,7 +490,7 @@ coneRandItemParams = do
mcShootLaser :: Item -> Machine -> World -> World mcShootLaser :: Item -> Machine -> World -> World
mcShootLaser it mc = cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir mcShootLaser it mc = cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
where where
pos = _mcPos mc pos = _mcPos mc +.+ 20 *.* unitVectorAtAngle dir
dir = mc ^?! mcType . _McTurret . tuDir dir = mc ^?! mcType . _McTurret . tuDir
phasev = _phaseV . _itParams $ it phasev = _phaseV . _itParams $ it
dam = _lasDamage $ _itParams it dam = _lasDamage $ _itParams it
src/Dodge/Item/Draw.hs
+20 -1
View File
@@ -6,9 +6,10 @@ module Dodge.Item.Draw (
) where ) where
import Control.Lens import Control.Lens
import Data.Maybe
import Dodge.Creature.HandPos
import Dodge.Data.Creature import Dodge.Data.Creature
import Dodge.Item.Draw.SPic import Dodge.Item.Draw.SPic
import Dodge.Item.Equipment.Shape
import Dodge.Item.HeldOffset import Dodge.Item.HeldOffset
import ShapePicture import ShapePicture
@@ -18,3 +19,21 @@ itemEquipPict cr it = case it ^. itUse of
ituse -> case ituse ^? equipEffect of ituse -> case ituse ^? equipEffect of
Just _ -> pictureOnEquip (itemSPic it) cr it Just _ -> pictureOnEquip (itemSPic it) cr it
Nothing -> mempty Nothing -> mempty
pictureOnEquip :: SPic -> Creature -> Item -> SPic
pictureOnEquip sp cr itm = fromMaybe mempty $ do
i <- itm ^? itLocation . ipInvID
epos <- cr ^? crInvEquipped . ix i
return $ equipPosition epos cr sp
equipPosition :: EquipPosition -> Creature -> SPic -> SPic
equipPosition epos cr sh = case epos of
OnLeftWrist -> translateToLeftWrist cr sh
OnRightWrist -> translateToRightWrist cr sh
OnLegs ->
translateToLeftLeg cr sh
<> translateToRightLeg cr (mirrorSPxz sh)
OnHead -> translateToHead cr sh
OnChest -> translateToChest cr sh
OnBack -> translateToBack cr sh
OnSpecial -> sh
src/Dodge/Item/Equipment/Shape.hs
-25
View File
@@ -1,25 +0,0 @@
module Dodge.Item.Equipment.Shape where
import Data.Maybe
import Dodge.Creature.HandPos
import Dodge.Data.Creature
import LensHelp
import ShapePicture
pictureOnEquip :: SPic -> Creature -> Item -> SPic
pictureOnEquip sp cr itm = fromMaybe mempty $ do
i <- itm ^? itLocation . ipInvID
epos <- cr ^? crInvEquipped . ix i
return $ equipPosition epos cr sp
equipPosition :: EquipPosition -> Creature -> SPic -> SPic
equipPosition epos cr sh = case epos of
OnLeftWrist -> translateToLeftWrist cr sh
OnRightWrist -> translateToRightWrist cr sh
OnLegs ->
translateToLeftLeg cr sh
<> translateToRightLeg cr (mirrorSPxz sh)
OnHead -> translateToHead cr sh
OnChest -> translateToChest cr sh
OnBack -> translateToBack cr sh
OnSpecial -> sh
src/Dodge/Item/HeldOffset.hs
+18 -8
View File
@@ -3,35 +3,42 @@ module Dodge.Item.HeldOffset where
import Data.Maybe import Data.Maybe
import Dodge.Creature.HandPos import Dodge.Creature.HandPos
import Dodge.Data.Creature import Dodge.Data.Creature
import Dodge.Data.Machine
import Geometry import Geometry
import LensHelp import LensHelp
turretItemOffset :: Item -> Turret -> Machine -> Point3 -> Point3
turretItemOffset it tu mc =
rotate3 (_tuDir tu - _mcDir mc) . (+.+.+ V3 0 0 shoulderHeight)
. transToHandle it
transToHandle :: Item -> Point3 -> Point3
transToHandle itm = fromMaybe id $ do
x <- itm ^? itUse . heldAim . aimHandlePos
return (-.-.- V3 x 0 0)
heldItemOffset :: Item -> Creature -> Point3 -> Point3 heldItemOffset :: Item -> Creature -> Point3 -> Point3
heldItemOffset itm cr heldItemOffset itm cr
| isSelected && _posture (_crStance cr) == Aiming = | isSelected && _posture (_crStance cr) == Aiming =
(+.+.+ V3 (aimingWeaponZeroPos cr itm) 0 shoulderD) (+.+.+ V3 (aimingWeaponZeroPos cr itm) 0 shoulderHeight)
| isSelected && isTwoHandFlat = | isSelected && isTwoHandFlat =
(+.+.+ V3 (_crRad cr) 0 handD) (+.+.+ V3 (_crRad cr) 0 handD)
. rotate3 (twoFlatHRot cr) . rotate3 (twoFlatHRot cr)
. transToHandle . transToHandle itm
| isSelected && isOneHand = | isSelected && isOneHand =
(+.+.+ V3 0 0 handD) (+.+.+ V3 0 0 handD)
. (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0) . (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0)
. (+.+.+ V3 (-2) 0 0) . (+.+.+ V3 (-2) 0 0)
. transToHandle . transToHandle itm
| isSelected = | isSelected =
(+.+.+ V3 0 0 handD) (+.+.+ V3 0 0 handD)
. (+.+.+ V3 (_crRad cr) 0 0) . (+.+.+ V3 (_crRad cr) 0 0)
. rotate3 (strideRot cr + 1.2) . rotate3 (strideRot cr + 1.2)
. (+.+.+ V3 (-5) 0 0) . (+.+.+ V3 (-5) 0 0)
-- . (+.+.+ V3 (-5) 0 0) -- . (+.+.+ V3 (-5) 0 0)
. transToHandle . transToHandle itm
| otherwise = id | otherwise = id
where where
transToHandle = fromMaybe id $ do
x <- itm ^? itUse . heldAim . aimHandlePos
return (-.-.- V3 x 0 0)
shoulderD = 18
handD = 15 handD = 15
isSelected = _itIsHeld itm isSelected = _itIsHeld itm
handPos = case cr ^? crStance . carriage of handPos = case cr ^? crStance . carriage of
@@ -46,6 +53,9 @@ heldItemOffset itm cr
f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
sLen = _strideLength $ _crStance cr sLen = _strideLength $ _crStance cr
shoulderHeight :: Float
shoulderHeight = 18
strideRot :: Creature -> Float strideRot :: Creature -> Float
strideRot cr = case cr ^? crStance . carriage of strideRot cr = case cr ^? crStance . carriage of
Just (Walking x LeftForward) -> f x Just (Walking x LeftForward) -> f x
src/Dodge/Machine/Draw.hs
+7 -4
View File
@@ -1,7 +1,8 @@
module Dodge.Machine.Draw module Dodge.Machine.Draw
where where
import Dodge.Item.HeldOffset
import Dodge.Item.Draw.SPic
import Dodge.Placement.TopDecoration import Dodge.Placement.TopDecoration
--import Dodge.Placement.Instance.Turret
import Shape import Shape
import Picture import Picture
import Geometry import Geometry
@@ -38,11 +39,13 @@ terminalShape mc = colorSH col (prismPoly
col = _mcColor mc col = _mcColor mc
drawTurret :: Turret -> Machine -> SPic drawTurret :: Turret -> Machine -> SPic
drawTurret _ mc = drawTurret tu mc =
( rotateSH (- _mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square w) ( colorSH (_mcColor mc) $ upperPrismPoly 20 (square w)
, mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc ) , mempty
) )
<> overPosSP (turretItemOffset it tu mc) (itemSPic it)
where where
it = _tuWeapon tu
w = _mcWidth mc w = _mcWidth mc
sensorSPic :: (PaletteColor, DecorationShape) -> Machine -> SPic sensorSPic :: (PaletteColor, DecorationShape) -> Machine -> SPic
src/Dodge/Machine/Update.hs
+3 -9
View File
@@ -16,6 +16,7 @@ import Dodge.WorldEvent.Explosion
import Geometry import Geometry
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import LensHelp import LensHelp
import Control.Monad
updateMachine :: Machine -> World -> World updateMachine :: Machine -> World -> World
updateMachine mc updateMachine mc
@@ -32,7 +33,6 @@ mcTurretUpdate mc = case mc ^? mcType . _McTurret of
Just tu -> updateTurret (_tuTurnSpeed tu) mc Just tu -> updateTurret (_tuTurnSpeed tu) mc
_ -> id _ -> id
-- this needs a major cleanup
updateTurret :: Float -> Machine -> World -> World updateTurret :: Float -> Machine -> World -> World
updateTurret rotSpeed mc w updateTurret rotSpeed mc w
| _mcHP mc < 1 = | _mcHP mc < 1 =
@@ -57,13 +57,12 @@ updateTurret rotSpeed mc w
mcid = _mcID mc mcid = _mcID mc
ypos = _crPos $ you w ypos = _crPos $ you w
mcpos = _mcPos mc mcpos = _mcPos mc
--mcdir = _mcDir mc
seesYou = hasLOSIndirect mcpos ypos w seesYou = hasLOSIndirect mcpos ypos w
(elecDams, dams) = partition isElectrical $ _mcDamage mc (elecDams, dams) = partition isElectrical $ _mcDamage mc
dam = sum $ map _dmAmount dams dam = sum $ map _dmAmount dams
elecDam = sum $ map _dmAmount elecDams elecDam = sum $ map _dmAmount elecDams
doTurn doTurn
| seesYou = cWorld . machines . ix mcid . mcDir %~ turnTo rotSpeed mcpos ypos | seesYou = cWorld . machines . ix mcid . mcType . _McTurret . tuDir %~ turnTo rotSpeed mcpos ypos
| otherwise = id | otherwise = id
closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1 closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
updateFiringStatus updateFiringStatus
@@ -75,14 +74,9 @@ mcUseItem mc = fromMaybe id $ do
tu <- mc ^? mcType . _McTurret tu <- mc ^? mcType . _McTurret
let it = tu ^. tuWeapon let it = tu ^. tuWeapon
hit <- it ^? itType . iyBase . ibtHeld hit <- it ^? itType . iyBase . ibtHeld
guard (_tuFireTime tu > 0)
return $ mcUseHeld hit it mc return $ mcUseHeld hit it mc
-- maybeFire
-- | _tuFireTime (_mcType mc) > 0 =
-- fromMaybe id $ do
-- return $ tuUseItem
-- | otherwise = id
mcSensorTriggerUpdate :: Machine -> World -> World mcSensorTriggerUpdate :: Machine -> World -> World
mcSensorTriggerUpdate mc = fromMaybe id $ do mcSensorTriggerUpdate mc = fromMaybe id $ do
trid <- mc ^? mcMounts . ix ObTrigger trid <- mc ^? mcMounts . ix ObTrigger
src/Dodge/Render/ShapePicture.hs
+278 -239
View File
@@ -1,113 +1,118 @@
module Dodge.Render.ShapePicture module Dodge.Render.ShapePicture (
( worldSPic worldSPic,
) where ) where
import Dodge.Block.Draw
import Dodge.Machine.Draw
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
import Dodge.Cloud.Draw
import Dodge.Zoning
import Dodge.Button.Draw
import Dodge.LightSource.Draw
import Dodge.Targeting.Draw
import Dodge.Beam.Draw
import Dodge.RadarSweep.Draw
import Dodge.Projectile.Draw
import Dodge.Item.Draw.SPic
import Dodge.EnergyBall.Draw
import Dodge.Creature.Picture.Awareness
import Dodge.Creature.Picture
import Dodge.Flame.Draw
import Dodge.Bullet.Draw
import Dodge.Spark.Draw
import Dodge.RadarBlip
import Dodge.Flare
import Dodge.ShortShow
import Dodge.Data.Config
import Dodge.Render.InfoBox
import Dodge.Debug.Picture
import Dodge.Picture.SizeInvariant
import Dodge.Zone
import Dodge.Data.World
import Dodge.Base
import Dodge.SoundLogic.LoadSound
import Dodge.Graph
import Dodge.GameRoom
import Dodge.Update.Camera
import Dodge.Render.List
import Dodge.Path
import Geometry
import Geometry.Zone
import ShapePicture
import Picture
import Sound.Data
import Geometry.ConvexPoly
import ShortShow
import Polyhedra
import StreamingHelp
import qualified IntMapHelp as IM -- Lazy?
import qualified Data.Map.Strict as M
import Control.Lens import Control.Lens
import Data.Maybe
import qualified Streaming.Prelude as S
import qualified Data.Graph.Inductive as FGL
import qualified Data.Set as Set
import Padding
import Data.Foldable import Data.Foldable
import qualified Data.Graph.Inductive as FGL
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as Set
import Dodge.Base
import Dodge.Beam.Draw
import Dodge.Block.Draw
import Dodge.Bullet.Draw
import Dodge.Button.Draw
import Dodge.Cloud.Draw
import Dodge.Creature.Picture
import Dodge.Creature.Picture.Awareness
import Dodge.Data.Config
import Dodge.Data.World
import Dodge.Debug.Picture
import Dodge.EnergyBall.Draw
import Dodge.Flame.Draw
import Dodge.Flare
import Dodge.GameRoom
import Dodge.Graph
import Dodge.Item.Draw.SPic
import Dodge.Laser.Draw
import Dodge.LightSource.Draw
import Dodge.LinearShockwave.Draw
import Dodge.Machine.Draw
import Dodge.Path
import Dodge.Picture.SizeInvariant
import Dodge.Projectile.Draw
import Dodge.Prop.Draw
import Dodge.RadarBlip
import Dodge.RadarSweep.Draw
import Dodge.Render.InfoBox
import Dodge.Render.List
import Dodge.Shockwave.Draw
import Dodge.ShortShow
import Dodge.SoundLogic.LoadSound
import Dodge.Spark.Draw
import Dodge.Targeting.Draw
import Dodge.Tesla.Arc.Draw
import Dodge.TractorBeam.Draw
import Dodge.Update.Camera
import Dodge.Zone
import Dodge.Zoning
import Geometry
import Geometry.ConvexPoly
import Geometry.Zone
import qualified IntMapHelp as IM
import Padding
import Picture
import Polyhedra
import ShapePicture
import ShortShow
import Sound.Data
import qualified Streaming.Prelude as S
singleSPic :: SPic -> SPic singleSPic :: SPic -> SPic
singleSPic = id singleSPic = id
worldSPic :: Configuration -> World -> SPic worldSPic :: Configuration -> World -> SPic
worldSPic cfig w worldSPic cfig w =
= singleSPic (mempty, extraPics cfig w) singleSPic (mempty, extraPics cfig w)
<> 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)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes) <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
<> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses) <> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
<> foldup drawCreature (filtOn _crPos _creatures) <> foldup drawCreature (filtOn _crPos _creatures)
<> foldup floorItemSPic (filtOn _flItPos _floorItems) <> foldup floorItemSPic (filtOn _flItPos _floorItems)
<> foldup btSPic (filtOn _btPos _buttons) <> foldup btSPic (filtOn _btPos _buttons)
<> foldup mcSPic (filtOn _mcPos _machines) <> foldup mcSPic (filtOn _mcPos _machines)
<> singleSPic (anyTargeting cfig w) <> singleSPic (anyTargeting cfig w)
where where
foldup = foldMap' foldup = foldMap'
filtOn f g = IM.filter (pointIsClose . f) (g (_cWorld w)) filtOn f g = IM.filter (pointIsClose . f) (g (_cWorld w))
pointIsClose = cullPoint cfig w pointIsClose = cullPoint cfig w
anyTargeting :: Configuration -> World -> SPic anyTargeting :: Configuration -> World -> SPic
anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr) anyTargeting cfig w = (mempty, pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
where where
cr = you w cr = you w
f it = fmap (\g -> drawTargeting g it cr cfig w) (it ^? itTargeting . tgDraw) f it = fmap (\g -> drawTargeting g it cr cfig w) (it ^? itTargeting . tgDraw)
drawCreature :: Creature -> SPic drawCreature :: Creature -> SPic
drawCreature cr = case _crType cr of drawCreature cr = case _crType cr of
Humanoid {} -> basicCrPict cr Humanoid{} -> basicCrPict cr
Barreloid {} -> picAtCrPos1 (setDepth 20 $ pictures Barreloid{} ->
[ color orange $ circleSolid 10 picAtCrPos1
, setDepth 0.049 . color (greyN 0.5) $ circleSolid 8 ( setDepth 20 $
, color (greyN 0.5) $ circleSolid 8 pictures
]) cr [ color orange $ circleSolid 10
Lampoid{_lampHeight=h} -> picAtCrPosNoRot1 (lampCrPic h) cr , setDepth 0.049 . color (greyN 0.5) $ circleSolid 8
Turretoid -> mempty , color (greyN 0.5) $ circleSolid 8
]
)
cr
Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr
NonDrawnCreature -> mempty NonDrawnCreature -> mempty
lampCrPic :: Float -> Picture lampCrPic :: Float -> Picture
lampCrPic h = pictures lampCrPic h =
[ setLayer BloomLayer (setDepth h . color white $ circleSolid 3) pictures
, foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1) [ setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
] , foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h -1)
]
where where
f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
--DrawnCreature f -> f cr
-- --DrawnCreature f -> f cr
--
picAtCrPosNoRot1 :: Picture -> Creature -> SPic picAtCrPosNoRot1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-} --{-# INLINE picAtCrPos #-}
picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic
@@ -117,14 +122,16 @@ picAtCrPos1 :: Picture -> Creature -> SPic
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 = uncurryV translateSPf (fpos x) shiftDraw fpos fdir fdraw x =
. rotateSP (fdir x) uncurryV translateSPf (fpos x)
$ fdraw x x . rotateSP (fdir x)
$ fdraw x x
shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
shiftDraw' fpos fdir fdraw x = uncurryV translateSPf (fpos x) shiftDraw' fpos fdir fdraw x =
. rotateSP (fdir x) uncurryV translateSPf (fpos x)
$ fdraw x . rotateSP (fdir x)
$ fdraw x
cullPoint :: Configuration -> World -> Point2 -> Bool cullPoint :: Configuration -> World -> Point2 -> Bool
cullPoint cfig w p cullPoint cfig w p
@@ -132,78 +139,79 @@ cullPoint cfig w p
| otherwise = dist (_cameraCenter (_cWorld w)) p < _viewDistance (_cWorld w) | otherwise = dist (_cameraCenter (_cWorld w)) p < _viewDistance (_cWorld w)
extraPics :: Configuration -> World -> Picture extraPics :: Configuration -> World -> Picture
extraPics cfig w = pictures (_decorations (_cWorld w)) extraPics cfig w =
<> concatMapPic drawTractorBeam (_tractorBeams (_cWorld w)) pictures (_decorations (_cWorld w))
<> concatMapPic drawLinearShockwave (_linearShockwaves (_cWorld w)) <> concatMapPic drawTractorBeam (_tractorBeams (_cWorld w))
<> concatMapPic drawShockwave (_shockwaves (_cWorld w)) <> concatMapPic drawLinearShockwave (_linearShockwaves (_cWorld w))
<> concatMapPic drawLaser (_lasersToDraw (_cWorld w)) <> concatMapPic drawShockwave (_shockwaves (_cWorld w))
<> concatMapPic drawTeslaArc (_teslaArcs (_cWorld w)) <> concatMapPic drawLaser (_lasersToDraw (_cWorld w))
-- <> concatMapPic drawParticle (_particles w) <> concatMapPic drawTeslaArc (_teslaArcs (_cWorld w))
<> concatMapPic drawRadarSweep (_radarSweeps (_cWorld w)) -- <> concatMapPic drawParticle (_particles w)
<> concatMapPic drawFlame (_flames (_cWorld w)) <> concatMapPic drawRadarSweep (_radarSweeps (_cWorld w))
<> concatMapPic drawEnergyBall (_energyBalls (_cWorld w)) <> concatMapPic drawFlame (_flames (_cWorld w))
<> concatMapPic drawSpark (_sparks (_cWorld w)) <> concatMapPic drawEnergyBall (_energyBalls (_cWorld w))
<> concatMapPic drawBul (_bullets (_cWorld w)) <> concatMapPic drawSpark (_sparks (_cWorld w))
<> concatMapPic drawBlip (_radarBlips (_cWorld w)) <> concatMapPic drawBul (_bullets (_cWorld w))
<> concatMapPic drawFlare (_flares (_cWorld w)) <> concatMapPic drawBlip (_radarBlips (_cWorld w))
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams (_cWorld w)) <> concatMapPic drawFlare (_flares (_cWorld w))
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams (_cWorld w)) <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams (_cWorld w))
<> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources (_cWorld w)) <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams (_cWorld w))
<> testPic cfig w <> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources (_cWorld w))
<> concatMapPic clDraw (_clouds (_cWorld w) ) <> testPic cfig w
<> concatMapPic ppDraw (_pressPlates (_cWorld w) ) <> concatMapPic clDraw (_clouds (_cWorld w))
<> viewClipBounds cfig w <> concatMapPic ppDraw (_pressPlates (_cWorld w))
<> debugDraw cfig w <> viewClipBounds cfig w
<> debugDraw cfig w
debugDraw :: Configuration -> World -> Picture debugDraw :: Configuration -> World -> Picture
{-# INLINE debugDraw #-} {-# INLINE debugDraw #-}
debugDraw cfig w debugDraw cfig w
| Show_debug `Set.member` _debug_booleans cfig = | Show_debug `Set.member` _debug_booleans cfig =
pic pic
<> <> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts)
setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
| otherwise = mempty | otherwise = mempty
where where
(ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig) (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
debugDraw' :: Configuration -> World -> DebugBool -> ([String],Picture) debugDraw' :: Configuration -> World -> DebugBool -> ([String], Picture)
{-# INLINE debugDraw' #-} {-# INLINE debugDraw' #-}
debugDraw' cfig w bl = case bl of debugDraw' cfig w bl = case bl of
Show_debug -> lstring "Show debug" Show_debug -> lstring "Show debug"
Noclip -> lstring "Noclip" Noclip -> lstring "Noclip"
Remove_LOS -> lstring "No line of sight" Remove_LOS -> lstring "No line of sight"
Cull_more_lights -> lstring "Cull more lights" Cull_more_lights -> lstring "Cull more lights"
Close_shape_culling -> lstring "Close shape culling" Close_shape_culling -> lstring "Close shape culling"
Bound_box_screen -> lstring "bound box screen, this should be moved" Bound_box_screen -> lstring "bound box screen, this should be moved"
Show_ms_frame -> rdraw mempty Show_ms_frame -> rdraw mempty
View_boundaries -> rdraw $ viewBoundaries w View_boundaries -> rdraw $ viewBoundaries w
Show_bound_box -> rdraw $ drawBoundingBox w Show_bound_box -> rdraw $ drawBoundingBox w
Show_wall_search_rays -> rdraw $ drawWallSearchRays w Show_wall_search_rays -> rdraw $ drawWallSearchRays w
Show_dda_test -> rdraw $ drawDDATest w Show_dda_test -> rdraw $ drawDDATest w
Show_far_wall_detect -> rdraw $ drawFarWallDetect w Show_far_wall_detect -> rdraw $ drawFarWallDetect w
Show_select -> rdraw $ drawWorldSelect w Show_select -> rdraw $ drawWorldSelect w
Inspect_wall -> rdraw $ drawInspectWalls w Inspect_wall -> rdraw $ drawInspectWalls w
Cr_awareness -> rdraw $ drawCreatureDisplayTexts w Cr_awareness -> rdraw $ drawCreatureDisplayTexts w
Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
Cr_status -> rdraw $ drawCrInfo cfig w Cr_status -> rdraw $ drawCrInfo cfig w
Mouse_position -> rdraw $ drawMousePosition cfig w Mouse_position -> rdraw $ drawMousePosition cfig w
Walls_info -> rdraw $ drawWlIDs cfig w Walls_info -> rdraw $ drawWlIDs cfig w
Pathing -> rdraw $ drawPathing cfig w Pathing -> rdraw $ drawPathing cfig w
Show_nodes_near_select -> rdraw $ drawNodesNearSelect w Show_nodes_near_select -> rdraw $ drawNodesNearSelect w
Show_path_between -> rdraw $ drawPathBetween w Show_path_between -> rdraw $ drawPathBetween w
where where
lstring str = ([str],mempty) lstring str = ([str], mempty)
rdraw pic = (mempty,pic) rdraw pic = (mempty, pic)
drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures (_cWorld w)) drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures (_cWorld w))
drawPathBetween :: World -> Picture drawPathBetween :: World -> Picture
drawPathBetween w = setLayer DebugLayer drawPathBetween w =
$ color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist) setLayer DebugLayer $
<> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp) color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
<> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep) <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w) <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
where where
nodepos = (`getNodePos` w) nodepos = (`getNodePos` w)
nodelist = makePathBetween sp ep w nodelist = makePathBetween sp ep w
@@ -211,25 +219,28 @@ drawPathBetween w = setLayer DebugLayer
ep = _rSelect w ep = _rSelect w
drawNodesNearSelect :: World -> Picture drawNodesNearSelect :: World -> Picture
drawNodesNearSelect w = setLayer DebugLayer drawNodesNearSelect w =
$ runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp)) setLayer DebugLayer $
<> color green (drawCross sp) runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp))
<> color green (drawCross sp)
where where
sp = _lSelect w sp = _lSelect w
drawInspectWalls :: World -> Picture drawInspectWalls :: World -> Picture
drawInspectWalls w = foldMap (drawInspectWall w) drawInspectWalls w =
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) foldMap (drawInspectWall w) $
$ IM.elems $ _walls (_cWorld w) filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $
IM.elems $ _walls (_cWorld w)
where where
(a,b) = _lLine w (a, b) = _lLine w
drawInspectWall :: World -> Wall -> Picture drawInspectWall :: World -> Wall -> Picture
drawInspectWall w wl = setLayer DebugLayer drawInspectWall w wl =
$ color rose (thickLine 3 [a,b]) setLayer DebugLayer $
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor) color rose (thickLine 3 [a, b])
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
where where
(a,b) = _wlLine wl (a, b) = _wlLine wl
drawDoorPaths :: World -> Int -> Picture drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = fromMaybe mempty $ do drawDoorPaths w drid = fromMaybe mempty $ do
@@ -237,60 +248,68 @@ drawDoorPaths w drid = fromMaybe mempty $ do
return $ foldMap (drawPathEdge . (^. _3)) paths return $ foldMap (drawPathEdge . (^. _3)) paths
drawPathEdge :: PathEdge -> Picture drawPathEdge :: PathEdge -> Picture
drawPathEdge pe = setLayer DebugLayer drawPathEdge pe =
$ multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe)) setLayer DebugLayer $
multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe))
obstacleColor :: EdgeObstacle -> Color obstacleColor :: EdgeObstacle -> Color
obstacleColor eo = case eo of obstacleColor eo = case eo of
WallObstacle -> cyan WallObstacle -> cyan
DoorObstacle -> red DoorObstacle -> red
AutoDoorObstacle -> yellow AutoDoorObstacle -> yellow
BlockObstacle -> blue BlockObstacle -> blue
drawWorldSelect :: World -> Picture drawWorldSelect :: World -> Picture
drawWorldSelect w = setLayer DebugLayer drawWorldSelect w =
$ color cyan (line [a,b]) setLayer DebugLayer $
<> color magenta (line [c,d]) color cyan (line [a, b])
<> color magenta (line [c, d])
where where
(a,b) = _lLine w (a, b) = _lLine w
(c,d) = _rLine w (c, d) = _rLine w
drawFarWallDetect :: World -> Picture drawFarWallDetect :: World -> Picture
drawFarWallDetect w = setLayer DebugLayer drawFarWallDetect w =
. color yellow setLayer DebugLayer
. foldMap (\q -> line . color yellow
[ p . foldMap
, fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w ( \q ->
] ) line
$ runIdentity $ S.toList_ $ streamViewpoints p w [ p
, fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
]
)
$ runIdentity $ S.toList_ $ streamViewpoints p w
where where
p = _cameraViewFrom (_cWorld w) p = _cameraViewFrom (_cWorld w)
drawDDATest :: World -> Picture drawDDATest :: World -> Picture
drawDDATest w = runIdentity (S.foldMap_ (drawZoneCol orange 50) ps) drawDDATest w =
<> runIdentity (S.foldMap_ (drawZoneCol green 50) ps') runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
<> runIdentity (S.foldMap_ drawCross qs) <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps')
<> color blue (runIdentity (S.foldMap_ drawCross qs')) <> runIdentity (S.foldMap_ drawCross qs)
<> setLayer DebugLayer (color yellow (line [cvf,mwp])) <> color blue (runIdentity (S.foldMap_ drawCross qs'))
<> setLayer DebugLayer (color yellow (line [cvf, mwp]))
where where
cvf = _cameraViewFrom (_cWorld w) cvf = _cameraViewFrom (_cWorld w)
mwp = mouseWorldPos w mwp = mouseWorldPos w
ps = ddaStreamX 50 cvf mwp ps = ddaStreamX 50 cvf mwp
ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w) qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
drawCross :: Point2 -> Picture drawCross :: Point2 -> Picture
drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5 drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5
crossPic :: Float -> Picture crossPic :: Float -> Picture
crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)] crossPic x = line [V2 x x, V2 (- x) (- x)] <> line [V2 (- x) x, V2 x (- x)]
drawZoneCol :: Color -> Float -> V2 Int -> Picture drawZoneCol :: Color -> Float -> V2 Int -> Picture
drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p:ps ++ [p]) drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
where where
(p:ps) = zipWith (+.+) innerSquare (p : ps) =
$ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)] zipWith (+.+) innerSquare $
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
innerSquare :: [Point2] innerSquare :: [Point2]
innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)] innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
@@ -298,51 +317,61 @@ innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
drawWallSearchRays :: World -> Picture drawWallSearchRays :: World -> Picture
drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
where where
f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5) f p =
<> line [_cameraViewFrom (_cWorld w), p] setLayer DebugLayer $
color yellow $
uncurryV translate p (circle 5)
<> line [_cameraViewFrom (_cWorld w), p]
testPic :: Configuration -> World -> Picture testPic :: Configuration -> World -> Picture
testPic _ _ = mempty testPic _ _ = mempty
drawBoundingBox :: World -> Picture drawBoundingBox :: World -> Picture
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x] drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
where where
(x:xs) = _boundBox (_cWorld w) (x : xs) = _boundBox (_cWorld w)
clDraw :: Cloud -> Picture clDraw :: Cloud -> Picture
clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c) clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c)
ppDraw :: PressPlate -> Picture ppDraw :: PressPlate -> Picture
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
floorItemSPic :: FloorItem -> SPic floorItemSPic :: FloorItem -> SPic
floorItemSPic flit = uncurryV translateSPf (_flItPos flit) floorItemSPic flit =
$ rotateSP (_flItRot flit) (itemSPic (_flIt flit)) uncurryV translateSPf (_flItPos flit) $
rotateSP (_flItRot flit) (itemSPic (_flIt flit))
btSPic :: Button -> SPic btSPic :: Button -> SPic
btSPic bt = uncurryV translateSPf (_btPos bt) btSPic bt =
$ rotateSP (_btRot bt) (drawButton (_btPict bt) bt) uncurryV translateSPf (_btPos bt) $
rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
mcSPic :: Machine -> SPic mcSPic :: Machine -> SPic
mcSPic mc = uncurryV translateSPf (_mcPos mc) mcSPic mc =
$ rotateSP (_mcDir mc) (drawMachine mc) uncurryV translateSPf (_mcPos mc) $
rotateSP (_mcDir mc) (drawMachine mc)
soundPic :: Configuration -> World -> Sound -> Picture soundPic :: Configuration -> World -> Sound -> Picture
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
where where
p = _soundPos s p = _soundPos s
thePic thePic =
= rotate (_cameraRot (_cWorld w)) rotate (_cameraRot (_cWorld w))
. scale theScale theScale . scale theScale theScale
. centerText . centerText
. soundToOnomato . soundToOnomato
$ _soundChunkID s $ _soundChunkID s
theScale = 0.15 * f (_soundVolume s * 0.0001) theScale = 0.15 * f (_soundVolume s * 0.0001)
f x = 1 - 0.5 * (1 - x) f x = 1 - 0.5 * (1 - x)
drawMousePosition :: Configuration -> World -> Picture drawMousePosition :: Configuration -> World -> Picture
drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig drawMousePosition cfig w =
. uncurryV translate p setLayer FixedCoordLayer . winScale cfig
. scale 0.1 0.1 . uncurryV translate p
. text . scale 0.1 0.1
$ shortPoint2 mwp . text
$ shortPoint2 mwp
where where
p = worldPosToScreen w mwp p = worldPosToScreen w mwp
mwp = mouseWorldPos w mwp = mouseWorldPos w
@@ -351,12 +380,13 @@ drawWlIDs :: Configuration -> World -> Picture
drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls (_cWorld w)) drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls (_cWorld w))
where where
f wl f wl
| dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test" | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test"
| otherwise = winScale cfig | otherwise =
. uncurryV translate p winScale cfig
. scale 0.1 0.1 . uncurryV translate p
. text . scale 0.1 0.1
$ show $ _wlID wl . text
$ show $ _wlID wl
where where
p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl) p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
@@ -369,62 +399,71 @@ edgeToPic poly pe
ep = _peEnd pe ep = _peEnd pe
drawPathing :: Configuration -> World -> Picture drawPathing :: Configuration -> World -> Picture
drawPathing cfig w = setLayer DebugLayer drawPathing cfig w =
$ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr) setLayer DebugLayer $
<> foldMap dispInc (graphToIncidence gr) foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
<> foldMap dispInc (graphToIncidence gr)
where where
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
gr = _pathGraph (_cWorld w) gr = _pathGraph (_cWorld w)
crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String]) crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2, [String])
crDisplayInfo cfig w cr crDisplayInfo cfig w cr
| _crID cr == 0 = Nothing | _crID cr == 0 = Nothing
| crOnScreen = Just (_crPos cr, catMaybes | crOnScreen =
-- [fmap show $ ap ^? crGoal Just
[ fpreShow "crHP" $ cr ^? crHP ( _crPos cr
, fpreShow "crStrategy" $ ap ^? apStrategy , catMaybes
, fmap (("crPos....." ++) . shortShow) $ cr ^? crPos -- [fmap show $ ap ^? crGoal
, fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance [ fpreShow "crHP" $ cr ^? crHP
-- , fmap show $ cr ^? crOldPos , fpreShow "crStrategy" $ ap ^? apStrategy
, fpreShow "crAction" $ ap ^? apAction , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos
, fpreShow "crImpulse" $ ap ^? apImpulse , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
] , -- , fmap show $ cr ^? crOldPos
) fpreShow "crAction" $ ap ^? apAction
, fpreShow "crImpulse" $ ap ^? apImpulse
]
)
| otherwise = Nothing | otherwise = Nothing
where where
ap = _crActionPlan cr ap = _crActionPlan cr
crOnScreen = pointOnScreen cfig w $ _crPos cr crOnScreen = pointOnScreen cfig w $ _crPos cr
fpreShow :: (Show a,Functor f) => String -> f a -> f String fpreShow :: (Show a, Functor f) => String -> f a -> f String
fpreShow str = fmap (((rightPad 7 '.'str ++ "...") ++) . show) fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
drawCrInfo :: Configuration -> World -> Picture drawCrInfo :: Configuration -> World -> Picture
drawCrInfo cfig w = setLayer FixedCoordLayer drawCrInfo cfig w =
$ renderInfoListsAt (2*hw - 400) 0 cfig w setLayer FixedCoordLayer $
$ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures (_cWorld w) renderInfoListsAt (2 * hw - 400) 0 cfig w $
mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures (_cWorld w)
where where
hw = halfWidth cfig hw = halfWidth cfig
viewBoundaries :: World -> Picture viewBoundaries :: World -> Picture
viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _grBound) grs) viewBoundaries w =
<> color yellow (foldMap (\q -> line [p,q]) $ farWallPoints p w) setLayer DebugLayer $
color green (foldMap (polygonWire . _grBound) grs)
<> color yellow (foldMap (\q -> line [p, q]) $ farWallPoints p w)
where where
p = _crPos $ you w p = _crPos $ you w
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms (_cWorld w)) grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms (_cWorld w))
viewClipBounds :: Configuration -> World -> Picture viewClipBounds :: Configuration -> World -> Picture
viewClipBounds cfig w viewClipBounds cfig w
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries | _debug_view_clip_bounds cfig == AllRoomClipBoundaries =
= setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping (_cWorld w)) setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping (_cWorld w))
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries =
= setLayer DebugLayer $ f (_roomClipping (_cWorld w)) setLayer DebugLayer $ f (_roomClipping (_cWorld w))
| otherwise = mempty | otherwise = mempty
where where
f (x:xs) = g x xs <> f xs f (x : xs) = g x xs <> f xs
f [] = mempty f [] = mempty
g x (y:ys) | convexPolysOverlap x y = color green (polygonWire $ _cpPoints x) g x (y : ys)
<> color yellow (polygonWire $ _cpPoints y) | convexPolysOverlap x y =
<> g x ys color green (polygonWire $ _cpPoints x)
<> color yellow (polygonWire $ _cpPoints y)
<> g x ys
| otherwise = g x ys | otherwise = g x ys
g _ [] = mempty g _ [] = mempty
src/Dodge/Turretoid.hs
-8
View File
@@ -1,8 +0,0 @@
module Dodge.Turretoid where
import Dodge.Creature.Impulse
import Dodge.Creature.State
import Dodge.Data.World
updateTurretoid :: Creature -> World -> World
updateTurretoid = stateUpdate followThenClearImpulses