Continue shape rendering improvements

src/Dodge/Data.hs

@@ -27,7 +27,6 @@ import Data.Preload
 import Picture.Data
 import ShapePicture
 import Geometry.Data
-import Polyhedra.Data
 import Sound.Data
 import qualified DoubleStack as DS
 import Dodge.GameRoom
@@ -76,7 +75,8 @@ data World = World
     , _playingSounds        :: M.Map SoundOrigin Sound
     , _decorations          :: IM.IntMap Picture
     , _foregroundShape      :: Shape
-    , _foregroundDecorations :: [Polyhedra]
+    --, _foregroundDecorations :: [Polyhedra]
+    , _foregroundDecorations :: Shape
     , _foregroundEdgeVerx   :: [Point3]
     , _corpses              :: Zone [Corpse]
     , _clickMousePos        :: !Point2

src/Dodge/Default/World.hs

@@ -80,7 +80,7 @@ defaultWorld = World
     , _inventoryMode = TopInventory
     , _lClickHammer = HammerUp
     , _foregroundShape = mempty
-    , _foregroundDecorations = []
+    , _foregroundDecorations = mempty
     , _foregroundEdgeVerx = []
     , _radDistortion = []
     , _gameRooms = []

src/Dodge/Layout.hs

@@ -24,7 +24,6 @@ import Picture.Data
 import Tile
 import Polyhedra
 import Polyhedra.Data
-import Shape
 
 import Control.Monad.State
 import Control.Lens
@@ -78,11 +77,7 @@ setupWorldBounds w = w
         ) ps
 
 setupForegroundEdgeVerxs :: World -> World
-setupForegroundEdgeVerxs w = w & foregroundEdgeVerx .~ polyhedrasToEdges (_foregroundDecorations w)
+setupForegroundEdgeVerxs w = w & foregroundShape .~ (_foregroundDecorations w)
-    & foregroundShape .~ ([ShapeObj ListV vs],es)
-  where
-    vs = shVfromList $ map pairToSV $ concatMap polyToTris $ concatMap _pyFaces $ _foregroundDecorations w
-    es = shEfromList $ polyhedrasToEdges (_foregroundDecorations w)
 
 polyhedrasToEdges :: [Polyhedra] -> [Point3]
 polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges

src/Dodge/LevelGen.hs

@@ -19,9 +19,9 @@ import Dodge.LevelGen.TriggerDoor
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Data
 import Geometry
+import Shape
 --import Geometry.Data
 import Picture
-import Polyhedra
 import qualified IntMapHelp as IM
 
 --import System.Random
@@ -99,7 +99,7 @@ placeSpot ps w = case _psType ps of
       where 
         (q:qs) = map (shiftPointBy (p,rot)) ps'
         rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
-    PutForeground poly -> w & foregroundDecorations %~ (map (uncurryV translateXY p . rotateXY rot) poly ++)
+    PutForeground sh -> w & foregroundDecorations %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)
     PutNothing -> w
     PutID _ -> w
     --_   -> w

src/Dodge/LevelGen/Data.hs

@@ -19,8 +19,8 @@ module Dodge.LevelGen.Data
     ) where
 import Dodge.Data
 import Picture
-import Polyhedra.Data
 import Geometry.Data
+import Shape.Data
 
 import Control.Lens
 import Control.Monad.State
@@ -40,7 +40,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutBtDoor Color Point2 Float Point2 Point2 Float
     | PutSwitchDoor Color Point2 Float Point2 Point2 Float
     | RandPS (State StdGen PSType)
-    | PutForeground [Polyhedra]
+    | PutForeground Shape
     | PutNothing
     | PutID { _putID :: Int}
 data PlacementSpot = PS

src/Dodge/Render.hs

@@ -19,7 +19,6 @@ import Shader.Bind
 import Shader.Data
 import MatrixHelper
 --import Polyhedra.Data
-import Polyhedra
 import Shader.ExtraPrimitive
 import Shader.Parameters
 
@@ -98,8 +97,6 @@ doDrawing pdata w = do
     if w ^. config . wall_textured
         then renderTextureWalls pdata nWalls
         else renderBlankWalls pdata nWalls
-    ---draw foreground geometry onto base buffer
-    renderFoldable shadV $ polysToPic $ foregroundPics w
     --draw objects onto base buffer
     layerCounts <- UMV.replicate (6*6) 0
     pokeBindFoldableLayer shadV layerCounts $ worldPictures w

src/Dodge/Render/Picture.hs

@@ -14,7 +14,6 @@ import Dodge.SoundLogic.LoadSound
 import Sound.Data
 import Geometry
 import Picture
-import Polyhedra.Data
 import ShapePicture
 
 import Control.Lens
@@ -42,9 +41,6 @@ worldPictures w = pictures
     winSize = 30 + max (getWindowX w) (getWindowY w)
     camCen = _cameraCenter w
     
-foregroundPics :: World -> [Polyhedra]
-foregroundPics = _foregroundDecorations
-
 fixedCoordPictures :: World -> Picture
 fixedCoordPictures w = case _menuLayers w of 
     [] -> pictures

src/Dodge/Room/Foreground.hs

@@ -6,9 +6,8 @@ import Dodge.Base
 import Picture
 import Geometry
 --import Geometry.Data
-import Geometry.Vector3D
+--import Geometry.Vector3D
-import Polyhedra
+import Shape
-import Polyhedra.Data
 
 import Data.List
 import Data.Maybe
@@ -48,14 +47,11 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
         ]
     yN = d * 0.5 *.* normalizeV (pa -.- pb)
 
