diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index bcd329ef6..d62195ddc 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -7,7 +7,6 @@ import Dodge.Creature.State import Dodge.Data.World import Dodge.Humanoid import Dodge.Lampoid -import Dodge.Turretoid import LensHelp import System.Random @@ -15,7 +14,6 @@ updateCreature :: Creature -> World -> World updateCreature cr = case _crType cr of Lampoid{} -> updateLampoid cr Humanoid{} -> updateHumanoid cr - Turretoid{} -> updateTurretoid cr Barreloid{} -> updateBarreloid cr NonDrawnCreature -> id diff --git a/src/Dodge/Data/Creature/Misc.hs b/src/Dodge/Data/Creature/Misc.hs index 2f073da44..0a19c8df8 100644 --- a/src/Dodge/Data/Creature/Misc.hs +++ b/src/Dodge/Data/Creature/Misc.hs @@ -68,7 +68,6 @@ data CreatureType } | Barreloid {_barrelType :: BarrelType} | Lampoid {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int} - | Turretoid | NonDrawnCreature deriving (Eq, Ord, Show, Read) diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 2abcb2534..2b4293701 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -490,7 +490,7 @@ coneRandItemParams = do mcShootLaser :: Item -> Machine -> World -> World mcShootLaser it mc = cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir where - pos = _mcPos mc + pos = _mcPos mc +.+ 20 *.* unitVectorAtAngle dir dir = mc ^?! mcType . _McTurret . tuDir phasev = _phaseV . _itParams $ it dam = _lasDamage $ _itParams it diff --git a/src/Dodge/Item/Draw.hs b/src/Dodge/Item/Draw.hs index 7e74f0fee..feec8a8c6 100644 --- a/src/Dodge/Item/Draw.hs +++ b/src/Dodge/Item/Draw.hs @@ -6,9 +6,10 @@ module Dodge.Item.Draw ( ) where import Control.Lens +import Data.Maybe +import Dodge.Creature.HandPos import Dodge.Data.Creature import Dodge.Item.Draw.SPic -import Dodge.Item.Equipment.Shape import Dodge.Item.HeldOffset import ShapePicture @@ -18,3 +19,21 @@ itemEquipPict cr it = case it ^. itUse of ituse -> case ituse ^? equipEffect of Just _ -> pictureOnEquip (itemSPic it) cr it 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 diff --git a/src/Dodge/Item/Equipment/Shape.hs b/src/Dodge/Item/Equipment/Shape.hs deleted file mode 100644 index 97dc1d844..000000000 --- a/src/Dodge/Item/Equipment/Shape.hs +++ /dev/null @@ -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 diff --git a/src/Dodge/Item/HeldOffset.hs b/src/Dodge/Item/HeldOffset.hs index bdf38a178..a0393f07c 100644 --- a/src/Dodge/Item/HeldOffset.hs +++ b/src/Dodge/Item/HeldOffset.hs @@ -3,35 +3,42 @@ module Dodge.Item.HeldOffset where import Data.Maybe import Dodge.Creature.HandPos import Dodge.Data.Creature +import Dodge.Data.Machine import Geometry 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 itm cr | isSelected && _posture (_crStance cr) == Aiming = - (+.+.+ V3 (aimingWeaponZeroPos cr itm) 0 shoulderD) + (+.+.+ V3 (aimingWeaponZeroPos cr itm) 0 shoulderHeight) | isSelected && isTwoHandFlat = (+.+.+ V3 (_crRad cr) 0 handD) . rotate3 (twoFlatHRot cr) - . transToHandle + . transToHandle itm | isSelected && isOneHand = (+.+.+ V3 0 0 handD) . (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0) . (+.+.+ V3 (-2) 0 0) - . transToHandle + . transToHandle itm | isSelected = (+.+.+ V3 0 0 handD) . (+.+.+ V3 (_crRad cr) 0 0) . rotate3 (strideRot cr + 1.2) . (+.+.+ V3 (-5) 0 0) -- . (+.+.+ V3 (-5) 0 0) - . transToHandle + . transToHandle itm | otherwise = id where - transToHandle = fromMaybe id $ do - x <- itm ^? itUse . heldAim . aimHandlePos - return (-.-.- V3 x 0 0) - shoulderD = 18 handD = 15 isSelected = _itIsHeld itm handPos = case cr ^? crStance . carriage of @@ -46,6 +53,9 @@ heldItemOffset itm cr f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen sLen = _strideLength $ _crStance cr +shoulderHeight :: Float +shoulderHeight = 18 + strideRot :: Creature -> Float strideRot cr = case cr ^? crStance . carriage of Just (Walking x LeftForward) -> f x diff --git a/src/Dodge/Machine/Draw.hs b/src/Dodge/Machine/Draw.hs index 4047f1e0c..471dcd438 100644 --- a/src/Dodge/Machine/Draw.hs +++ b/src/Dodge/Machine/Draw.hs @@ -1,7 +1,8 @@ module Dodge.Machine.Draw where +import Dodge.Item.HeldOffset +import Dodge.Item.Draw.SPic import Dodge.Placement.TopDecoration ---import Dodge.Placement.Instance.Turret import Shape import Picture import Geometry @@ -38,11 +39,13 @@ terminalShape mc = colorSH col (prismPoly col = _mcColor mc drawTurret :: Turret -> Machine -> SPic -drawTurret _ mc = - ( rotateSH (- _mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square w) - , mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc ) +drawTurret tu mc = + ( colorSH (_mcColor mc) $ upperPrismPoly 20 (square w) + , mempty ) + <> overPosSP (turretItemOffset it tu mc) (itemSPic it) where + it = _tuWeapon tu w = _mcWidth mc sensorSPic :: (PaletteColor, DecorationShape) -> Machine -> SPic diff --git a/src/Dodge/Machine/Update.hs b/src/Dodge/Machine/Update.hs index 67c8ab3ef..c81a6466e 100644 --- a/src/Dodge/Machine/Update.hs +++ b/src/Dodge/Machine/Update.hs @@ -16,6 +16,7 @@ import Dodge.WorldEvent.Explosion import Geometry import qualified IntMapHelp as IM import LensHelp +import Control.Monad updateMachine :: Machine -> World -> World updateMachine mc @@ -32,7 +33,6 @@ mcTurretUpdate mc = case mc ^? mcType . _McTurret of Just tu -> updateTurret (_tuTurnSpeed tu) mc _ -> id --- this needs a major cleanup updateTurret :: Float -> Machine -> World -> World updateTurret rotSpeed mc w | _mcHP mc < 1 = @@ -57,13 +57,12 @@ updateTurret rotSpeed mc w mcid = _mcID mc ypos = _crPos $ you w mcpos = _mcPos mc - --mcdir = _mcDir mc seesYou = hasLOSIndirect mcpos ypos w (elecDams, dams) = partition isElectrical $ _mcDamage mc dam = sum $ map _dmAmount dams elecDam = sum $ map _dmAmount elecDams 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 closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1 updateFiringStatus @@ -75,14 +74,9 @@ mcUseItem mc = fromMaybe id $ do tu <- mc ^? mcType . _McTurret let it = tu ^. tuWeapon hit <- it ^? itType . iyBase . ibtHeld + guard (_tuFireTime tu > 0) return $ mcUseHeld hit it mc --- maybeFire --- | _tuFireTime (_mcType mc) > 0 = --- fromMaybe id $ do --- return $ tuUseItem --- | otherwise = id - mcSensorTriggerUpdate :: Machine -> World -> World mcSensorTriggerUpdate mc = fromMaybe id $ do trid <- mc ^? mcMounts . ix ObTrigger diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index ce1275bf7..7194f0c7c 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -1,113 +1,118 @@ -module Dodge.Render.ShapePicture - ( worldSPic - ) 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 +module Dodge.Render.ShapePicture ( + worldSPic, +) where -import StreamingHelp -import qualified IntMapHelp as IM -- Lazy? -import qualified Data.Map.Strict as M 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 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 = id worldSPic :: Configuration -> World -> SPic -worldSPic cfig w - = singleSPic (mempty, extraPics cfig w) - <> foldup drawProp' (filtOn _prPos _props) - <> foldup drawProjectile (filtOn _prjPos _projectiles) - <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks) - <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes) - <> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses) - <> foldup drawCreature (filtOn _crPos _creatures) - <> foldup floorItemSPic (filtOn _flItPos _floorItems) - <> foldup btSPic (filtOn _btPos _buttons) - <> foldup mcSPic (filtOn _mcPos _machines) - <> singleSPic (anyTargeting cfig w) +worldSPic cfig w = + singleSPic (mempty, extraPics cfig w) + <> foldup drawProp' (filtOn _prPos _props) + <> foldup drawProjectile (filtOn _prjPos _projectiles) + <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks) + <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes) + <> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses) + <> foldup drawCreature (filtOn _crPos _creatures) + <> foldup floorItemSPic (filtOn _flItPos _floorItems) + <> foldup btSPic (filtOn _btPos _buttons) + <> foldup mcSPic (filtOn _mcPos _machines) + <> singleSPic (anyTargeting cfig w) where foldup = foldMap' filtOn f g = IM.filter (pointIsClose . f) (g (_cWorld w)) pointIsClose = cullPoint cfig w 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 cr = you w f it = fmap (\g -> drawTargeting g it cr cfig w) (it ^? itTargeting . tgDraw) drawCreature :: Creature -> SPic drawCreature cr = case _crType cr of - Humanoid {} -> basicCrPict cr - Barreloid {} -> picAtCrPos1 (setDepth 20 $ pictures - [ color orange $ circleSolid 10 - , setDepth 0.049 . color (greyN 0.5) $ circleSolid 8 - , color (greyN 0.5) $ circleSolid 8 - ]) cr - Lampoid{_lampHeight=h} -> picAtCrPosNoRot1 (lampCrPic h) cr - Turretoid -> mempty + Humanoid{} -> basicCrPict cr + Barreloid{} -> + picAtCrPos1 + ( setDepth 20 $ + pictures + [ color orange $ circleSolid 10 + , setDepth 0.049 . color (greyN 0.5) $ circleSolid 8 + , color (greyN 0.5) $ circleSolid 8 + ] + ) + cr + Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr NonDrawnCreature -> mempty lampCrPic :: Float -> Picture -lampCrPic h = pictures - [ setLayer BloomLayer (setDepth h . color white $ circleSolid 3) - , foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1) - ] +lampCrPic h = + pictures + [ setLayer BloomLayer (setDepth h . color white $ circleSolid 3) + , foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h -1) + ] where 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 --{-# INLINE picAtCrPos #-} picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic @@ -117,93 +122,96 @@ picAtCrPos1 :: Picture -> Creature -> SPic picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic -shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x) - . rotateSP (fdir x) - $ fdraw x x +shiftDraw fpos fdir fdraw x = + uncurryV translateSPf (fpos x) + . rotateSP (fdir x) + $ fdraw x x shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic -shiftDraw' fpos fdir fdraw x = uncurryV translateSPf (fpos x) - . rotateSP (fdir x) - $ fdraw x +shiftDraw' fpos fdir fdraw x = + uncurryV translateSPf (fpos x) + . rotateSP (fdir x) + $ fdraw x cullPoint :: Configuration -> World -> Point2 -> Bool -cullPoint cfig w p +cullPoint cfig w p | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox (_cWorld w)) | otherwise = dist (_cameraCenter (_cWorld w)) p < _viewDistance (_cWorld w) extraPics :: Configuration -> World -> Picture -extraPics cfig w = pictures (_decorations (_cWorld w)) - <> concatMapPic drawTractorBeam (_tractorBeams (_cWorld w)) - <> concatMapPic drawLinearShockwave (_linearShockwaves (_cWorld w)) - <> concatMapPic drawShockwave (_shockwaves (_cWorld w)) - <> concatMapPic drawLaser (_lasersToDraw (_cWorld w)) - <> concatMapPic drawTeslaArc (_teslaArcs (_cWorld w)) --- <> concatMapPic drawParticle (_particles w) - <> concatMapPic drawRadarSweep (_radarSweeps (_cWorld w)) - <> concatMapPic drawFlame (_flames (_cWorld w)) - <> concatMapPic drawEnergyBall (_energyBalls (_cWorld w)) - <> concatMapPic drawSpark (_sparks (_cWorld w)) - <> concatMapPic drawBul (_bullets (_cWorld w)) - <> concatMapPic drawBlip (_radarBlips (_cWorld w)) - <> concatMapPic drawFlare (_flares (_cWorld w)) - <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams (_cWorld w)) - <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams (_cWorld w)) - <> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources (_cWorld w)) - <> testPic cfig w - <> concatMapPic clDraw (_clouds (_cWorld w) ) - <> concatMapPic ppDraw (_pressPlates (_cWorld w) ) - <> viewClipBounds cfig w - <> debugDraw cfig w +extraPics cfig w = + pictures (_decorations (_cWorld w)) + <> concatMapPic drawTractorBeam (_tractorBeams (_cWorld w)) + <> concatMapPic drawLinearShockwave (_linearShockwaves (_cWorld w)) + <> concatMapPic drawShockwave (_shockwaves (_cWorld w)) + <> concatMapPic drawLaser (_lasersToDraw (_cWorld w)) + <> concatMapPic drawTeslaArc (_teslaArcs (_cWorld w)) + -- <> concatMapPic drawParticle (_particles w) + <> concatMapPic drawRadarSweep (_radarSweeps (_cWorld w)) + <> concatMapPic drawFlame (_flames (_cWorld w)) + <> concatMapPic drawEnergyBall (_energyBalls (_cWorld w)) + <> concatMapPic drawSpark (_sparks (_cWorld w)) + <> concatMapPic drawBul (_bullets (_cWorld w)) + <> concatMapPic drawBlip (_radarBlips (_cWorld w)) + <> concatMapPic drawFlare (_flares (_cWorld w)) + <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams (_cWorld w)) + <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams (_cWorld w)) + <> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources (_cWorld w)) + <> testPic cfig w + <> concatMapPic clDraw (_clouds (_cWorld w)) + <> concatMapPic ppDraw (_pressPlates (_cWorld w)) + <> viewClipBounds cfig w + <> debugDraw cfig w debugDraw :: Configuration -> World -> Picture {-# INLINE debugDraw #-} -debugDraw cfig w +debugDraw cfig w | Show_debug `Set.member` _debug_booleans cfig = 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 where (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig) -debugDraw' :: Configuration -> World -> DebugBool -> ([String],Picture) +debugDraw' :: Configuration -> World -> DebugBool -> ([String], Picture) {-# INLINE debugDraw' #-} debugDraw' cfig w bl = case bl of - Show_debug -> lstring "Show debug" - Noclip -> lstring "Noclip" - Remove_LOS -> lstring "No line of sight" - Cull_more_lights -> lstring "Cull more lights" + Show_debug -> lstring "Show debug" + Noclip -> lstring "Noclip" + Remove_LOS -> lstring "No line of sight" + Cull_more_lights -> lstring "Cull more lights" Close_shape_culling -> lstring "Close shape culling" - Bound_box_screen -> lstring "bound box screen, this should be moved" - Show_ms_frame -> rdraw mempty - View_boundaries -> rdraw $ viewBoundaries w - Show_bound_box -> rdraw $ drawBoundingBox w - Show_wall_search_rays -> rdraw $ drawWallSearchRays w - Show_dda_test -> rdraw $ drawDDATest w - Show_far_wall_detect -> rdraw $ drawFarWallDetect w - Show_select -> rdraw $ drawWorldSelect w - Inspect_wall -> rdraw $ drawInspectWalls w - Cr_awareness -> rdraw $ drawCreatureDisplayTexts w - Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w - Cr_status -> rdraw $ drawCrInfo cfig w - Mouse_position -> rdraw $ drawMousePosition cfig w - Walls_info -> rdraw $ drawWlIDs cfig w - Pathing -> rdraw $ drawPathing cfig w - Show_nodes_near_select -> rdraw $ drawNodesNearSelect w - Show_path_between -> rdraw $ drawPathBetween w + Bound_box_screen -> lstring "bound box screen, this should be moved" + Show_ms_frame -> rdraw mempty + View_boundaries -> rdraw $ viewBoundaries w + Show_bound_box -> rdraw $ drawBoundingBox w + Show_wall_search_rays -> rdraw $ drawWallSearchRays w + Show_dda_test -> rdraw $ drawDDATest w + Show_far_wall_detect -> rdraw $ drawFarWallDetect w + Show_select -> rdraw $ drawWorldSelect w + Inspect_wall -> rdraw $ drawInspectWalls w + Cr_awareness -> rdraw $ drawCreatureDisplayTexts w + Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w + Cr_status -> rdraw $ drawCrInfo cfig w + Mouse_position -> rdraw $ drawMousePosition cfig w + Walls_info -> rdraw $ drawWlIDs cfig w + Pathing -> rdraw $ drawPathing cfig w + Show_nodes_near_select -> rdraw $ drawNodesNearSelect w + Show_path_between -> rdraw $ drawPathBetween w where - lstring str = ([str],mempty) - rdraw pic = (mempty,pic) + lstring str = ([str], mempty) + rdraw pic = (mempty, pic) drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures (_cWorld w)) drawPathBetween :: World -> Picture -drawPathBetween w = setLayer DebugLayer - $ color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist) - <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp) - <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep) - <> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w) +drawPathBetween w = + setLayer DebugLayer $ + color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist) + <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp) + <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep) + <> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w) where nodepos = (`getNodePos` w) nodelist = makePathBetween sp ep w @@ -211,25 +219,28 @@ drawPathBetween w = setLayer DebugLayer ep = _rSelect w drawNodesNearSelect :: World -> Picture -drawNodesNearSelect w = setLayer DebugLayer - $ runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp)) - <> color green (drawCross sp) +drawNodesNearSelect w = + setLayer DebugLayer $ + runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp)) + <> color green (drawCross sp) where sp = _lSelect w drawInspectWalls :: World -> Picture -drawInspectWalls w = foldMap (drawInspectWall w) - $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) - $ IM.elems $ _walls (_cWorld w) +drawInspectWalls w = + foldMap (drawInspectWall w) $ + filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $ + IM.elems $ _walls (_cWorld w) where - (a,b) = _lLine w + (a, b) = _lLine w drawInspectWall :: World -> Wall -> Picture -drawInspectWall w wl = setLayer DebugLayer - $ color rose (thickLine 3 [a,b]) - <> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor) +drawInspectWall w wl = + setLayer DebugLayer $ + color rose (thickLine 3 [a, b]) + <> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor) where - (a,b) = _wlLine wl + (a, b) = _wlLine wl drawDoorPaths :: World -> Int -> Picture drawDoorPaths w drid = fromMaybe mempty $ do @@ -237,60 +248,68 @@ drawDoorPaths w drid = fromMaybe mempty $ do return $ foldMap (drawPathEdge . (^. _3)) paths drawPathEdge :: PathEdge -> Picture -drawPathEdge pe = setLayer DebugLayer - $ multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe)) +drawPathEdge pe = + setLayer DebugLayer $ + multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe)) obstacleColor :: EdgeObstacle -> Color obstacleColor eo = case eo of - WallObstacle -> cyan - DoorObstacle -> red + WallObstacle -> cyan + DoorObstacle -> red AutoDoorObstacle -> yellow BlockObstacle -> blue drawWorldSelect :: World -> Picture -drawWorldSelect w = setLayer DebugLayer - $ color cyan (line [a,b]) - <> color magenta (line [c,d]) +drawWorldSelect w = + setLayer DebugLayer $ + color cyan (line [a, b]) + <> color magenta (line [c, d]) where - (a,b) = _lLine w - (c,d) = _rLine w + (a, b) = _lLine w + (c, d) = _rLine w drawFarWallDetect :: World -> Picture -drawFarWallDetect w = setLayer DebugLayer - . color yellow - . foldMap (\q -> line - [ p - , fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w - ] ) - $ runIdentity $ S.toList_ $ streamViewpoints p w +drawFarWallDetect w = + setLayer DebugLayer + . color yellow + . foldMap + ( \q -> + line + [ p + , fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w + ] + ) + $ runIdentity $ S.toList_ $ streamViewpoints p w where p = _cameraViewFrom (_cWorld w) drawDDATest :: World -> Picture -drawDDATest w = runIdentity (S.foldMap_ (drawZoneCol orange 50) ps) - <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps') - <> runIdentity (S.foldMap_ drawCross qs) - <> color blue (runIdentity (S.foldMap_ drawCross qs')) - <> setLayer DebugLayer (color yellow (line [cvf,mwp])) +drawDDATest w = + runIdentity (S.foldMap_ (drawZoneCol orange 50) ps) + <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps') + <> runIdentity (S.foldMap_ drawCross qs) + <> color blue (runIdentity (S.foldMap_ drawCross qs')) + <> setLayer DebugLayer (color yellow (line [cvf, mwp])) where cvf = _cameraViewFrom (_cWorld w) mwp = mouseWorldPos w ps = ddaStreamX 50 cvf mwp 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) drawCross :: Point2 -> Picture drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5 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 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 - (p:ps) = zipWith (+.+) innerSquare - $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)] + (p : ps) = + 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 = [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 w = foldMap (f . fst) $ allVisibleWalls w where - f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5) - <> line [_cameraViewFrom (_cWorld w), p] + f p = + setLayer DebugLayer $ + color yellow $ + uncurryV translate p (circle 5) + <> line [_cameraViewFrom (_cWorld w), p] testPic :: Configuration -> World -> Picture testPic _ _ = mempty drawBoundingBox :: World -> Picture -drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x] +drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x] where - (x:xs) = _boundBox (_cWorld w) + (x : xs) = _boundBox (_cWorld w) clDraw :: Cloud -> Picture clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c) + ppDraw :: PressPlate -> Picture ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) + floorItemSPic :: FloorItem -> SPic -floorItemSPic flit = uncurryV translateSPf (_flItPos flit) - $ rotateSP (_flItRot flit) (itemSPic (_flIt flit)) +floorItemSPic flit = + uncurryV translateSPf (_flItPos flit) $ + rotateSP (_flItRot flit) (itemSPic (_flIt flit)) btSPic :: Button -> SPic -btSPic bt = uncurryV translateSPf (_btPos bt) - $ rotateSP (_btRot bt) (drawButton (_btPict bt) bt) +btSPic bt = + uncurryV translateSPf (_btPos bt) $ + rotateSP (_btRot bt) (drawButton (_btPict bt) bt) + mcSPic :: Machine -> SPic -mcSPic mc = uncurryV translateSPf (_mcPos mc) - $ rotateSP (_mcDir mc) (drawMachine mc) +mcSPic mc = + uncurryV translateSPf (_mcPos mc) $ + rotateSP (_mcDir mc) (drawMachine mc) soundPic :: Configuration -> World -> Sound -> Picture soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w where p = _soundPos s - thePic - = rotate (_cameraRot (_cWorld w)) - . scale theScale theScale - . centerText - . soundToOnomato - $ _soundChunkID s + thePic = + rotate (_cameraRot (_cWorld w)) + . scale theScale theScale + . centerText + . soundToOnomato + $ _soundChunkID s theScale = 0.15 * f (_soundVolume s * 0.0001) f x = 1 - 0.5 * (1 - x) drawMousePosition :: Configuration -> World -> Picture -drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig - . uncurryV translate p - . scale 0.1 0.1 - . text - $ shortPoint2 mwp +drawMousePosition cfig w = + setLayer FixedCoordLayer . winScale cfig + . uncurryV translate p + . scale 0.1 0.1 + . text + $ shortPoint2 mwp where p = worldPosToScreen w mwp mwp = mouseWorldPos w @@ -350,13 +379,14 @@ drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig drawWlIDs :: Configuration -> World -> Picture drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls (_cWorld w)) where - f wl - | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test" - | otherwise = winScale cfig - . uncurryV translate p - . scale 0.1 0.1 - . text - $ show $ _wlID wl + f wl + | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test" + | otherwise = + winScale cfig + . uncurryV translate p + . scale 0.1 0.1 + . text + $ show $ _wlID wl where p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl) @@ -369,78 +399,87 @@ edgeToPic poly pe ep = _peEnd pe drawPathing :: Configuration -> World -> Picture -drawPathing cfig w = setLayer DebugLayer - $ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr) - <> foldMap dispInc (graphToIncidence gr) +drawPathing cfig w = + setLayer DebugLayer $ + foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr) + <> foldMap dispInc (graphToIncidence gr) 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) -crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String]) -crDisplayInfo cfig w cr +crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2, [String]) +crDisplayInfo cfig w cr | _crID cr == 0 = Nothing - | crOnScreen = Just (_crPos cr, catMaybes --- [fmap show $ ap ^? crGoal - [ fpreShow "crHP" $ cr ^? crHP - , fpreShow "crStrategy" $ ap ^? apStrategy - , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos - , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance --- , fmap show $ cr ^? crOldPos - , fpreShow "crAction" $ ap ^? apAction - , fpreShow "crImpulse" $ ap ^? apImpulse - ] - ) + | crOnScreen = + Just + ( _crPos cr + , catMaybes + -- [fmap show $ ap ^? crGoal + [ fpreShow "crHP" $ cr ^? crHP + , fpreShow "crStrategy" $ ap ^? apStrategy + , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos + , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance + , -- , fmap show $ cr ^? crOldPos + fpreShow "crAction" $ ap ^? apAction + , fpreShow "crImpulse" $ ap ^? apImpulse + ] + ) | otherwise = Nothing where ap = _crActionPlan cr crOnScreen = pointOnScreen cfig w $ _crPos cr -fpreShow :: (Show a,Functor f) => String -> f a -> f String -fpreShow str = fmap (((rightPad 7 '.'str ++ "...") ++) . show) +fpreShow :: (Show a, Functor f) => String -> f a -> f String +fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show) drawCrInfo :: Configuration -> World -> Picture -drawCrInfo cfig w = setLayer FixedCoordLayer - $ renderInfoListsAt (2*hw - 400) 0 cfig w - $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures (_cWorld w) +drawCrInfo cfig w = + setLayer FixedCoordLayer $ + renderInfoListsAt (2 * hw - 400) 0 cfig w $ + mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures (_cWorld w) where hw = halfWidth cfig viewBoundaries :: World -> Picture -viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _grBound) grs) - <> color yellow (foldMap (\q -> line [p,q]) $ farWallPoints p w) +viewBoundaries w = + setLayer DebugLayer $ + color green (foldMap (polygonWire . _grBound) grs) + <> color yellow (foldMap (\q -> line [p, q]) $ farWallPoints p w) where p = _crPos $ you w grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms (_cWorld w)) viewClipBounds :: Configuration -> World -> Picture viewClipBounds cfig w - | _debug_view_clip_bounds cfig == AllRoomClipBoundaries - = setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping (_cWorld w)) - | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries - = setLayer DebugLayer $ f (_roomClipping (_cWorld w)) + | _debug_view_clip_bounds cfig == AllRoomClipBoundaries = + setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping (_cWorld w)) + | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries = + setLayer DebugLayer $ f (_roomClipping (_cWorld w)) | otherwise = mempty where - f (x:xs) = g x xs <> f xs + f (x : xs) = g x xs <> f xs f [] = mempty - g x (y:ys) | convexPolysOverlap x y = color green (polygonWire $ _cpPoints x) - <> color yellow (polygonWire $ _cpPoints y) - <> g x ys + g x (y : ys) + | convexPolysOverlap x y = + color green (polygonWire $ _cpPoints x) + <> color yellow (polygonWire $ _cpPoints y) + <> g x ys | otherwise = g x ys g _ [] = mempty --wallFloorsToDraw :: World -> [Wall] --wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w --- where +-- where -- onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall --- isVisible wl +-- isVisible wl -- | wl ^? wlUnshadowed == Just False = False -- | otherwise = onScreen wl -- --lineOnScreen :: World -> Point2 -> Point2 -> Bool ---lineOnScreen w p1 p2 = pointInPolygon p1 sp --- || pointInPolygon p2 sp +--lineOnScreen w p1 p2 = pointInPolygon p1 sp +-- || pointInPolygon p2 sp -- || any (isJust . uncurry (intersectSegSeg p1 p2)) sps --- where +-- where -- sp = screenPolygon w -- sps = zip sp (tail sp ++ [head sp]) -- @@ -448,7 +487,7 @@ viewClipBounds cfig w --drawWallFloor wl = if _wlOpacity wl == SeeThrough -- then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y] -- else blank --- where +-- where -- (x,y) = _wlLine wl -- c = _wlColor wl -- n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x) diff --git a/src/Dodge/Turretoid.hs b/src/Dodge/Turretoid.hs deleted file mode 100644 index 0a34088b9..000000000 --- a/src/Dodge/Turretoid.hs +++ /dev/null @@ -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