Redo shape vertices as a list, should allow for mirroring

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) 

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.yield (mempty, extraPics cfig w)
-    <> (S.each $ fmap (dbArg _prDraw) (filtOn _prPos _props)                              )
+    <> S.map (dbArg _prDraw) (filtOn' _prPos _props)                             
-    <> (S.each $ fmap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)           )
+    <> S.map (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks)           
-    <> (S.each $ fmap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)   )
+    <> S.map (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _shapes)   
-    <> (S.each $ fmap (dbArg _cpPict) (filtOn _cpPos _corpses)                            )
+    <> S.map (dbArg _cpPict) (filtOn' _cpPos _corpses)                            
-    <> (S.map (dbArg _crPict) (filtOn' _crPos _creatures)                          )
+    <> S.map (dbArg _crPict) (filtOn' _crPos _creatures)                          
-    <> (S.each $ fmap floorItemSPic (filtOn _flItPos _floorItems)                         )
+    <> S.map floorItemSPic (filtOn' _flItPos _floorItems)                         
-    <> (S.each $ fmap btSPic (filtOn _btPos _buttons)                                     )
+    <> S.map btSPic (filtOn' _btPos _buttons)                                     
-    <> (S.each $ fmap mcSPic (filtOn _mcPos _machines)                                    )
+    <> 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

@@ -112,8 +112,8 @@ pokeShapeObj
     -> ShapeObj
     -> IO (Int,Int,Int)
 --{-# INLINE pokeShapeObj #-}
-pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
+pokeShapeObj ptr iptr ieptr counts (ShapeObj shtype shVerts) = case shtype of
-    TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts
+    TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts (S.each shVerts)
 
 pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort 
     -> Ptr GLushort 

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 #-}

src/Shape/Data.hs

@@ -29,7 +29,7 @@ shEfromList = id
 
 data ShapeObj = ShapeObj 
     { _shType   :: ShapeType 
-    , _shVs :: Stream (Of ShapeV) IO ()
+    , _shVs     :: [ShapeV]
     }
   deriving ()
 
@@ -46,3 +46,4 @@ pairToSV :: (Point3,Point4) -> ShapeV
 {-# INLINE pairToSV #-}
 pairToSV = uncurry ShapeV
 makeLenses ''ShapeV
+makeLenses ''ShapeObj

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 (S.map (over shVs reverse) . overPosSH flipy) mirrorxz
---mirrorSPxz = bimap (reverse . overPosSH flipy) mirrorxz
+  where
---  where
+    flipy (V3 x y z) = V3 x (negate y) z
---    flipy (V3 x y z) = V3 x (negate y) z
 
 mirrorSPyz :: SPic -> SPic
-mirrorSPyz = bimap id mirroryz
+mirrorSPyz = bimap (S.map (over shVs reverse) . overPosSH flipx) mirroryz
--- this can be done by creating a reverse topprism ShapeObj
+  where
---mirrorSPyz = bimap (reverse . overPosSH flipx) mirroryz
+    flipx (V3 x y z) = V3 (negate x) y z
---  where
---    flipx (V3 x y z) = V3 (negate x) y z