Add various helpers for creating polyhedra

shader/lighting/occlude.geom

@@ -5,7 +5,7 @@ layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
 uniform vec3 lightPos;
 
 vec4 shift (vec4 p)
-{ return vec4 (p.xy + (200 * (p.xy-lightPos.xy)), (-1) , 1);
+{ return vec4 (p.xy + (200 * (p.xy-lightPos.xy)), 0 , 1);
 }
 float isLHS (vec2 startV, vec2 testV)
 {

src/Data/Preload/Render.hs

@@ -7,8 +7,7 @@ import Shader.Data
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Control.Lens
 data RenderData = RenderData
-    { _lightingFloorShader      :: FullShader
+    { _lightingOccludeShader    :: FullShader
-    , _lightingOccludeShader    :: FullShader
     , _lightingWallShader       :: FullShader
     , _lightingSurfaceShader    :: FullShader
     , _lightingLineShadowShader :: FullShader

src/Dodge/Creature/Inanimate.hs

@@ -41,7 +41,7 @@ initialiseLamp :: CRUpdate
 initialiseLamp w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp i)
   where
     i = IM.newKey $ _lightSources $ f w -- to give different lights different keys
-    addLS = over lightSources (IM.insert i (lightAt (x,y,0) i))
+    addLS = over lightSources (IM.insert i (lightAt (x,y,100) i))
     (x,y) = _crPos cr
 
 updateLamp :: Int -> CRUpdate
@@ -53,7 +53,7 @@ updateLamp i = unrandUpdate handleLS internalUpdate
         | otherwise    = w & lightSources . ix i . lsPos .~ f cPos
       where
         cPos = _crPos cr
-        f (x,y) = (x,y,0)
+        f (x,y) = (x,y,100)
     internalUpdate cr 
         | _crHP cr < 0 = Nothing
         | otherwise    = Just $ doDamage cr

src/Dodge/LightSources.hs

@@ -14,7 +14,7 @@ lightAt (x,y,z) i =
     LS {_lsID = i
        ,_lsPos = (x,y,z)
        ,_lsDir = 0
-       ,_lsRad = 500
+       ,_lsRad = 300
        ,_lsIntensity = 0.75
        }
 basicLS :: PSType

src/Dodge/Picture.hs

@@ -4,6 +4,7 @@ Creates uniform sizes and commands for the Dodge modules. -}
 module Dodge.Picture
     where
 import Geometry
+import Geometry.Vector3D
 import Geometry.Data
 import Picture
 

src/Dodge/Render.hs

@@ -60,7 +60,7 @@ doDrawing pdata w = do
     bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
 
     -- store floor position into buffer
-    let addC (xx,yy) = (xx,yy,0.1)
+    let addC (xx,yy) = (xx,yy,0)
     nsurfVs <- F.foldM (pokeShader (_lightingSurfaceShader pdata)) [Render3 
         $ polyToTris $ map addC $ screenPolygon w ]
     bindShaderBuffers [_lightingSurfaceShader pdata] [nsurfVs]
@@ -123,7 +123,7 @@ doDrawing pdata w = do
             drawShader (_grayscaleShader pdata) 4
     blend $= Enabled
     
-    bufferUBO $ perspectiveMatrixc 0 1 (0,0) (2,2)
+    bufferUBO $ isoMatrix 0 1 (0,0) (2,2)
 
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
     _ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
@@ -131,8 +131,7 @@ doDrawing pdata w = do
     return (eTicks - sTicks)
 
 --------------------------------------------------------------------------------
-
+-- note: currently assume there is only one UBO, we only bind it once at setup
--- note we currently assume there is only one UBO, we only bind it once at setup
 bufferUBO :: [Float] -> IO ()
 bufferUBO mat = withArray mat $ \ptr ->
     bufferSubData UniformBuffer WriteToBuffer 0 64 ptr

src/Dodge/Room/Foreground.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Foreground
     where
 import Dodge.Picture
@@ -5,6 +6,8 @@ import Dodge.Base
 import Picture
 import Geometry
 import Geometry.Data
+import Geometry.Vector3D
+import Polyhedra
 
 import Data.List
 import Data.Maybe
@@ -45,13 +48,17 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
     yN = d * 0.5 *.* normalizeV (pa -.- pb)
 
 highPipe :: Point2 -> Point2 -> Picture
-highPipe x y = pictures 
+highPipe x@(xx,xy) y = pictures 
-    [setDepth 100 $ thickLine [x,y] 10
+    --[color orange . pictures . map (poly3D . map ( ( , black) . ( +.+.+ (x,y,50)))) $ boxXYZ 
-    ,setDepth 90 $ color orange $ thickLine [x,y] 10
+    [ color orange . pictures . map (poly3D . map ( (,black) . (+.+.+ (xx,xy,50)))) 
+        $ boxABC (a,b,0) (a',b',0) (0,0,10)
     ,verticalPipe 5 orange x 0 100 
     ,verticalPipe 5 orange y 0 100 
     ,verticalPipe 5 orange (0.5 *.* (x +.+ y)) 50 100 
     ]
+  where
+    (a,b) = y -.- x
+    (a',b') = 10 *.* (normalizeV $ vNormal (a,b))
 
 girderZ :: Float -> Point2 -> Point2 -> Picture
 girderZ w x y = setDepth 50 $ color red $ pictures $

src/Geometry/Vector.hs

@@ -35,36 +35,6 @@ a *.* (x2, y2) =
     !y = a * y2
   in (x, y)
 
-infixl 6 +.+.+, -.-.-
-infixl 7 *.*.*
-
-{- | 3D coordinate-wise addition.  -}
-(+.+.+) :: Point3 -> Point3 -> Point3
-{-# INLINE (+.+.+) #-}
-(x1, y1, z1) +.+.+ (x2, y2, z2) =
-  let
-    !x = x1 + x2
-    !y = y1 + y2
-    !z = z1 + z2
-  in (x, y, z)
-{- | 3D coordinate-wise subtraction.  -}
-(-.-.-) :: Point3 -> Point3 -> Point3
-{-# INLINE (-.-.-) #-}
-(x1, y1, z1) -.-.- (x2, y2, z2) =
-  let
-    !x = x1 - x2
-    !y = y1 - y2
-    !z = z1 - z2
-  in (x, y, z)
-{- | 3D scalar multiplication.  -}
-(*.*.*) :: Point3 -> Point3 -> Point3
-{-# INLINE (*.*.*) #-}
-(x1, y1, z1) *.*.* (x2, y2, z2) =
-  let
-    !x = x1 * x2
-    !y = y1 * y2
-    !z = z1 * z2
-  in (x, y, z)
 {- | Normalize a vector to length 1.  -}
 normalizeV :: Point2 -> Point2
 {-# INLINE normalizeV #-}

src/Geometry/Vector3D.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE BangPatterns #-}
+module Geometry.Vector3D
+    where
+import Geometry.Data
+
+infixl 6 +.+.+, -.-.-
+infixl 7 *.*.*
+
+{- | 3D coordinate-wise addition.  -}
+(+.+.+) :: Point3 -> Point3 -> Point3
+{-# INLINE (+.+.+) #-}
+(x1, y1, z1) +.+.+ (x2, y2, z2) =
+  let
+    !x = x1 + x2
+    !y = y1 + y2
+    !z = z1 + z2
+  in (x, y, z)
+{- | 3D coordinate-wise subtraction.  -}
+(-.-.-) :: Point3 -> Point3 -> Point3
+{-# INLINE (-.-.-) #-}
+(x1, y1, z1) -.-.- (x2, y2, z2) =
+  let
+    !x = x1 - x2
+    !y = y1 - y2
+    !z = z1 - z2
+  in (x, y, z)
+{- | 3D scalar multiplication.  -}
+(*.*.*) :: Point3 -> Point3 -> Point3
+{-# INLINE (*.*.*) #-}
+(x1, y1, z1) *.*.* (x2, y2, z2) =
+  let
+    !x = x1 * x2
+    !y = y1 * y2
+    !z = z1 * z2
+  in (x, y, z)
+
+crossProd :: Point3 -> Point3 -> Point3
+crossProd (x,y,z) (a,b,c) = 
+    ( y * c - z * b
+    , z * a - x * c
+    , x * b - y * a
+    )

src/MatrixHelper.hs

@@ -1,6 +1,6 @@
 module MatrixHelper
     ( perspectiveMatrixb
-    , perspectiveMatrixc
+    , isoMatrix
     ) where
 --import Geometry
 import Geometry.Data
@@ -28,13 +28,13 @@ perspectiveMatrixb rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) =
         !*! vertScale
         !*! vertTrans
 
-perspectiveMatrixc 
+isoMatrix 
     :: Float        -- ^ Rotation
     -> Float        -- ^ Zoom
     -> Point2       -- ^ Translation
     -> Point2       -- ^ Window size
     -> [GLfloat]
-perspectiveMatrixc rot zoom (tranx,trany) (winx,winy) = concatMap vToL 
+isoMatrix rot zoom (tranx,trany) (winx,winy) = concatMap vToL 
     . vToL 
     . lmt 
     $ scaleMat (2*zoom/winx,2*zoom/winy)

src/Picture/Render.hs

@@ -59,7 +59,7 @@ createLightMap
     -> (Float,Float)        -- View from position
     -> Picture              -- foreground pictures
     -> IO ()
-createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) _ = do
+createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) fpics = do
     -- get viewport size so we can reset it later
     (vppos,vpsize) <- get viewport
     -- set the viewport size to that of the render buffer
@@ -98,12 +98,6 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) _ = do
     blendFunc $= (Zero, OneMinusSrcAlpha)
     stencilTest $= Enabled
     forM_ lightPoints $ \((x,y,z),r,lum) -> do
--- bind buffer for floor light circle
-        let lightPtr = _vboPointer $ _vaoVBO $ _shaderVAO $ _lightingFloorShader pdata
-        pokeFourOff lightPtr 0 (x,y,r,lum)
-        bindShaderBuffers [_lightingFloorShader pdata] [1]
-
-        
 -- stencil out walls
         colorMask $= Color4 Disabled Disabled Disabled Disabled
         clear [StencilBuffer]
@@ -121,7 +115,6 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) _ = do
         cullFace $= Nothing
         colorMask $= Color4 Disabled Disabled Disabled Enabled
         stencilFunc $= (Equal, 0, 255)
---        drawShader (_lightingFloorShader pdata) 1
 -- draw floor surface
         currentProgram $= Just (_shaderProgram $ _lightingSurfaceShader pdata)
         uniform (head $  _shaderCustomUnis $ _lightingSurfaceShader pdata)

src/Picture/ToPolyhedra.hs

@@ -0,0 +1,11 @@
+module Picture.ToPolyhedra
+    where
+import Picture.Data
+import Geometry.Data
+
+toPolyhedra :: Picture -> [[Point3]]
+toPolyhedra (OnLayer _ pic) = toPolyhedra pic
+toPolyhedra (Pictures pics) = concatMap toPolyhedra pics
+toPolyhedra (OverPic f _ pic) = map (map f) $ toPolyhedra pic
+toPolyhedra (Poly3D _ vs) = [fst $ unzip vs]
+toPolyhedra _ = []

src/Polyhedra.hs

@@ -0,0 +1,76 @@
+module Polyhedra
+    where
+import Geometry.Data
+import Geometry.Vector3D
+
+import Data.Maybe
+import Data.List
+
+-- | Polyhedra are represented using two types of data: 
+-- 1. a list of faces,
+-- 2. a list of edges.
+-- Each face is a list of points that are assumed to lie on a plane, and be
+-- ordered to form an anticlockwise convex polygon within that plane.
+-- Each edge is a tuple containing four points: the first two are the two edge
+-- coordinates, the last two being the normals of two planes of the polyhedra
+-- that the edge connects.
+data Polyhedra = Polyhedron
+    { _pyFaces :: [[Point3]]
+    , _pyEdges :: [(Point3,Point3,Point3,Point3)]
+    }
+
+constructEdges :: [[Point3]] -> [(Point3,Point3,Point3,Point3)]
+constructEdges (face:faces) = mapMaybe (findReverseEdge otherEdges) (faceEdges face) 
+    ++ constructEdges faces
+  where
+    otherEdges = concatMap faceEdges faces
+constructEdges _ = []
+
+findReverseEdge 
+    :: [(Point3,Point3,Point3)] 
+    -> (Point3,Point3,Point3) 
+    -> Maybe (Point3,Point3,Point3,Point3)
+findReverseEdge otherEdges (x,y,z) = fmap (\(_,_,n) -> (x,y,z,n))
+    $ find (\(a,b,_) -> (x,y) == (b,a)) otherEdges
+
+faceEdges :: [Point3] -> [(Point3,Point3,Point3)]
+faceEdges xs = map addNormal $ zip xs (tail xs ++ [head xs])
+  where
+    addNormal (x,y) = (x,y,n)
+    (a:b:c:_) = xs
+    n = crossProd (b -.-.- a) (c -.-.- a)
+
+rhombus :: Point3 -> Point3 -> [Point3]
+rhombus a b = 
+    [(0,0,0)
+    ,a
+    ,a +.+.+ b
+    ,b
+    ]
+
+boxXYZ :: Float -> Float -> Float -> [[Point3]]
+boxXYZ x y z = 
+    [ bottomFace
+    , map (+.+.+ (0,0,z)) $ reverse bottomFace
+    , frontFace
+    , map (+.+.+ (0,y,0)) $ reverse frontFace
+    , sideFace
+    , map (+.+.+ (x,0,0)) $ reverse sideFace
+    ]
+  where
+    bottomFace = rhombus (0,y,0) (x,0,0) 
+    frontFace  = rhombus (x,0,0) (0,0,z)
+    sideFace   = rhombus (0,0,z) (0,y,0)
+boxABC :: Point3 -> Point3 -> Point3 -> [[Point3]]
+boxABC a b c =
+    [ faceNC
+    , map (+.+.+ c) $ reverse faceNC
+    , faceNB
+    , map (+.+.+ b) $ reverse faceNB
+    , faceNA
+    , map (+.+.+ a) $ reverse faceNA
+    ]
+  where
+    faceNC = rhombus b a
+    faceNB = rhombus a c
+    faceNA = rhombus c b

src/Preload/Render.hs

@@ -26,8 +26,6 @@ preloadRender = do
     bindBufferBase IndexedUniformBuffer 0 $= Just theUBO
 
 -- lighting shaders
-    lightingFloorShad <- makeShader "lighting/floor" [vert,geom,frag] [4] Points 
-                    pokeLightingFloorStrat
     wsShad <- makeShader "lighting/occlude" [vert,geom,frag] [4] Points pokeWPStrat
                 >>= addUniforms ["lightPos"]
     wlLightShad 
@@ -80,7 +78,6 @@ preloadRender = do
         { _pictureShaders           = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
         , _lightingSurfaceShader    = lightingSurfaceShad
         , _lightingLineShadowShader = lightingLineShadowShad
-        , _lightingFloorShader      = lightingFloorShad
         , _lightingOccludeShader    = wsShad
         , _lightingWallShader       = wlLightShad
         , _wallBlankShader          = wlBlank
@@ -153,7 +150,6 @@ setupFramebuffer = do
 cleanUpRenderPreload :: RenderData -> IO ()
 cleanUpRenderPreload pd = do
     mapM_ freeShaderPointers $ _pictureShaders pd
-    freeShaderPointers $ _lightingFloorShader pd
     freeShaderPointers $ _lightingOccludeShader pd
     freeShaderPointers $ _fullscreenShader pd
 
@@ -169,10 +165,6 @@ pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType
 pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> flat3 p ++ flat4 co) vs
 pokeTriStrat _ = []
 
-pokeLightingFloorStrat :: RenderType -> [[Float]]
-pokeLightingFloorStrat Render1111{_unRender1111=x} = [flat4 x]
-pokeLightingFloorStrat _ = undefined
-
 pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> concat [flat3 a, flat4 b, flat2 c]) vs
 pokeCharStrat _ = []