-highPipe :: Float -> Point2 -> Point2 -> [Polyhedra]
+highPipe :: Float -> Point2 -> Point2 -> Shape
-highPipe h x@(V2 xx xy) y = 
+highPipe h x y = translateSHz h $ colorSH orange $ upperPrismPoly 5
-    [ Polyhedron . map (map ( (,orange) . (+.+.+ V3 xx xy h))) 
+    [x +.+ n, y +.+ n, y -.- n, x -.- n]
-        $ boxABC (V3 a b 0) (V3 a' b' 0) (V3 0 0 5)
-    ]
   where
-    (V2 a b) = y -.- x
+    n = 2.5 *.* normalizeV (vNormal (y -.- x))
-    (V2 a' b') = 10 *.* normalizeV (vNormal (V2 a b))
 
 girderZ :: Float -> Point2 -> Point2 -> Picture
 girderZ w x y = setDepth 50 $ color red $ pictures $

src/Dodge/Room/Start.hs

@@ -25,8 +25,8 @@ startRoom = do
     h <- state $ randomR (200,400)
     let fground = sPS (V2 0 0) 0 $ PutForeground $ 
                highPipe 80 (V2  0    (h/3)) (V2  w    (h/2))
-            ++ highPipe 40 (V2  0    (h/2)) (V2  w    (h/3))
+            <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/3))
-            ++ highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
+            <> highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
         theLamp = sPS (V2 (w/2) (h/2)) 0 $ putColorLamp (V3 0.75 0.75 0.75)
     treeFromPost [Left rezBox, Left door] . Right 
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 

src/Shader/Poke.hs

@@ -62,7 +62,6 @@ pokeShapeObjs ptr iptr _ count = VS.foldlM' (pokeShapeObj ptr iptr) count . VS.f
 
 pokeShapeObj :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeObj -> IO (Int,Int,Int,Int)
 pokeShapeObj ptr iptr counts (ShapeObj shType shVerts) = case shType of
-    ListV -> pokeShapeVs ptr iptr counts shVerts
     TopPrism size -> pokeTopPrism size ptr iptr counts shVerts
 
 pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int,Int)
@@ -80,9 +79,6 @@ pokeTopPrismIndex nv iptr ni ioff = do
     pokeElemOff iptr ni (fromIntegral $ nv + ioff)
     return (ni + 1)
 
-pokeShapeVs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int, Int,Int,Int)
-pokeShapeVs ptr iptr count = VS.foldlM' (pokeShapeV ptr iptr) count . VS.fromList
-
 pokeShapeEs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [Point3] -> IO (Int,Int,Int,Int)
 pokeShapeEs ptr ieptr count = VS.foldlM' (pokeShapeE ptr ieptr) count . VS.fromList
 
@@ -120,23 +116,6 @@ pokeJustV ptr (nv,ne,ni,nei) sh = do
     V3 a b c    = _svPos sh
     V4 d e f g  = _svCol sh
 
-pokeShapeV :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeV -> IO (Int,Int,Int,Int)
-pokeShapeV ptr iptr (nv,ne,ni,nei) sh = do
-    pokeElemOff ptr (off 0) a
-    pokeElemOff ptr (off 1) b
-    pokeElemOff ptr (off 2) c
-    pokeElemOff ptr (off 3) d
-    pokeElemOff ptr (off 4) e
-    pokeElemOff ptr (off 5) f
-    pokeElemOff ptr (off 6) g
-    pokeElemOff iptr ni (fromIntegral nv)
-    return (nv+1,ne,ni+1,nei)
-  where
-    off i = nv*7 + i
-    V3 a b c    = _svPos sh
-    V4 d e f g  = _svCol sh
-
-
 pokePoint3s :: Ptr Float -> VS.Stream IO Point3 -> IO Int
 pokePoint3s ptr = VS.foldlM' (pokePoint3 ptr) 0
 

src/Shape.hs

@@ -4,6 +4,7 @@ module Shape
     , translateSH
     , emptySH
     , upperPrismPoly
+    , polyCirc
     , translateSHz
     , translateSHf
     , rotateSH
@@ -24,8 +25,8 @@ emptySH :: Shape
 emptySH = mempty
 
 polyCirc :: Int -> Float -> [Point2]
-{-# INLINE polycirc #-}
+{-# INLINE polyCirc #-}
-polyCirc n r = map (\i -> rotateV ) [0..n]
+polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/(fromIntegral n)..]
 
 upperPrismPoly 
     :: Float    -- ^ height, expected to be strictly positive
@@ -53,22 +54,6 @@ upperPrismPoly h ps =
     sideEdges = shEfromList $ concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
     makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h]
 
-flatPoly :: [Point2] -> Shape
-flatPoly ps =
-    ( [ShapeObj ListV $ shVfromList $ polyToTris $ map f ps]
-    , shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps])
-    )
-  where
-    f (V2 x y) = pairToSV ( V3 x y 0,  black )
-    g (V2 x y) (V2 a b) =
-        [ V3 x y   0
-        , V3 a b   0
-        , V3 x y 0 -.-.- n
-        , V3 a b 0 -.-.- n
-        ]
-      where
-        n = addZ 0 $ vNormal (V2 (a-x) (b-y))
-
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
 colorSH col = overCol $ const col

src/Shape/Data.hs

@@ -40,8 +40,7 @@ data ShapeObj = ShapeObj
 
 data ShapeType
     = TopPrism Int
-    | ListV
+--    | ListV
---    | TopHexahedron    -- ^ assumed convex, eight vertices
 
 -- edges are given by four consecutive points
 data ShapeV = ShapeV