From 22ac8feb37ae29228227b6f744208ad9ce7127bb Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 4 Jul 2022 23:17:53 +0100 Subject: [PATCH] Redo shape vertices as a list, should allow for mirroring --- src/Dodge/Render.hs | 2 +- src/Dodge/Render/ShapePicture.hs | 22 +++++++++++----------- src/Shader/Poke.hs | 4 ++-- src/Shape.hs | 28 ++++++++++------------------ src/Shape/Data.hs | 5 +++-- src/ShapePicture.hs | 17 ++++++++--------- 6 files changed, 35 insertions(+), 43 deletions(-) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 96b167b29..335416ded 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -51,7 +51,7 @@ doDrawing pdata u = do -- attempt to poke in parallel -- let (ws,wp) = wallSPics <> worldSPic cfig w ( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) ) - <- MP.bindM2 (\ wlwifl counts -> return (wlwifl,counts)) + <- MP.bindM2 (curry return) ( pokeWallsWindowsFloor (shadVBOptr $ _wallTextureShader pdata) (shadVBOptr $ _windowShader pdata) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 977b06162..babe84fa3 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -43,18 +43,18 @@ import Padding worldSPic :: Configuration -> World -> Stream (Of SPic) IO () worldSPic cfig w - = (S.yield (mempty, extraPics cfig w) ) - <> (S.each $ fmap (dbArg _prDraw) (filtOn _prPos _props) ) - <> (S.each $ fmap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks) ) - <> (S.each $ fmap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes) ) - <> (S.each $ fmap (dbArg _cpPict) (filtOn _cpPos _corpses) ) - <> (S.map (dbArg _crPict) (filtOn' _crPos _creatures) ) - <> (S.each $ fmap floorItemSPic (filtOn _flItPos _floorItems) ) - <> (S.each $ fmap btSPic (filtOn _btPos _buttons) ) - <> (S.each $ fmap mcSPic (filtOn _mcPos _machines) ) - <> S.yield (anyTargeting cfig w ) + = S.yield (mempty, extraPics cfig w) + <> S.map (dbArg _prDraw) (filtOn' _prPos _props) + <> S.map (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks) + <> S.map (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _shapes) + <> S.map (dbArg _cpPict) (filtOn' _cpPos _corpses) + <> S.map (dbArg _crPict) (filtOn' _crPos _creatures) + <> S.map floorItemSPic (filtOn' _flItPos _floorItems) + <> S.map btSPic (filtOn' _btPos _buttons) + <> S.map mcSPic (filtOn' _mcPos _machines) + <> S.yield (anyTargeting cfig w) where - filtOn f g = IM.filter (pointIsClose . f) (g w) + --filtOn f g = IM.filter (pointIsClose . f) (g w) filtOn' f g = S.filter (pointIsClose . f) $ S.each (g w) pointIsClose = cullPoint cfig w diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 605e32888..a9bc759df 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -112,8 +112,8 @@ pokeShapeObj -> ShapeObj -> IO (Int,Int,Int) --{-# INLINE pokeShapeObj #-} -pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of - TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts +pokeShapeObj ptr iptr ieptr counts (ShapeObj shtype shVerts) = case shtype of + TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts (S.each shVerts) pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort diff --git a/src/Shape.hs b/src/Shape.hs index dd0394328..a5b8e3496 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -45,7 +45,7 @@ prismPoly -> [Point3] -> Shape {-# INLINE prismPoly #-} -prismPoly upps downps = S.yield (ShapeObj (TopPrism n) (S.each $ f upps downps)) +prismPoly upps downps = S.yield (ShapeObj (TopPrism n) (f upps downps)) where n = length upps f (a:as) (b:bs) = g a:g b:f as bs @@ -58,7 +58,7 @@ upperPrismPoly -> [Point2] -> Shape {-# INLINE upperPrismPoly #-} -upperPrismPoly h ps = S.yield (ShapeObj (TopPrism n) (S.each $ f ps)) +upperPrismPoly h ps = S.yield (ShapeObj (TopPrism n) (f ps)) where n = length ps g h' (V2 x y) = pairToSV (V3 x y h', black) @@ -70,7 +70,7 @@ upperPrismPolyHalf -> [Point2] -> Shape {-# INLINE upperPrismPolyHalf #-} -upperPrismPolyHalf h ps = S.yield (ShapeObj (TopPrism n) (S.each $ f upps downps)) +upperPrismPolyHalf h ps = S.yield (ShapeObj (TopPrism n) (f upps downps)) where n = length ps upps = map f' ps @@ -88,17 +88,9 @@ overColSH :: (Point4 -> Point4) -> Shape -> Shape {-# INLINE overColSH #-} overColSH = S.map . overColObj ---overColSHM :: Monad m => (Point4 -> m Point4) -> Shape -> m Shape ---{-# INLINE overColSHM #-} ---overColSHM = mapM . overColObjM - -overPosSHI :: (Point3 -> Point3) -> Shape -> Shape -{-# INLINE overPosSHI #-} -overPosSHI = S.map . overPosObj - translateSH :: Point3 -> Shape -> Shape {-# INLINE translateSH #-} -translateSH !p = overPosSHI (+.+.+ p) +translateSH !p = overPosSH (+.+.+ p) translateSHf :: Float -> Float -> Shape -> Shape {-# INLINE translateSHf #-} @@ -110,23 +102,23 @@ translateSHz !z = translateSH (V3 0 0 z) rotateSH :: Float -> Shape -> Shape {-# INLINE rotateSH #-} -rotateSH = overPosSHI . rotate3 +rotateSH = overPosSH . rotate3 overPosSH :: (Point3 -> Point3) -> Shape -> Shape {-# INLINEABLE overPosSH #-} -overPosSH = overPosSHI +overPosSH = S.map . overPosObj rotateSHx :: Float -> Shape -> Shape {-# INLINE rotateSHx #-} -rotateSHx a = overPosSHI (rotate3x a) +rotateSHx a = overPosSH (rotate3x a) scaleSH :: Point3 -> Shape -> Shape {-# INLINE scaleSH #-} -scaleSH (V3 a b c) = overPosSHI (\(V3 x y z) -> V3 (x*a) (y*b) (z*c)) +scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c)) overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj {-# INLINE overColObj #-} -overColObj f (ShapeObj st vs) = ShapeObj st (S.map (overColVertex f) vs) +overColObj f (ShapeObj st vs) = ShapeObj st (fmap (overColVertex f) vs) --overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj --{-# INLINE overColObjM #-} @@ -138,7 +130,7 @@ overColVertex f (ShapeV a b) = ShapeV a (f b) overPosObj :: (Point3 -> Point3) -> ShapeObj -> ShapeObj {-# INLINE overPosObj #-} -overPosObj f (ShapeObj st vs) = ShapeObj st $ S.map (overPosVertex f) vs +overPosObj f (ShapeObj st vs) = ShapeObj st $ fmap (overPosVertex f) vs overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV {-# INLINE overPosVertex #-} diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index c59f2046a..43ce29fa5 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -28,8 +28,8 @@ shVfromList = id shEfromList = id data ShapeObj = ShapeObj - { _shType :: ShapeType - , _shVs :: Stream (Of ShapeV) IO () + { _shType :: ShapeType + , _shVs :: [ShapeV] } deriving () @@ -46,3 +46,4 @@ pairToSV :: (Point3,Point4) -> ShapeV {-# INLINE pairToSV #-} pairToSV = uncurry ShapeV makeLenses ''ShapeV +makeLenses ''ShapeObj diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index d8a257b01..b48d94953 100644 --- a/src/ShapePicture.hs +++ b/src/ShapePicture.hs @@ -18,6 +18,8 @@ import Picture import Geometry import Data.Bifunctor +import Control.Lens +import qualified Streaming.Prelude as S type SPic = (Shape, Picture) @@ -49,14 +51,11 @@ rotateSP :: Float -> SPic -> SPic rotateSP a = bimap (rotateSH a) (rotate a) mirrorSPxz :: SPic -> SPic -mirrorSPxz = bimap id mirrorxz ---mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz --- where --- flipy (V3 x y z) = V3 x (negate y) z +mirrorSPxz = bimap (S.map (over shVs reverse) . overPosSH flipy) mirrorxz + where + flipy (V3 x y z) = V3 x (negate y) z mirrorSPyz :: SPic -> SPic -mirrorSPyz = bimap id mirroryz --- this can be done by creating a reverse topprism ShapeObj ---mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz --- where --- flipx (V3 x y z) = V3 (negate x) y z +mirrorSPyz = bimap (S.map (over shVs reverse) . overPosSH flipx) mirroryz + where + flipx (V3 x y z) = V3 (negate x) y z