From 8ed8c48ffedc43c648d8c8e770d2f7f84cf73d7d Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 2 Mar 2021 20:15:32 +0100 Subject: [PATCH] Fix arc rendering, allowing them to rotate --- shader/arc.frag | 6 ++++-- src/Loop.hs | 1 + src/Picture.hs | 10 +++++----- src/Picture/Data.hs | 2 +- src/Picture/Render.hs | 16 +++++++++++----- 5 files changed, 22 insertions(+), 13 deletions(-) diff --git a/shader/arc.frag b/shader/arc.frag index 40a42ea5c..d906816a5 100644 --- a/shader/arc.frag +++ b/shader/arc.frag @@ -7,6 +7,8 @@ in vec2 angles; out vec4 fColor; out float gl_FragDepth; +uniform float rotation; + void main() { vec2 pos = gl_FragCoord.xy; @@ -16,10 +18,10 @@ void main() ); vec2 posDiff = pos - cenPosT; - float sa = angles.x; + float sa = angles.x - rotation; vec2 sv = vec2 (-sin(sa), cos(sa)); float saTest = dot(sv,posDiff) >= 0 ? 0 : 1; - float ea = angles.y; + float ea = angles.y - rotation; vec2 ev = vec2 (-sin(ea), cos(ea)); float eaTest = dot(ev,posDiff) <= 0 ? 0 : 1; float aTest = ea - sa < radians(180) ? max (saTest,eaTest) diff --git a/src/Loop.hs b/src/Loop.hs index 65491f2e1..1055c7b29 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -60,6 +60,7 @@ setupLoop wName xSize ySize GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha) GL.clearColor $= GL.Color4 0 0.5 0 1 GL.clearDepth $= (200) + swapInterval $= ImmediateUpdates doLoop setup window startWorld sideEffects eventFn worldFn ) diff --git a/src/Picture.hs b/src/Picture.hs index 427556277..035387d04 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -88,7 +88,7 @@ polygonCol = PolygonCol 0 color :: RGBA -> Picture -> Picture {-# INLINE color #-} -color c pic = OverPic id id (const c) pic +color c pic = OverPic id id 0 (const c) pic translate3 :: Float -> Float -> Point3 -> Point3 {-# INLINE translate3 #-} @@ -96,11 +96,11 @@ translate3 a b (x,y,z) = (x+a,y+b,z) translate :: Float -> Float -> Picture -> Picture {-# INLINE translate #-} -translate x y pic = OverPic (translate3 x y) id id pic +translate x y pic = OverPic (translate3 x y) id 0 id pic setDepth :: Float -> Picture -> Picture {-# INLINE setDepth #-} -setDepth d pic = OverPic (\(x,y,_) -> (x,y,-d)) id id pic +setDepth d pic = OverPic (\(x,y,_) -> (x,y,-d)) id 0 id pic setLayer :: Int -> Picture -> Picture {-# INLINE setLayer #-} @@ -112,7 +112,7 @@ scale3 a b (x,y,z) = (x*a,y*b,z) scale :: Float -> Float -> Picture -> Picture {-# INLINE scale #-} -scale x y pic = OverPic (scale3 x y) ((*) x) id pic +scale x y pic = OverPic (scale3 x y) ((*) x) 0 id pic rotate3 :: Float -> Point3 -> Point3 {-# INLINE rotate3 #-} @@ -121,7 +121,7 @@ rotate3 a (x,y,z) = (x',y',z) rotate :: Float -> Picture -> Picture {-# INLINE rotate #-} -rotate a pic = OverPic (rotate3 a) id id pic +rotate a pic = OverPic (rotate3 a) id a id pic --rotateRad a = Rotate a --{-# INLINE rotateRad #-} diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index e460afe62..028e5214a 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -71,7 +71,7 @@ data Picture | ThickArc Int Float Float Float Float | Line Int [Point2] | Pictures [Picture] - | OverPic (Point3 -> Point3) (Float -> Float) (Point4 -> Point4) Picture + | OverPic (Point3 -> Point3) (Float -> Float) Float (Point4 -> Point4) Picture | OnLayer Int Picture diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 6435a4748..5330dceba 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -69,6 +69,11 @@ overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c) overPos f (RenderArc (a,b,c)) = RenderArc (f a,b,c) +overRot :: Float -> RenderType -> RenderType +{-# INLINE overRot #-} +overRot ang (RenderArc (a,b,(r,s,t,v))) = RenderArc (a,b,(r+ang,s+ang,t,v)) +overRot _ ren = ren + overCol :: (Point4 -> Point4) -> RenderType -> RenderType {-# INLINE overCol #-} overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs @@ -222,9 +227,10 @@ picToLTree mx (Text i s) | otherwise = LBranches [] picToLTree j Blank = LBranches [] picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics -picToLTree j (OverPic f f' f'' (OverPic g g' g'' pic)) = picToLTree j $ OverPic (f . g) (f' . g') (f'' . g'') pic -picToLTree j (OverPic f f' f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' f'') ps) -picToLTree j (OverPic f f' f'' pic) = fmap (overPos f . overSca f' . overCol f'') $ picToLTree j pic +picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic)) + = picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic +picToLTree j (OverPic f f' r f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' r f'') ps) +picToLTree j (OverPic f f' r f'' pic) = fmap (overPos f . overSca f' . overRot r . overCol f'') $ picToLTree j pic picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic | otherwise = LBranches [] picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic @@ -433,7 +439,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata forM_ lightPoints $ \(x,y,r,lum) -> do --- cullFace $= Just Front + cullFace $= Just Front clear [DepthBuffer] currentProgram $= Just (fst $ _wallShadowShader pdata) bindVertexArrayObject $= Just (_vao $ _wallVAO pdata) @@ -444,7 +450,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p ---- --drawElements Points (fromIntegral nWalls) UnsignedByte ptr -- glDrawElements GL_POINTS (fromIntegral $ length wallPoints) GL_UNSIGNED_BYTE ptr drawArrays Points (fromIntegral 0) (fromIntegral $ nWalls) --- cullFace $= Nothing + cullFace $= Nothing currentProgram $= Just (fst $ _fadeCircleShader pdata) bindVertexArrayObject $= Just (_vao $ _fadeCircVAO pdata) let fadeCircPtr = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _fadeCircVAO pdata