323 lines
12 KiB
Haskell
323 lines
12 KiB
Haskell
--{-# LANGUAGE Strict #-}
|
|
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
|
|
module Picture.Render
|
|
where
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import Control.Monad.Trans.State
|
|
|
|
import qualified Control.Foldl as F
|
|
|
|
import Data.Bifunctor
|
|
|
|
import Picture
|
|
import Geometry
|
|
|
|
import Picture.Preload
|
|
--import Control.Lens
|
|
|
|
import Foreign
|
|
|
|
import Codec.Picture
|
|
|
|
import Graphics.Rendering.OpenGL hiding (Line,get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
import Data.Foldable
|
|
import Data.List
|
|
import qualified Data.Vector.Storable as V
|
|
import qualified Data.DList as DL
|
|
|
|
import Control.DeepSeq
|
|
|
|
concat34 :: (Point3,RGBA) -> [Float]
|
|
concat34 ((x,y,z),(r,g,b,a)) = [x,y,z,r,g,b,a]
|
|
|
|
|
|
toVec2 (x,y) = Vector2 x y
|
|
toVec3 (x,y,z) = Vector3 x y z
|
|
toVec4 (x,y,z,w) = Vector4 x y z w
|
|
|
|
polyToTris :: [s] -> [s]
|
|
{-# INLINE polyToTris #-}
|
|
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
|
|
polyToTris _ = []
|
|
|
|
tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
|
|
{-# INLINE tripFirst #-}
|
|
tripFirst f (x,y,z) = (f x,y,z)
|
|
|
|
tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
|
|
{-# INLINE tripSecond #-}
|
|
tripSecond f (x,y,z) = (x,f y,z)
|
|
|
|
scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
|
|
{-# INLINE scaleT #-}
|
|
scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
|
|
|
|
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
|
|
overPos f (RenderPoly vs) = RenderPoly $ 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 (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
|
|
overPos f (RenderArc (a,b,c)) = RenderArc (f a,b,c)
|
|
overPos _ RenderBlank = RenderBlank
|
|
|
|
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
|
|
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
|
|
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
|
|
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
|
|
overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
|
|
overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
|
|
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
|
|
{-# INLINE setDepthRen #-}
|
|
setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
|
|
{-# INLINE colorRen #-}
|
|
colorRen :: RGBA -> RenderType -> RenderType
|
|
colorRen c = overCol $ const c
|
|
|
|
stringToList :: String -> [(Point3,Point4,Point2)]
|
|
{-# INLINE stringToList #-}
|
|
stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
|
|
[0,0.9*dimText..]
|
|
$ map charToTuple s
|
|
where dimText = 100
|
|
|
|
charToTuple :: Char -> (Point3,Point4,Point2)
|
|
{-# INLINE charToTuple #-}
|
|
charToTuple c = ((0,0,0),white,(offset,100))
|
|
where offset = fromIntegral (fromEnum c) - 32
|
|
|
|
picToFTree :: Picture -> FTree RenderType
|
|
{-# INLINE picToFTree #-}
|
|
picToFTree (Polygon ps) = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
|
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))
|
|
picToFTree Blank = FLeaf $ RenderBlank
|
|
picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
|
|
picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic
|
|
picToFTree (Translate x y pic) = FBranch (translateRen x y) $ picToFTree pic
|
|
picToFTree (Rotate a pic) = FBranch (rotateRen a) $ picToFTree pic
|
|
picToFTree (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree pic
|
|
picToFTree (Color c pic) = FBranch (colorRen c) $ picToFTree pic
|
|
picToFTree (Pictures pics) = FBranches $ map picToFTree pics
|
|
picToFTree (Line ps) = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
|
|
|
|
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)
|
|
-> 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
|
|
|
|
type ThreePtrs = (Ptr Float,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
|
|
|
|
pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
|
|
pokeArc (pa,pb,pc) n (RenderArc ((x,y,z),(r,g,b,a),(s,t,u,v)))
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = return n
|
|
pokeArc _ n _ = return n
|
|
|
|
pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
|
|
pokeTwoOff ptr n (x,y) = do
|
|
pokeElemOff ptr (2*n+0) x
|
|
pokeElemOff ptr (2*n+1) y
|
|
pokeThreeOff :: Ptr Float -> Int -> (Float,Float,Float) -> IO ()
|
|
pokeThreeOff ptr n (x,y,z) = do
|
|
pokeElemOff ptr (3*n+0) x
|
|
pokeElemOff ptr (3*n+1) y
|
|
pokeElemOff ptr (3*n+2) z
|
|
pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
|
|
pokeFourOff ptr n (x,y,z,w) = do
|
|
pokeElemOff ptr (4*n+0) x
|
|
pokeElemOff ptr (4*n+1) y
|
|
pokeElemOff ptr (4*n+2) z
|
|
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
|
|
|
|
pokeLineVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
|
pokeLineVert pa pb n (p,c)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
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)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
pokeElemOff pc n s
|
|
return (n+1)
|
|
|
|
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)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
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
|
|
|
|
pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
|
pokeVert pa pb n (p,c)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
return (n+1)
|
|
|
|
translate3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE translate3 #-}
|
|
translate3 a b (x,y,z) = (x+a,y+b,z)
|
|
scale3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE scale3 #-}
|
|
scale3 a b (x,y,z) = (x*a,y*b,z)
|
|
rotate3 :: Float -> Point3 -> Point3
|
|
{-# INLINE rotate3 #-}
|
|
rotate3 a (x,y,z) = (x',y',z)
|
|
where (x',y') = rotateV a (x,y)
|
|
|
|
fSize = sizeOf (0 :: Float)
|
|
|
|
bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
|
|
bindArrayBuffers numVs ps = do
|
|
forM_ ps $ \(bo,ptr,i) -> 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)
|
|
<- 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)
|
|
) $ picToFTree pic
|
|
|
|
depthFunc $= Just Less
|
|
-- draw triangles
|
|
currentProgram $= Just (_basicShader pdata)
|
|
bindArrayBuffers nTriVs [(_posVBO pdata, _ptrPosVBO pdata, 3)
|
|
,(_colVBO pdata, _ptrColVBO pdata, 4)
|
|
]
|
|
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ nTriVs)
|
|
-- draw lines, don't need to change the program or vaos, just need to bind the
|
|
-- vbos and draw
|
|
bindArrayBuffers nLineVs
|
|
[(_posVBO pdata, _ptrLinePos pdata, 3)
|
|
,(_colVBO pdata, _ptrLineCol pdata, 4)
|
|
]
|
|
drawArrays Lines (fromIntegral firstIndex) (fromIntegral $ nLineVs)
|
|
-- draw circles
|
|
currentProgram $= Just (_circShader pdata)
|
|
uniform (_uniWinSize pdata) $= Vector2 winx winy
|
|
uniform (_csZoomUni pdata) $= zoom
|
|
bindVertexArrayObject $= Just (_circVAO pdata)
|
|
bindArrayBuffers numCircVs
|
|
[(_posVBO pdata, _ptrCircPos pdata, 3)
|
|
,(_colVBO pdata, _ptrCircCol pdata, 4)
|
|
,(_texVBO pdata, _ptrCircSca pdata, 1)
|
|
]
|
|
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numCircVs)
|
|
-- draw arcs
|
|
currentProgram $= Just (_arcShader pdata)
|
|
uniform (_asWinUni pdata) $= Vector2 winx winy
|
|
uniform (_asZoomUni pdata) $= zoom
|
|
bindVertexArrayObject $= Just (_arcVAO pdata)
|
|
bindArrayBuffers numArcVs
|
|
[(_posVBO pdata, _ptrArcPos pdata, 3)
|
|
,(_colVBO pdata, _ptrArcCol pdata, 4)
|
|
,(_texVBO pdata, _ptrArcSca pdata, 4)
|
|
]
|
|
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numArcVs)
|
|
-- draw text
|
|
currentProgram $= Just (_textShader pdata)
|
|
bindVertexArrayObject $= Just (_textVAO pdata)
|
|
bindArrayBuffers numVert'
|
|
[(_posVBO pdata, _ptrCharPos pdata, 3)
|
|
,(_colVBO pdata, _ptrCharCol pdata, 4)
|
|
,(_texVBO pdata, _ptrCharTex pdata, 2)
|
|
]
|
|
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVert')
|
|
|
|
|
|
|
|
bufferOffset :: Integral a => a -> Ptr b
|
|
bufferOffset = plusPtr nullPtr . fromIntegral
|
|
|