From 089dcc3f5d73063df420387f6782b97076a51cb3 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 27 Jun 2021 18:53:06 +0200 Subject: [PATCH] Add various helpers for creating polyhedra --- shader/lighting/occlude.geom | 2 +- src/Data/Preload/Render.hs | 3 +- src/Dodge/Creature/Inanimate.hs | 4 +- src/Dodge/LightSources.hs | 2 +- src/Dodge/Picture.hs | 1 + src/Dodge/Render.hs | 7 ++- src/Dodge/Room/Foreground.hs | 13 ++++-- src/Geometry/Vector.hs | 30 ------------- src/Geometry/Vector3D.hs | 42 ++++++++++++++++++ src/MatrixHelper.hs | 6 +-- src/Picture/Render.hs | 15 ++----- src/Picture/ToPolyhedra.hs | 11 +++++ src/Polyhedra.hs | 76 +++++++++++++++++++++++++++++++++ src/Preload/Render.hs | 8 ---- 14 files changed, 155 insertions(+), 65 deletions(-) create mode 100644 src/Geometry/Vector3D.hs create mode 100644 src/Picture/ToPolyhedra.hs create mode 100644 src/Polyhedra.hs diff --git a/shader/lighting/occlude.geom b/shader/lighting/occlude.geom index 21c3584a9..e810aed43 100644 --- a/shader/lighting/occlude.geom +++ b/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) { diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index 3c68f2f45..8dc0b72c4 100644 --- a/src/Data/Preload/Render.hs +++ b/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 diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index b301d3740..48afcdc64 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/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 diff --git a/src/Dodge/LightSources.hs b/src/Dodge/LightSources.hs index 2fecfb8d1..12fba8d6e 100644 --- a/src/Dodge/LightSources.hs +++ b/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 diff --git a/src/Dodge/Picture.hs b/src/Dodge/Picture.hs index 01051ad9a..9f483e3c5 100644 --- a/src/Dodge/Picture.hs +++ b/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 diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 75a5d0fdc..c6f437513 100644 --- a/src/Dodge/Render.hs +++ b/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 we currently assume there is only one UBO, we only bind it once at setup +-- note: 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 diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 2068418dc..e3b6a6442 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/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 - [setDepth 100 $ thickLine [x,y] 10 - ,setDepth 90 $ color orange $ thickLine [x,y] 10 +highPipe x@(xx,xy) y = pictures + --[color orange . pictures . map (poly3D . map ( ( , black) . ( +.+.+ (x,y,50)))) $ boxXYZ + [ 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 $ diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 5889a5c14..f45dd633f 100644 --- a/src/Geometry/Vector.hs +++ b/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 #-} diff --git a/src/Geometry/Vector3D.hs b/src/Geometry/Vector3D.hs new file mode 100644 index 000000000..5044b14a0 --- /dev/null +++ b/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 + ) diff --git a/src/MatrixHelper.hs b/src/MatrixHelper.hs index f41fa6423..cfa1e1d53 100644 --- a/src/MatrixHelper.hs +++ b/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) diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 2cfa20bcd..ac80bd2ee 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -59,14 +59,14 @@ createLightMap -> (Float,Float) -- View from position -> Picture -- foreground pictures -> IO () -createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) _ = do --- get viewport size so we can reset it later +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 + -- set the viewport size to that of the render buffer viewport $= (vppos, divideSize resDiv vpsize) bindFramebuffer Framebuffer $= _spareFBO pdata --- store wall and light positions into buffer + -- store wall and light positions into buffer nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) (map Render22 wallPoints) bindShaderBuffers [_lightingWallShader pdata] [nWallLights] nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints) @@ -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) diff --git a/src/Picture/ToPolyhedra.hs b/src/Picture/ToPolyhedra.hs new file mode 100644 index 000000000..7b0f2923d --- /dev/null +++ b/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 _ = [] diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs new file mode 100644 index 000000000..33208c9d2 --- /dev/null +++ b/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 diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index e107797a4..697b9748f 100644 --- a/src/Preload/Render.hs +++ 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 _ = []