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

Fix arc rendering, allowing them to rotate

Browse Source
This commit is contained in:
jgk
2021-03-02 20:15:32 +01:00
parent 81f5385710
commit 8ed8c48ffe
5 changed files with 22 additions and 13 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Picture/Data.hs
+1 -1
View File
@@ -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
+11 -5
View File
@@ -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