Fix arc rendering, allowing them to rotate

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) 

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
                  )

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 #-}

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
 
 

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