Implement arc rendering, works for increasing angle difference < 2pi
This commit is contained in:
+47
-67
@@ -74,13 +74,15 @@ overCol _ RenderBlank = RenderBlank
|
||||
scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
|
||||
{-# INLINE scaleRen #-}
|
||||
scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
|
||||
--scaleRen x y (RenderCirc (a,b,c)) = overPos (scale3 x y) $ RenderCirc (a,b,c)
|
||||
scaleRen x y rt = overPos (scale3 x y) rt
|
||||
{-# INLINE translateRen #-}
|
||||
translateRen x y = overPos $ translate3 x y
|
||||
rotateRen,setDepthRen :: Float -> RenderType -> RenderType
|
||||
{-# INLINE rotateRen #-}
|
||||
rotateRen a = overPos $ rotate3 a
|
||||
rotateRen a (RenderArc (p,c,(as,ae,r,w))) = overPos (rotate3 a) $ RenderArc (p,c,(f as,f ae,r,w))
|
||||
--where f b = normalizeAngle $ a + b
|
||||
where f b = a + b
|
||||
rotateRen a pic = overPos (rotate3 a) pic
|
||||
{-# INLINE setDepthRen #-}
|
||||
setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
|
||||
{-# INLINE colorRen #-}
|
||||
@@ -106,7 +108,7 @@ picToFTree (PolygonCol vs) = let (ps,cs) = unzip vs
|
||||
in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
picToFTree (Circle r) = FLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
picToFTree (ThickArc startA endA rad wdth)
|
||||
= FLeaf $ RenderArc $ ((0,0,0),white,(startA,endA,rad,wdth))
|
||||
= FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
picToFTree Blank = FLeaf $ RenderBlank
|
||||
picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
|
||||
picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic
|
||||
@@ -121,43 +123,38 @@ doubleLine :: [Point2] -> [Point2]
|
||||
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
||||
doubleLine _ = []
|
||||
|
||||
pokeFold :: (Ptr Float, Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeFold (pa,pb) = F.FoldM
|
||||
(pokePoly pa pb)
|
||||
(return 0)
|
||||
return
|
||||
pokeTextFold :: (Ptr Float, Ptr Float,Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeTextFold (pa,pb,pc) = F.FoldM
|
||||
(pokeText pa pb pc)
|
||||
(return 0)
|
||||
return
|
||||
pokeCircFold :: (Ptr Float, Ptr Float,Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeCircFold (pa,pb,pc) = F.FoldM
|
||||
(pokeCirc pa pb pc)
|
||||
(return 0)
|
||||
return
|
||||
|
||||
theFold :: (Ptr Float,Ptr Float)
|
||||
-> (Ptr Float,Ptr Float,Ptr Float)
|
||||
-> (Ptr Float,Ptr Float,Ptr Float)
|
||||
-> (Ptr Float,Ptr Float)
|
||||
-> (Ptr Float,Ptr Float,Ptr Float)
|
||||
theFold :: TwoPtrs
|
||||
-> ThreePtrs
|
||||
-> ThreePtrs
|
||||
-> TwoPtrs
|
||||
-> ThreePtrs
|
||||
-> F.FoldM IO RenderType (Int,Int,Int,Int,Int)
|
||||
theFold pas pbs pcs pds pes
|
||||
= (,,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
|
||||
<*> pokeLineFold pds
|
||||
<*> pokeThreePtrsWith pokeArc pes
|
||||
-- = (,,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
|
||||
= (,,,,) <$> pokeTwoPtrsWith pokePoly pas
|
||||
<*> pokeThreePtrsWith pokeText pbs
|
||||
<*> pokeThreePtrsWith pokeCirc pcs
|
||||
<*> pokeTwoPtrsWith pokeLine pds
|
||||
<*> pokeThreePtrsWith pokeArc pes
|
||||
|
||||
type ThreePtrs = (Ptr Float,Ptr Float,Ptr Float)
|
||||
type TwoPtrs = (Ptr Float,Ptr Float)
|
||||
|
||||
pokeThreePtrsWith :: (ThreePtrs -> Int -> RenderType -> IO Int)
|
||||
-> ThreePtrs -> F.FoldM IO RenderType Int
|
||||
pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
|
||||
pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int)
|
||||
-> TwoPtrs -> F.FoldM IO RenderType Int
|
||||
pokeTwoPtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
|
||||
|
||||
pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
|
||||
pokeArc (pa,pb,pc) n (RenderArc ((x,y,z),(r,g,b,a),(s,t,u,v)))
|
||||
pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
|
||||
| n > 20000 * 2 = return n
|
||||
| otherwise = return n
|
||||
| otherwise = do
|
||||
pokeThreeOff pa n p
|
||||
pokeFourOff pb n c
|
||||
pokeFourOff pc n s
|
||||
return $ n + 1
|
||||
pokeArc _ n _ = return n
|
||||
|
||||
pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
|
||||
@@ -177,14 +174,9 @@ pokeFourOff ptr n (x,y,z,w) = do
|
||||
pokeElemOff ptr (4*n+3) w
|
||||
|
||||
|
||||
pokeLineFold :: (Ptr Float, Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeLineFold (pa,pb) = F.FoldM
|
||||
(pokeLine pa pb)
|
||||
(return 0)
|
||||
return
|
||||
pokeLine :: Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
|
||||
pokeLine pa pb n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
|
||||
pokeLine _ _ n _ = return n
|
||||
pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int
|
||||
pokeLine (pa,pb) n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
|
||||
pokeLine _ n _ = return n
|
||||
|
||||
pokeLineVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
||||
pokeLineVert pa pb n (p,c)
|
||||
@@ -194,22 +186,19 @@ pokeLineVert pa pb n (p,c)
|
||||
pokeFourOff pb n c
|
||||
return (n+1)
|
||||
|
||||
pokeCirc :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
|
||||
pokeCirc pa pb pc n (RenderCirc vs) = pokeCircVert pa pb pc n vs
|
||||
pokeCirc _ _ _ n _ = return n
|
||||
|
||||
pokeCircVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Float) -> IO Int
|
||||
pokeCircVert pa pb pc n (p,c,s)
|
||||
pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
|
||||
pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s))
|
||||
| n > 20000 * 2 = return n
|
||||
| otherwise = do
|
||||
pokeThreeOff pa n p
|
||||
pokeFourOff pb n c
|
||||
pokeElemOff pc n s
|
||||
return (n+1)
|
||||
pokeCirc _ n _ = return n
|
||||
|
||||
pokeText :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
|
||||
pokeText pa pb pc n (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
|
||||
pokeText _ _ _ n _ = return n
|
||||
pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
|
||||
pokeText (pa,pb,pc) n (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
|
||||
pokeText _ n _ = return n
|
||||
|
||||
pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point2) -> IO Int
|
||||
pokeTextVert pa pb pc n (p,c,t)
|
||||
@@ -220,13 +209,9 @@ pokeTextVert pa pb pc n (p,c,t)
|
||||
pokeTwoOff pc n t
|
||||
return (n+1)
|
||||
|
||||
pokePic :: Ptr Float -> Ptr Float -> FTree RenderType -> IO Int
|
||||
pokePic = go 0
|
||||
where go n pa pb t = foldM (pokePoly pa pb) n t
|
||||
|
||||
pokePoly :: Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
|
||||
pokePoly pa pb n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
|
||||
pokePoly _ _ n _ = return n
|
||||
pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
|
||||
pokePoly (pa,pb) n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
|
||||
pokePoly _ n _ = return n
|
||||
|
||||
pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
||||
pokeVert pa pb n (p,c)
|
||||
@@ -255,18 +240,16 @@ bindArrayBuffers numVs ps = do
|
||||
bindBuffer ArrayBuffer $= Just bo
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
|
||||
|
||||
|
||||
renderPicture' :: PreloadData -> Float -> (Float,Float) -> Picture -> IO ()
|
||||
renderPicture' pdata zoom (winx,winy) pic = do
|
||||
let firstIndex = 0
|
||||
numArcVs = 0
|
||||
|
||||
(nTriVs,numVert',numCircVs,nLineVs,nArcVs)
|
||||
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
|
||||
<- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
|
||||
(_ptrCharPos pdata, _ptrCharCol pdata, _ptrCharTex pdata)
|
||||
(_ptrCircPos pdata, _ptrCircCol pdata, _ptrCircSca pdata)
|
||||
(_ptrLinePos pdata, _ptrLineCol pdata)
|
||||
(_ptrArcPos pdata, _ptrArcCol pdata, _ptrArcSca pdata)
|
||||
(_ptrCharPos pdata, _ptrCharCol pdata, _ptrCharTex pdata)
|
||||
(_ptrCircPos pdata, _ptrCircCol pdata, _ptrCircSca pdata)
|
||||
(_ptrLinePos pdata, _ptrLineCol pdata)
|
||||
(_ptrArcPos pdata, _ptrArcCol pdata, _ptrArcSca pdata)
|
||||
) $ picToFTree pic
|
||||
|
||||
depthFunc $= Just Less
|
||||
@@ -299,24 +282,21 @@ renderPicture' pdata zoom (winx,winy) pic = do
|
||||
uniform (_asWinUni pdata) $= Vector2 winx winy
|
||||
uniform (_asZoomUni pdata) $= zoom
|
||||
bindVertexArrayObject $= Just (_arcVAO pdata)
|
||||
bindArrayBuffers numArcVs
|
||||
bindArrayBuffers nArcVs
|
||||
[(_posVBO pdata, _ptrArcPos pdata, 3)
|
||||
,(_colVBO pdata, _ptrArcCol pdata, 4)
|
||||
,(_texVBO pdata, _ptrArcSca pdata, 4)
|
||||
]
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numArcVs)
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nArcVs)
|
||||
-- draw text
|
||||
currentProgram $= Just (_textShader pdata)
|
||||
bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
bindArrayBuffers numVert'
|
||||
bindArrayBuffers nTextVs
|
||||
[(_posVBO pdata, _ptrCharPos pdata, 3)
|
||||
,(_colVBO pdata, _ptrCharCol pdata, 4)
|
||||
,(_texVBO pdata, _ptrCharTex pdata, 2)
|
||||
]
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVert')
|
||||
|
||||
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nTextVs)
|
||||
|
||||
bufferOffset :: Integral a => a -> Ptr b
|
||||
bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
|
||||
|
||||
Reference in New Issue
Block a user