Reimplement text rendering
This commit is contained in:
+93
-19
@@ -57,24 +57,90 @@ stateBump xs _ = do
|
||||
redT :: Foldable t => t () -> [Int]
|
||||
redT x = evalState (foldM stateBump [] x) 0
|
||||
|
||||
picToFTree :: Picture -> FTree [(Point3,Point4)]
|
||||
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)
|
||||
scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
|
||||
|
||||
scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
|
||||
scaleRen x y (RenderPoly xs) = RenderPoly $ map (first $ scale3 x y) xs
|
||||
scaleRen x y (RenderText xs) = RenderText $ map (tripFirst (scale3 x y ) . scaleT x) xs
|
||||
--scaleRen x y (RenderText xs) = RenderText $ map (\(a,b,c) -> (a,b, (0,0.2))) xs
|
||||
scaleRen x y rt = rt
|
||||
translateRen x y (RenderPoly xs) = RenderPoly $ map (first $ translate3 x y) xs
|
||||
translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ translate3 x y) xs
|
||||
--translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ const (0.2,0.2,0)) xs
|
||||
translateRen x y rt = rt
|
||||
rotateRen,setDepthRen :: Float -> RenderType -> RenderType
|
||||
rotateRen a (RenderPoly xs) = RenderPoly $ map (first $ rotate3 a) xs
|
||||
rotateRen a (RenderText xs) = RenderText $ map (tripFirst $ rotate3 a) xs
|
||||
rotateRen a rt = rt
|
||||
setDepthRen a (RenderPoly xs) = RenderPoly $ map (first $ (\(x,y,_) -> (x,y,a))) xs
|
||||
setDepthRen a (RenderText xs) = RenderText $ map (tripFirst $ (\(x,y,_) -> (x,y,a))) xs
|
||||
setDepthRen a rt = rt
|
||||
colorRen :: RGBA -> RenderType -> RenderType
|
||||
colorRen c (RenderPoly xs) = RenderPoly $ map (second $ const c) xs
|
||||
colorRen c (RenderText xs) = RenderText $ map (tripSecond $ const c) xs
|
||||
colorRen c rt = rt
|
||||
|
||||
stringToList :: String -> [(Point3,Point4,Point2)]
|
||||
stringToList s = zipWith (\x (a,b,c) -> (translate3 x (0-dimText) a,b,c))
|
||||
[0,0.9*dimText..]
|
||||
$ map charToTuple s
|
||||
where dimText = 100
|
||||
|
||||
charToTuple :: Char -> (Point3,Point4,Point2)
|
||||
charToTuple c = ((0,0,0),white,(offset,100))
|
||||
where offset = fromIntegral (fromEnum c) - 32
|
||||
|
||||
picToFTree :: Picture -> FTree RenderType
|
||||
{-# INLINE picToFTree #-}
|
||||
picToFTree (Polygon ps) = FLeaf $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
picToFTree Blank = FLeaf $ []
|
||||
picToFTree (Text _) = FLeaf $ []
|
||||
picToFTree (Scale x y pic) = FBranch (map $ first $ scale3 x y) $ picToFTree pic
|
||||
picToFTree (Translate x y pic) = FBranch (map $ first $ translate3 x y) $ picToFTree pic
|
||||
picToFTree (Rotate a pic) = FBranch (map $ first $ rotate3 a) $ picToFTree pic
|
||||
picToFTree (SetDepth a pic) = FBranch (map $ first $ (\(x,y,_) -> (x,y,a))) $ picToFTree pic
|
||||
picToFTree (Color c pic) = FBranch (map $ second $ const c) $ picToFTree pic
|
||||
picToFTree (Polygon ps) = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
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
|
||||
|
||||
pokePic :: Ptr Float -> Ptr Float -> FTree [(Point3,Point4)] -> IO Int
|
||||
pokeTexts :: Ptr Float -> Ptr Float -> Ptr Float -> FTree RenderType -> IO Int
|
||||
pokeTexts = go 0
|
||||
where go n pa pb pc t = foldM (pokeText pa pb pc) n t
|
||||
|
||||
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 ((x,y,z),(r,g,b,a),(s,t))
|
||||
| n > 20000 * 2 = return n
|
||||
| otherwise = do
|
||||
pokeElemOff pa (3*n+0) x
|
||||
pokeElemOff pa (3*n+1) y
|
||||
pokeElemOff pa (3*n+2) z
|
||||
pokeElemOff pb (4*n+0) r
|
||||
pokeElemOff pb (4*n+1) g
|
||||
pokeElemOff pb (4*n+2) b
|
||||
pokeElemOff pb (4*n+3) a
|
||||
pokeElemOff pc (2*n+0) s
|
||||
pokeElemOff pc (2*n+1) 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 -> [(Point3,Point4)] -> IO Int
|
||||
pokePoly pa pb n vs = foldM (pokeVert pa pb) n vs
|
||||
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 ((x,y,z),(r,g,b,a))
|
||||
@@ -129,21 +195,29 @@ rotate3 a (x,y,z) = (x',y',z)
|
||||
|
||||
renderPicture' :: PreloadData -> Picture -> IO ()
|
||||
renderPicture' pdata pic = do
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let firstIndex = 0
|
||||
fSize = sizeOf (0::Float)
|
||||
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
numVert <- pokePic (_ptrPosVBO pdata) (_ptrColVBO pdata) $ picToFTree pic
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 3, _ptrPosVBO pdata, StreamDraw)
|
||||
-- marshallVs vertices $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 4, _ptrColVBO pdata, StreamDraw)
|
||||
-- marshallVs colVs $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVert)
|
||||
|
||||
currentProgram $= Just (_textShader pdata)
|
||||
numVert' <- pokeTexts (_ptrPosVBO pdata) (_ptrColVBO pdata) (_ptrTexVBO pdata) $ picToFTree pic
|
||||
bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *3, _ptrPosVBO pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *4, _ptrColVBO pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *2, _ptrTexVBO pdata, StreamDraw)
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVert')
|
||||
|
||||
renderPicture :: PreloadData -> Picture -> IO ()
|
||||
renderPicture pdata pic = do
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
|
||||
Reference in New Issue
Block a user