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

First implementation of quadratic bezier curve shader

Browse Source
This commit is contained in:
justin
2021-03-12 15:25:07 +01:00
parent 6f1f817ed3
commit 0489a092bc
21 changed files with 372 additions and 37 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Item/Weapon.hs
+23
View File
@@ -335,6 +335,11 @@ launcher = defaultGun
, _itHammer = NoHammer
, _itEffect = NoItEffect
}
bezierGun = defaultGun
{ _itName = "B-GUN"
, _wpFire = bezierTarget
}
remoteLauncher = defaultGun
{ _itName = "ROCKO-REM"
, _itIdentity = RemoteLauncher
@@ -1402,6 +1407,24 @@ grenadePic x = pictures [ color (dark $ dark green) $ circleSolid 5
$ scale 0.05 0.05 $ color green $ text $ show $ 1 + quot x 20
]
bezierTarget :: Int -> World -> World
bezierTarget cid w = setTarget w
where
j = _crInvSel $ _creatures w IM.! cid
setTarget = set (creatures . ix cid . crInv . ix j . wpFire) $ bezierControl p
p = mouseWorldPos w
bezierControl :: Point2 -> Int -> World -> World
bezierControl targetp cid w = shootWithSound 0 (mkBezierBul startp controlp targetp) cid w
where
controlp = mouseWorldPos w
cr = _creatures w IM.! cid
dir = _crDir cr
startp = _crPos cr +.+ rotateV dir (_crRad cr + 1,0)
mkBezierBul :: Point2 -> Point2 -> Point2 -> Int -> World -> World
mkBezierBul startp controlp targetp cid w = w
fireRemoteLauncher :: Int -> World -> World
fireRemoteLauncher cid w = setLocation $ resetFire $ resetName
$ soundOnce (fromIntegral launcherSound)
src/Dodge/Rendering.hs
+6 -2
View File
@@ -75,6 +75,7 @@ worldPictures w
-- , itLabels
, ppLabels
, btLabels
, testPic w
]
where
decPicts = IM.elems $ _decorations w
@@ -119,6 +120,11 @@ worldPictures w
]
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
testPic :: World -> [Picture]
testPic w = [setLayer 1 $ onLayerL [99] $ color red $ bezierQuad (-90,0) (90,-50) (-200,200) ]
-- $ uncurry translate (mouseWorldPos w)
hudDrawings :: World -> Picture
hudDrawings w = setLayer 1 $ (onLayer InvLayer)
$ pictures
@@ -463,8 +469,6 @@ displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
scale 0.2 0.2 $ text $ reverse $ take 5 $ (++ repeat ' ') $ reverse $ show
$ _crHP $ _creatures w IM.! n
testPic w = blank
wallsForGloom :: World -> [(Point2,Point2,Point2,Point2)]
wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
$ filter wallCastsShadow
src/Picture.hs
+4
View File
@@ -4,6 +4,7 @@ module Picture
( module Picture.Data
, polygon
, polygonCol
, bezierQuad
, arc
, arcSolid
, thickArc
@@ -68,6 +69,9 @@ polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = PolygonCol 0
bezierQuad :: Point2 -> Point2 -> Point2 -> Picture
bezierQuad a b c = BezierQuad 0 [a,b,c]
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c pic = OverPic id id 0 (const c) pic
src/Picture/Data.hs
+2
View File
@@ -22,6 +22,7 @@ import Data.Traversable
data RenderType
= RenderPoly [(Point3,Point4)]
| RenderBezQ [(Point3,Point4)]
| RenderText [(Point3,Point4,Point3)]
| RenderArc (Point3,Point4,Point4)
| RenderLine [(Point3,Point4)]
@@ -74,6 +75,7 @@ data Picture
= Blank
| Text Int String
| Polygon Int [Point2]
| BezierQuad Int [Point2]
| PolygonCol Int [(Point2,RGBA)]
| Circle Int RGBA RGBA Float
| ThickArc Int Float Float Float Float
src/Picture/Preload.hs
+10 -1
View File
@@ -49,6 +49,9 @@ preloadRender = do
[(0,3),(1,4),(2,3)] Points pokeCharStrat
"data/texture/charMap.png"
bezierQuadShader
<- makeShader "bezierQuad" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeBezQStrat
--the following vbo is set up to contain one fixed vertex
dummyvbo <- genObjectName
dummyptr <- mallocArray numDrawableElements
@@ -61,7 +64,7 @@ preloadRender = do
backgroundvao <- setupVAO [(0,4),(1,2)]
return $ RenderData
{ _listShaders = [bslist,lslist,cslist,aslist,eslist]
{ _listShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
, _dummyVBO = dummyvbo
, _dummyPtr = dummyptr
, _lightSourceShader = lsShad
@@ -79,7 +82,13 @@ cleanUpRenderPreload pd = do
freeShaderPointers $ _backgroundShader pd
free $ _dummyPtr pd
{-# INLINE pokeBezQStrat #-}
pokeBezQStrat :: RenderType -> [[[Float]]]
pokeBezQStrat (RenderBezQ vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeBezQStrat _ = []
{-# INLINE pokeTriStrat #-}
pokeTriStrat :: RenderType -> [[[Float]]]
pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeTriStrat _ = []
src/Picture/Tree.hs
+8 -34
View File
@@ -8,13 +8,17 @@ import Geometry
import Data.Bifunctor
import Data.List
-- todo: refactor out the layer check somehow
-- consider generalising to alternative rather than using LTree
picToLTree :: Maybe Int -> Picture -> LTree RenderType
{-# INLINE picToLTree #-}
picToLTree mx (Polygon i ps)
= filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToLTree mx (PolygonCol i vs) =
filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToLTree mx (PolygonCol i vs)
= filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
where (ps,cs) = unzip vs
picToLTree mx (BezierQuad i ps)
= filtB mx i $ LLeaf $ RenderBezQ $ zip (map zeroZ $ ps) $ repeat black
picToLTree mx (Circle i colC colE r)
= filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC)
,( (-r,-r,0), colE)
@@ -64,6 +68,7 @@ scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
{-# INLINE overPos #-}
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
overPos f (RenderBezQ vs) = RenderBezQ $ map (first $ f) vs
overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
@@ -77,6 +82,7 @@ overRot _ ren = ren
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
{-# INLINE overCol #-}
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
overCol f (RenderBezQ vs) = RenderBezQ $ map (second $ f) vs
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
overCol f (RenderEllipse vs) = RenderEllipse $ map (second $ f) vs
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
@@ -112,35 +118,3 @@ rotate3 :: Float -> Point3 -> Point3
rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y)
--picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
--{-# INLINE picToAlt #-}
--picToAlt x (Polygon i ps)
-- | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-- | otherwise = Ap.empty
--picToAlt x (PolygonCol i vs)
-- | i /= x = Ap.empty
-- | otherwise =
-- let (ps,cs) = unzip vs
-- in Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
--picToAlt x (Circle i r)
-- | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
-- | otherwise = Ap.empty
--picToAlt x (Ellipse i (ax,ay) (bx,by) r)
-- | i == x = Ap.pure $ RenderEllipse [((ax,ay+r,0),black)
-- ,((ax,ay-r,0),black)
-- ,((bx,by-r,0),black)
-- ]
-- | otherwise = Ap.empty
--picToAlt x (ThickArc i startA endA rad wdth)
-- | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
-- | otherwise = Ap.empty
--picToAlt x (Line i ps)
-- | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-- | otherwise = Ap.empty
--picToAlt x (Text i s)
-- | i == x = Ap.pure $ RenderText $ stringToList s
-- | otherwise = Ap.empty
--picToAlt j Blank = Ap.empty
--picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics