From 294e01479a7495c976dcf0679d9e6f0ac9575de4 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 14 Sep 2021 01:17:07 +0100 Subject: [PATCH] Define shape datatype --- src/Color.hs | 74 ++++++++++++++++++++ src/Data/Preload/Render.hs | 1 + src/Dodge/Creature/State/Data.hs | 3 +- src/Dodge/Data.hs | 1 + src/Dodge/Item/Weapon/Bezier.hs | 2 +- src/Dodge/Item/Weapon/Bullet.hs | 4 +- src/Dodge/LevelGen/Block.hs | 2 +- src/Dodge/Particle/Bullet/HitEffect.hs | 11 +-- src/Dodge/Render.hs | 9 ++- src/Dodge/Render/Shape.hs | 9 +++ src/Picture.hs | 96 ++------------------------ src/Picture/Data.hs | 3 +- src/Polyhedra/Data.hs | 2 +- src/Preload/Render.hs | 3 +- src/Shader/Bind.hs | 1 + src/Shader/Poke.hs | 37 ++++++++++ src/Shape.hs | 62 +++++++++++++++++ src/Shape/Data.hs | 17 +++++ 18 files changed, 226 insertions(+), 111 deletions(-) create mode 100644 src/Color.hs create mode 100644 src/Dodge/Render/Shape.hs create mode 100644 src/Shape.hs create mode 100644 src/Shape/Data.hs diff --git a/src/Color.hs b/src/Color.hs new file mode 100644 index 000000000..d7226e35d --- /dev/null +++ b/src/Color.hs @@ -0,0 +1,74 @@ +module Color + where +import Geometry + +type RGBA = Point4 +type Color = Point4 + +withAlpha :: Float -> RGBA -> RGBA +{-# INLINE withAlpha #-} +withAlpha a (V4 x y z a') = V4 x y z (a*a') + +red,green,blue,yellow,cyan,magenta,rose + ,violet,azure,aquamarine,chartreuse,orange,white,black::Color +red = V4 1 0 0 1 +green = V4 0 1 0 1 +blue = V4 0 0 1 1 +yellow = V4 1 1 0 1 +cyan = V4 0 1 1 1 +magenta = V4 1 0 1 1 +rose = V4 1 0 0.5 1 +violet = V4 0.5 0 1 1 +azure = V4 0 0.5 1 1 +aquamarine= V4 0 1 0.5 1 +chartreuse= V4 0.5 1 0 1 +orange = V4 1 0.5 0 1 +white = V4 1 1 1 1 +black = V4 0 0 0 1 +{-# INLINE red #-} +{-# INLINE green #-} +{-# INLINE blue #-} +{-# INLINE yellow #-} +{-# INLINE cyan #-} +{-# INLINE magenta #-} +{-# INLINE rose #-} +{-# INLINE violet #-} +{-# INLINE azure #-} +{-# INLINE aquamarine #-} +{-# INLINE chartreuse #-} +{-# INLINE orange #-} +{-# INLINE white #-} +{-# INLINE black #-} + +mixColors :: Float -> Float -> Color -> Color -> Color +{-# INLINE mixColors #-} +mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = + let fullrat = rata + ratb + normrata = rata / fullrat + normratb = ratb / fullrat + f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int) + in V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2) + +light :: Color -> Color +{-# INLINE light #-} +light (V4 r g b a) = V4 (r+0.2) (g+0.2) (b+0.2) a + +dark :: Color -> Color +{-# INLINE dark #-} +dark (V4 r g b a) = V4 (r-0.2) (g-0.2) (b-0.2) a + +dim :: Color -> Color +{-# INLINE dim #-} +dim (V4 r g b a) = V4 (r/1.2) (g/1.2) (b/1.2) a + +brightX :: Float -> Float -> Color -> Color +{-# INLINE brightX #-} +brightX cm am (V4 r g b a) = V4 (r*cm) (g*cm) (b*cm) (a*am) + +bright :: Color -> Color +{-# INLINE bright #-} +bright (V4 r g b a) = V4 (r*1.2) (g*1.2) (b*1.2) a + +greyN :: Float -> Color +{-# INLINE greyN #-} +greyN x = toV4 (x,x,x,1) diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index 86beb997b..94ac14958 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -28,6 +28,7 @@ data RenderData = RenderData , _colorBlurShader :: FullShader , _barrelShader :: FullShader , _grayscaleShader :: FullShader + , _shapeShader :: FullShader , _pictureShaders :: MV.MVector (PrimState IO) FullShader , _fbo2 :: (FramebufferObject, TextureObject) , _fbo3 :: (FramebufferObject, TextureObject) diff --git a/src/Dodge/Creature/State/Data.hs b/src/Dodge/Creature/State/Data.hs index 09d34891e..a32258a5b 100644 --- a/src/Dodge/Creature/State/Data.hs +++ b/src/Dodge/Creature/State/Data.hs @@ -5,8 +5,7 @@ module Dodge.Creature.State.Data --import Geometry import Geometry.Data import Dodge.Data.DamageType ---import Dodge.Creature.Stance.Data -import Picture.Data +import Color import Control.Lens import qualified Data.IntSet as IS diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 7bdf5912a..73d7bdf08 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -30,6 +30,7 @@ import Polyhedra.Data import Sound.Data import qualified DoubleStack as DS import Dodge.GameRoom +import Color import GHC.Generics import Control.Lens diff --git a/src/Dodge/Item/Weapon/Bezier.hs b/src/Dodge/Item/Weapon/Bezier.hs index 45bed8ac7..6ab52a501 100644 --- a/src/Dodge/Item/Weapon/Bezier.hs +++ b/src/Dodge/Item/Weapon/Bezier.hs @@ -59,7 +59,7 @@ shootBezier targetp cr w = w & particles %~ (theBullet :) startp (controlp +.+ randPos) (targetp +.+ randPos') - (destroyOnImpact bulHitCr bulHitWall' bulHitFF') + (destroyOnImpact bulHitCr bulHitWall bulHitFF') 5 controlp = mouseWorldPos w cid = _crID cr diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index f49895339..680aba281 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -8,14 +8,14 @@ import Geometry.Data basicBullet :: Ammo basicBullet = BulletAmmo { _amString = "BULLET" - , _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF' + , _amBulEff = destroyOnImpact bulHitCr bulHitWall bulHitFF' , _amBulWth = 2 , _amBulVel = V2 50 0 } ltBullet :: Ammo ltBullet = BulletAmmo { _amString = "LTBULLET" - , _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF' + , _amBulEff = destroyOnImpact bulHitCr bulHitWall bulHitFF' , _amBulWth = 2 , _amBulVel = V2 40 0 } diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index 792330b92..3f39c94df 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -11,8 +11,8 @@ import Dodge.WorldEvent.Sound import Dodge.LevelGen.Pathing import Dodge.RandomHelp import Geometry -import Picture.Data import qualified IntMapHelp as IM +import Color import Control.Lens import Control.Monad.State diff --git a/src/Dodge/Particle/Bullet/HitEffect.hs b/src/Dodge/Particle/Bullet/HitEffect.hs index 7d4e367e7..65a1b7e98 100644 --- a/src/Dodge/Particle/Bullet/HitEffect.hs +++ b/src/Dodge/Particle/Bullet/HitEffect.hs @@ -137,10 +137,10 @@ bulConCr' bt p cr w ep = sp +.+ _btVel' bt mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white) {- | Hitting wall effects: create a spark, damage blocks. -} -bulHitWall' :: Particle -> Point2 -> Wall -> World -> World -bulHitWall' bt p wl w = damageBlocksBy 5 wl +bulHitWall :: Particle -> Point2 -> Wall -> World -> World +bulHitWall bt p wl w = damageBlocksBy 5 wl . smokeCloudAt dustcol 20 200 1 (addZ 20 pOut) - $ createSparkCol 8 theCol pOut (reflectDir wl) + . createSparkCol 8 theCol pOut (reflectDir wl) $ set randGen g w where @@ -212,8 +212,3 @@ hvBulHitWall' bt p x w = damageBlocksBy 5 x $ set randGen g $ foldr ($) w (spar bulHitFF' :: Particle -> Point2 -> ForceField -> World -> World bulHitFF' _ _ _ = id -{- | Typical effect: destroy on impact, damage creatures and blocks, create spark on walls. -} -basicBulletEffect :: HitEffect -basicBulletEffect = destroyOnImpact bulHitCr bulHitWall' bulHitFF' - - diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index b79637ddf..c7fa76084 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -10,6 +10,7 @@ import Dodge.Base.Window import Dodge.Render.Picture --import Dodge.Creature.ShadowBox import Dodge.Creature.Silhouette +import Dodge.Render.Shape import Geometry import Render import Data.Preload.Render @@ -20,7 +21,7 @@ import Shader.Data import MatrixHelper --import Polyhedra.Data import Polyhedra ---import Tuple +import Shape.Data import Foreign --import Control.Applicative @@ -88,6 +89,12 @@ doDrawing pdata w = do layerCounts <- UMV.replicate (6*6) 0 pokeBindFoldableLayer shadV layerCounts $ worldPictures w renderLayer 0 shadV layerCounts + + numShapeVs <- pokeShapeVs (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) + $ _shVertices $ worldShape w + bindShaderBuffers [_shapeShader pdata] [numShapeVs] + drawShader (_shapeShader pdata) numShapeVs + --draw floor onto base buffer nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w) bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs] diff --git a/src/Dodge/Render/Shape.hs b/src/Dodge/Render/Shape.hs new file mode 100644 index 000000000..6fde1ee81 --- /dev/null +++ b/src/Dodge/Render/Shape.hs @@ -0,0 +1,9 @@ +module Dodge.Render.Shape + where +import Dodge.Data +import Shape +import Geometry +import Color + +worldShape :: World -> Shape +worldShape _ = colorSh green . translateSh (V3 (-20) 200 50) . flatPoly $ rectNSWE 20 0 0 20 diff --git a/src/Picture.hs b/src/Picture.hs index 271d1d1b1..08f54d1bf 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE TupleSections - , BangPatterns - #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} module Picture ( module Picture.Data + , module Color , blank , polygon , polygonZ @@ -32,28 +32,6 @@ module Picture , rotate , scale , color - , withAlpha - , greyN - , red - , green - , blue - , yellow - , cyan - , magenta - , rose - , violet - , azure - , aquamarine - , chartreuse - , orange - , white - , black - , dim - , light - , dark - , bright - , brightX - , mixColors , zeroZ , setDepth , addDepth @@ -64,6 +42,7 @@ import Geometry import Geometry.Vector3D --import Geometry.Data import Picture.Data +import Color --import Data.List --import Data.Bifunctor @@ -337,73 +316,6 @@ thickArcHelp startA endA rad wdth = map f (V2 xc yc) = rotateV endA (V2 rad 0) f (pos,col,V3 a b c) = Verx pos col [a,b,c] 0 arcNum -withAlpha :: Float -> RGBA -> RGBA -{-# INLINE withAlpha #-} -withAlpha a (V4 x y z a') = V4 x y z (a*a') - -red,green,blue,yellow,cyan,magenta,rose - ,violet,azure,aquamarine,chartreuse,orange,white,black::Color -red = V4 1 0 0 1 -green = V4 0 1 0 1 -blue = V4 0 0 1 1 -yellow = V4 1 1 0 1 -cyan = V4 0 1 1 1 -magenta = V4 1 0 1 1 -rose = V4 1 0 0.5 1 -violet = V4 0.5 0 1 1 -azure = V4 0 0.5 1 1 -aquamarine= V4 0 1 0.5 1 -chartreuse= V4 0.5 1 0 1 -orange = V4 1 0.5 0 1 -white = V4 1 1 1 1 -black = V4 0 0 0 1 -{-# INLINE red #-} -{-# INLINE green #-} -{-# INLINE blue #-} -{-# INLINE yellow #-} -{-# INLINE cyan #-} -{-# INLINE magenta #-} -{-# INLINE rose #-} -{-# INLINE violet #-} -{-# INLINE azure #-} -{-# INLINE aquamarine #-} -{-# INLINE chartreuse #-} -{-# INLINE orange #-} -{-# INLINE white #-} -{-# INLINE black #-} - -mixColors :: Float -> Float -> Color -> Color -> Color -{-# INLINE mixColors #-} -mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = - let fullrat = rata + ratb - normrata = rata / fullrat - normratb = ratb / fullrat - f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int) - in V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2) - -light :: Color -> Color -{-# INLINE light #-} -light (V4 r g b a) = V4 (r+0.2) (g+0.2) (b+0.2) a - -dark :: Color -> Color -{-# INLINE dark #-} -dark (V4 r g b a) = V4 (r-0.2) (g-0.2) (b-0.2) a - -dim :: Color -> Color -{-# INLINE dim #-} -dim (V4 r g b a) = V4 (r/1.2) (g/1.2) (b/1.2) a - -brightX :: Float -> Float -> Color -> Color -{-# INLINE brightX #-} -brightX cm am (V4 r g b a) = V4 (r*cm) (g*cm) (b*cm) (a*am) - -bright :: Color -> Color -{-# INLINE bright #-} -bright (V4 r g b a) = V4 (r*1.2) (g*1.2) (b*1.2) a - -greyN :: Float -> Color -{-# INLINE greyN #-} -greyN x = toV4 (x,x,x,1) -- Currently the lens version is much slower overPos :: (Point3 -> Point3) -> Verx -> Verx diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 9c78ecd82..75a74140c 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} module Picture.Data where @@ -27,8 +28,6 @@ textNum = ShadNum 3 arcNum = ShadNum 4 ellNum = ShadNum 5 type Picture = [Verx] -type RGBA = Point4 -type Color = Point4 flat2 :: V2 a -> [a] flat2 (V2 x y) = [x,y] flat3 :: V3 a -> [a] diff --git a/src/Polyhedra/Data.hs b/src/Polyhedra/Data.hs index daeb09ead..b93a97a8d 100644 --- a/src/Polyhedra/Data.hs +++ b/src/Polyhedra/Data.hs @@ -14,7 +14,7 @@ newtype Polyhedra = Polyhedron { _pyFaces :: [[(Point3,Point4)]] } --- | Describe a polygon as a map from vertex indices to a positiong and list of faces. +-- | Describe a polygon as a map from vertex indices to a positioning and list of faces. -- The list of faces is assumed to be ordered in clockwise direction around the vertex. -- The vertices of the faces are assumed to start with a point adjacent to the -- key vertex and to be listed anticlockwise around the center of the face. diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index e7e20aed8..de6e0a8a6 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -77,6 +77,7 @@ preloadRender = do >>= addUniforms ["lightPos"] -- 2D draw shaders bslist <- makeShader "dualTwoD/basic" [vert,frag] [3,4] ETriangles + bslista <- makeShader "dualTwoD/basic" [vert,frag] [3,4] ETriangles aslist <- makeShader "dualTwoD/arc" [vert,frag] [3,4,3] ETriangles eslist <- makeShader "dualTwoD/ellipse" [vert,geom,frag] [3,4] ETriangles bezierQuadShader <- makeShader "dualTwoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip @@ -151,6 +152,7 @@ preloadRender = do return $ RenderData { _pictureShaders = shadV + , _shapeShader = bslista , _lightingCapShader = lightingCapShad , _lightingLineShadowShader = lightingLineShadowShad , _lightingOccludeShader = wsShad {_shadVAO = wpVAO} @@ -171,7 +173,6 @@ preloadRender = do , _fboHalf3 = fboHalf3Name , _fboLighting = fboLightingName , _fboLightingHigh = fboLightingHighName - --, _rboLighting = rboLightingName , _fboBase = fboBaseName , _fboCloud = fboCloudName , _fboBloom = fboBloomName diff --git a/src/Shader/Bind.hs b/src/Shader/Bind.hs index 403cf9dd4..500599cf5 100644 --- a/src/Shader/Bind.hs +++ b/src/Shader/Bind.hs @@ -16,6 +16,7 @@ import Control.Monad.Primitive import Control.Monad bindArrayBuffers :: Int -> VBO -> IO () +{-# INLINABLE bindArrayBuffers #-} bindArrayBuffers numVs theVBO = do bindBuffer ArrayBuffer $= Just (_vbo theVBO) bufferSubData diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index dda68c132..b8f6ebc7c 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -7,10 +7,13 @@ module Shader.Poke , pokePoint3s , pokePoint33s , poke224s + , pokeShape + , pokeShapeVs ) where import Shader.Data import Shader.Parameters import Picture.Data +import Shape.Data import Geometry.Data import Foreign @@ -37,6 +40,40 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the where sn = _unShadNum theShadNum +pokeShape :: Ptr Float -> Ptr Float -> Shape -> IO (Int,Int) +pokeShape vptr eptr sh = do + nVs <- pokeShapeVs vptr (_shVertices sh) + nEs <- pokeShapeEs eptr (_shEdges sh) + return (nVs,nEs) + +pokeShapeVs :: Ptr Float -> [ShapeV] -> IO Int +pokeShapeVs ptr vals0 = go vals0 0 + where + go [] n = return n + go ( sh:vals) !n = 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 + go vals (n+1) + where + off i = n*7 + i + V3 a b c = _svPos sh + V4 d e f g = _svCol sh + +pokeShapeEs :: Ptr Float -> [Point3] -> IO Int +pokeShapeEs ptr vals0 = go vals0 0 + where + go [] n = return n + go ((V3 a b c) :vals) !n = do + pokeElemOff ptr (n * 3) a + pokeElemOff ptr (n * 3 + 1) b + pokeElemOff ptr (n * 3 + 2) c + go vals (n+1) + pokeLayVerxs :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int diff --git a/src/Shape.hs b/src/Shape.hs new file mode 100644 index 000000000..6ec9b77b7 --- /dev/null +++ b/src/Shape.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} +module Shape + ( module Shape.Data + , module Shape + ) + where +import Geometry +--import Geometry.Vector3D +import Shape.Data +import Color + +empty :: Shape +{-# INLINE empty #-} +empty = Shape [] [] + +flatPoly :: [Point2] -> Shape +flatPoly ps = Shape + { _shVertices = polyToTris $ map f ps + , _shEdges = concat $ zipWith g ps (tail ps ++ [head ps]) + } + where + f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black } + g (V2 x y) (V2 a b) = + [ V3 x y 0 + , V3 a b 0 + , V3 x y (-1) + , V3 a b 1 + ] + +colorSh :: Color -> Shape -> Shape +colorSh col = overCol $ const col + +overCol :: (Point4 -> Point4) -> Shape -> Shape +overCol f Shape{_shVertices=vs,_shEdges=es} = Shape + {_shVertices = map (overColVertex f) vs + ,_shEdges = es + } + +overPos :: (Point3 -> Point3) -> Shape -> Shape +overPos f Shape{_shVertices=vs,_shEdges=es} = Shape + {_shVertices = map (overPosVertex f) vs + ,_shEdges = map f es + } + +translateSh :: Point3 -> Shape -> Shape +translateSh !p = overPos (+p) + +scale :: Point3 -> Shape -> Shape +scale !p = overPos (*p) + +overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV +overColVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV + {_svPos = pos + ,_svCol = f col + } + +overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV +overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV + {_svPos = f pos + ,_svCol = col + } + diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs new file mode 100644 index 000000000..bd99d0397 --- /dev/null +++ b/src/Shape/Data.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +module Shape.Data + where +import Geometry.Data +import Control.Lens +data Shape = Shape + { _shVertices :: [ShapeV] + , _shEdges :: [Point3] + } +-- edges are given by four consecutive points +data ShapeV = ShapeV + { _svPos :: Point3 + , _svCol :: Point4 + } +makeLenses ''ShapeV +makeLenses ''Shape