justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Define shape datatype

Browse Source
This commit is contained in:
justin
2021-09-14 01:17:07 +01:00
parent 29f048cfdd
commit 294e01479a
18 changed files with 226 additions and 111 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Color.hs
+74
View File
@@ -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)
src/Data/Preload/Render.hs
+1
View File
@@ -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)
src/Dodge/Creature/State/Data.hs
+1 -2
View File
@@ -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
src/Dodge/Data.hs
+1
View File
@@ -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
src/Dodge/Item/Weapon/Bezier.hs
+1 -1
View File
@@ -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
src/Dodge/Item/Weapon/Bullet.hs
+2 -2
View File
@@ -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
}
src/Dodge/LevelGen/Block.hs
+1 -1
View File
@@ -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
src/Dodge/Particle/Bullet/HitEffect.hs
+3 -8
View File
@@ -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'
src/Dodge/Render.hs
+8 -1
View File
@@ -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]
src/Dodge/Render/Shape.hs
+9
View File
@@ -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
src/Picture.hs
+4 -92
View File
@@ -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
src/Picture/Data.hs
+1 -2
View File
@@ -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]
src/Polyhedra/Data.hs
+1 -1
View File
@@ -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.
src/Preload/Render.hs
+2 -1
View File
@@ -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
src/Shader/Bind.hs
+1
View File
@@ -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
src/Shader/Poke.hs
+37
View File
@@ -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
src/Shape.hs
+62
View File
@@ -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
}
src/Shape/Data.hs
+17
View File
@@ -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