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

Add sounds, move data types out into separate folders

Browse Source
This commit is contained in:
justin
2022-07-16 17:06:51 +01:00
parent f8f4766012
commit e4a4766ddf
48 changed files with 658 additions and 496 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Render/ShapePicture.hs
+22 -37
View File
@@ -1,6 +1,7 @@
module Dodge.Render.ShapePicture
( worldSPic
) where
import Dodge.Item.Draw.SPic
import Dodge.Creature.Picture.Awareness
import Dodge.Creature.Picture
import Dodge.Particle.Draw
@@ -14,15 +15,12 @@ import Dodge.Picture.SizeInvariant
import Dodge.Data
import Dodge.Zone
import Dodge.Base
--import Dodge.Base.Window
import Dodge.SoundLogic.LoadSound
import Dodge.Graph
import Dodge.GameRoom
import Dodge.Update.Camera
import Dodge.Item.Draw
import Dodge.Render.List
import Dodge.Path
--import Dodge.Zone
import Geometry
import Geometry.Zone
import ShapePicture
@@ -30,13 +28,10 @@ import Picture
import Sound.Data
import Geometry.ConvexPoly
import ShortShow
--import Dodge.Base.Collide
import StreamingHelp
--import Data.Foldable
import qualified Data.IntMap.Strict as IM -- Lazy?
import qualified Data.Map.Strict as M
--import qualified Data.Set as Set
import Control.Lens
import Data.Maybe
import qualified Streaming.Prelude as S
@@ -51,19 +46,18 @@ singleSPic = id
worldSPic :: Configuration -> World -> SPic
worldSPic cfig w
= singleSPic (mempty, extraPics cfig w)
<> foldup (dbArg _prDraw) (filtOn' _prPos _props)
<> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foregroundShapes)
<> foldup (dbArg _cpPict) (filtOn' _cpPos _corpses)
<> foldup drawCreature (filtOn' _crPos _creatures)
<> foldup floorItemSPic (filtOn' _flItPos _floorItems)
<> foldup btSPic (filtOn' _btPos _buttons)
<> foldup mcSPic (filtOn' _mcPos _machines)
<> foldup (dbArg _prDraw) (filtOn _prPos _props)
<> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
<> foldup (dbArg _cpPict) (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 w)
--filtOn' f g = S.filter (pointIsClose . f) $ S.each (g w)
filtOn f g = IM.filter (pointIsClose . f) (g w)
pointIsClose = cullPoint cfig w
anyTargeting :: Configuration -> World -> SPic
@@ -157,11 +151,9 @@ drawPathBetween w = setLayer DebugLayer
ep = _rSelect w
drawNodesNearSelect :: World -> Picture
drawNodesNearSelect w = setLayer DebugLayer $
runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
-- <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
drawNodesNearSelect w = setLayer DebugLayer
$ runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp))
<> color green (drawCross sp)
-- <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
where
sp = _lSelect w
@@ -173,10 +165,8 @@ drawInspectWalls w = foldMap (drawInspectWall w)
(a,b) = _lLine w
drawInspectWall :: World -> Wall -> Picture
drawInspectWall w wl = setLayer DebugLayer $
color rose (thickLine 3 [a,b])
-- <> foldMap (drawZone wlZoneSize)
-- (runIdentity $ S.toList_ $ zoneOfWall wlZoneSize wl) -- this won't work if wlZoneSize is not consistent
drawInspectWall w wl = setLayer DebugLayer
$ color rose (thickLine 3 [a,b])
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
where
(a,b) = _wlLine wl
@@ -217,8 +207,8 @@ drawFarWallDetect w = setLayer DebugLayer
p = _cameraViewFrom w
drawDDATest :: World -> Picture
drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps)
<> runIdentity (S.foldMap_ (drawZone' 50) ps')
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]))
@@ -236,15 +226,11 @@ drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic
crossPic :: Float -> Picture
crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]
drawZone :: Float -> V2 Int -> Picture
drawZone s (V2 x y) = setLayer DebugLayer . color orange $ thickLine 2 (p:ps ++ [p])
drawZoneCol :: Color -> Float -> V2 Int -> Picture
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)]
drawZone' :: Float -> V2 Int -> Picture
drawZone' s (V2 x y) = setLayer DebugLayer . color green $ line (p:ps ++ [p])
where
(p:ps) = zipWith (+.+) (map (2*.*) 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)]
@@ -267,10 +253,9 @@ clDraw :: Cloud -> Picture
clDraw c = translate3 (_clPos c) (_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)