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

Redo shape vertices as a list, should allow for mirroring

Browse Source
This commit is contained in:
justin
2022-07-04 23:17:53 +01:00
parent 914c452afb
commit 22ac8feb37
6 changed files with 35 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Render.hs
+1 -1
View File
@@ -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)
src/Dodge/Render/ShapePicture.hs
+11 -11
View File
@@ -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
src/Shader/Poke.hs
+2 -2
View File
@@ -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
src/Shape.hs
+10 -18
View File
@@ -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 #-}
src/Shape/Data.hs
+3 -2
View File
@@ -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
src/ShapePicture.hs
+8 -9
View File
@@ -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