From e2c35b21bc05c2fae6780962ecc181f6a2ac89f6 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 10 Mar 2021 22:45:43 +0100 Subject: [PATCH] Refactor picture rendering code --- src/Picture/Data.hs | 38 +----- src/Picture/Preload.hs | 9 +- src/Picture/Render.hs | 255 ++--------------------------------------- src/Picture/Tree.hs | 140 ++++++++++++++++++++++ 4 files changed, 153 insertions(+), 289 deletions(-) create mode 100644 src/Picture/Tree.hs diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index aa287b47a..7fd4ea1f5 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -2,7 +2,7 @@ --{-# LANGUAGE Strict #-} module Picture.Data where -import Shader.Data + import Data.Monoid import qualified Data.Foldable as F import qualified Data.Sequence as Se @@ -12,11 +12,9 @@ import Geometry.Data import Control.Lens -import Foreign +--import Foreign -import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth) - -import qualified Control.Foldl as F +--import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth) import Control.Monad @@ -29,34 +27,6 @@ data RenderType | RenderLine [(Point3,Point4)] | RenderEllipse [(Point3,Point4)] -pokeShaders :: [FullShader RenderType] -> F.FoldM IO RenderType [Int] -pokeShaders fss = traverse pokeShader fss - -pokeShader :: FullShader RenderType -> F.FoldM IO RenderType Int -pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return - where vao = _shaderVAO fs - (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao - fls = _shaderPokeStrategy fs - -pokeRender :: (RenderType -> [[[Float]]]) - -> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int -pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt) - -pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int -pokeList ptrs n fsss = foldM (pokePtrs ptrs) n fsss - -pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int -pokePtrs ptrIs n fss = do - zipWithM_ f ptrIs fss - return $ n + 1 - where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs - -pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO () -pokeArrayOff ptr i xs = - zipWithM_ (pokeElemOff ptr) [i..] xs - - - type RGBA = (Float,Float,Float,Float) type Color = (Float,Float,Float,Float) @@ -93,7 +63,6 @@ instance Functor (RTree a) where fmap f (RBranches i ts) = RBranches i $ (fmap (fmap f)) ts fmap f (RLeaf x) = RLeaf (f x) - flat2 (x,y) = [x,y] flat3 (x,y,z) = [x,y,z] flat4 (x,y,z,w) = [x,y,z,w] @@ -114,7 +83,6 @@ data Picture | OverPic (Point3 -> Point3) (Point2 -> Point2) Float (Point4 -> Point4) Picture | OnLayer Int Picture - blank :: Picture {-# INLINE blank #-} blank = Blank diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index 34c55fde5..4baec8e53 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -12,15 +12,14 @@ import Codec.Picture import qualified Data.Vector.Storable as V import Control.Lens -import Control.Monad +--import Control.Monad import Foreign import Shader data RenderData = RenderData - { --_charMap :: Image PixelRGBA8 - _textures :: [TextureObject] + { _textures :: [TextureObject] , _backShader :: (Program, [UniformLocation]) , _wallShadowShader :: (Program, [UniformLocation]) , _lightmapCircleShader :: (Program, [UniformLocation]) @@ -35,7 +34,6 @@ data RenderData = RenderData makeLenses ''RenderData - pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs pokeTriStrat _ = [] @@ -103,8 +101,7 @@ preloadRender = do fadevao <- setupVAO [(0,4)] return $ RenderData - { -- _charMap = convertRGBA8 cmap - _textures = [dirttex,dirttex] + { _textures = [dirttex,dirttex] , _listShaders = [bslist,lslist,cslist,aslist,eslist] , _lightmapCircleShader = fcs , _backShader = bgs diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index e472fc0eb..cc266905e 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -1,6 +1,9 @@ --{-# LANGUAGE Strict #-} {-# LANGUAGE DeriveFoldable, StandaloneDeriving #-} module Picture.Render + ( module Picture.Render + , picToLTree + ) where import Shader @@ -18,6 +21,7 @@ import qualified Control.Foldl as F import Data.Bifunctor import Picture.Data +import Picture.Tree import Geometry import Picture.Preload @@ -33,93 +37,14 @@ import qualified Graphics.Rendering.OpenGL as GL import Data.Foldable import Data.List -import qualified Data.Vector.Storable as V +--import qualified Data.Vector.Storable as V import qualified Data.IntMap as IM -import qualified Data.DList as DL +--import qualified Data.DList as DL -import Control.DeepSeq +--import Control.DeepSeq import qualified SDL as SDL -white = (1,1,1,1) -black = (0,0,0,1) - -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,Float) -> (Point3,Point4,Point3) -> (Point3,Point4,Point3) -{-# INLINE scaleT #-} -scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y)) - -overPos :: (Point3 -> Point3) -> RenderType -> RenderType -{-# INLINE overPos #-} -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 (RenderEllipse vs) = RenderEllipse $ map (first f) 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 -overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs -overCol f (RenderEllipse vs) = RenderEllipse $ 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) - -overSca :: (Point2 -> Point2) -> RenderType -> RenderType -{-# INLINE overSca #-} -overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs -overSca f p = p - -scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType -{-# INLINE scaleRen #-} -scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT (x,y)) vs -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 (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 #-} -colorRen :: RGBA -> RenderType -> RenderType -colorRen c = overCol $ const c - -stringToList :: String -> [(Point3,Point4,Point3)] -{-# 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 -dimText :: Float -dimText = 100 - -charToTuple :: Char -> (Point3,Point4,Point3) -{-# INLINE charToTuple #-} -charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText)) - where offset = fromIntegral (fromEnum c) - 32 --picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType --{-# INLINE picToAlt #-} @@ -152,103 +77,6 @@ charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText)) --picToAlt j Blank = Ap.empty --picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics -collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType -collapseBranch f (FBranch g t) = FBranch (f . g) t -collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts -collapseBranch f (FLeaf x) = FLeaf (f x) - -filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType -{-# INLINE filtB #-} -filtB mx i t | Just i == mx || Nothing == mx = t - | otherwise = LBranches [] - -picToLTree :: Maybe Int -> Picture -> LTree RenderType -{-# INLINE picToLTree #-} -picToLTree mx (Polygon i ps) - = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black -picToLTree mx (PolygonCol i vs) = - filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs - where (ps,cs) = unzip vs -picToLTree mx (Circle i colC colE r) - = filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC) - ,( (-r,-r,0), colE) - ,( ( r,-r,0), black) - ] -picToLTree mx (ThickArc i startA endA rad wdth) - = filtB mx i $ LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth)) -picToLTree mx (Line i ps) - = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white -picToLTree mx (LineCol i vs) - = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs - where (ps,cs) = unzip vs -picToLTree mx (Text i s) - = filtB mx i $ LLeaf $ RenderText $ stringToList s -picToLTree j Blank = LBranches [] -picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics -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 - -doubleLine :: [a] -> [a] -{-# INLINE doubleLine #-} -doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs) -doubleLine _ = [] - -theFold :: TwoPtrs - -> ThreePtrs - -> ThreePtrs - -> TwoPtrs - -> ThreePtrs - -> TwoPtrs - -> F.FoldM IO RenderType (Int,Int,Int,Int,Int,Int) -theFold pas pbs pcs pds pes pfs - = (,,,,,) <$> pokeTwoPtrsWith pokePoly pas - <*> pokeThreePtrsWith pokeText pbs - <*> pokeThreePtrsWith pokeCirc pcs - <*> pokeTwoPtrsWith pokeLine pds - <*> pokeThreePtrsWith pokeArc pes - <*> pokeTwoPtrsWith pokeEllipse pfs - -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 -{-# INLINE pokeThreePtrsWith #-} -pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return -pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int) - -> TwoPtrs -> F.FoldM IO RenderType Int -{-# INLINE pokeTwoPtrsWith #-} -pokeTwoPtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return - -pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int -{-# INLINE pokeArc #-} -pokeArc (pa,pb,pc) n (RenderArc (p,c,s)) - | n > 20000 * 2 = return n - | otherwise = do - pokeThreeOff pa n p - pokeFourOff pb n c - pokeFourOff pc n s - return $ n + 1 -pokeArc _ n _ = return n - -pokeEllipse:: TwoPtrs -> Int -> RenderType -> IO Int -{-# INLINE pokeEllipse #-} -pokeEllipse ptrs n (RenderEllipse vs) = foldM (pokeEllipseVert ptrs) n vs -pokeEllipse _ n _ = return n - -pokeEllipseVert :: TwoPtrs -> Int -> (Point3,Point4) -> IO Int -{-# INLINE pokeEllipseVert #-} -pokeEllipseVert (pa,pb) n (p,c) - | n > 20000 * 2 = return n - | otherwise = do - pokeThreeOff pa n p - pokeFourOff pb n c - return $ n + 1 pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO () {-# INLINE pokeTwoOff #-} @@ -261,7 +89,6 @@ 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 () {-# INLINE pokeFourOff #-} pokeFourOff ptr n (x,y,z,w) = do @@ -270,74 +97,6 @@ pokeFourOff ptr n (x,y,z,w) = do pokeElemOff ptr (4*n+2) z pokeElemOff ptr (4*n+3) w - -pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int -{-# INLINE pokeLine #-} -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 -{-# INLINE pokeLineVert #-} -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 :: ThreePtrs -> Int -> RenderType -> IO Int -{-# INLINE pokeCirc #-} -pokeCirc _ n _ = return n - -pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int -{-# INLINE pokeText #-} -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, Point3) -> IO Int -{-# INLINE pokeTextVert #-} -pokeTextVert pa pb pc n (p,c,t) - | n > 20000 * 2 = return n - | otherwise = do - pokeThreeOff pa n p - pokeFourOff pb n c - pokeThreeOff pc n t - return (n+1) - -pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int -{-# INLINE pokePoly #-} -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 -{-# INLINE pokeVert #-} -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) - -twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float) -{-# INLINE twoPtrsVAO #-} -twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of - (a:b:_) -> (a,b) -threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float) -{-# INLINE threePtrsVAO #-} -threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of - (a:b:c:_) -> (a,b,c) - setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [FullShader RenderType] -> IO () setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do let scalMat = Linear.Matrix.transpose $ diff --git a/src/Picture/Tree.hs b/src/Picture/Tree.hs new file mode 100644 index 000000000..0234f970a --- /dev/null +++ b/src/Picture/Tree.hs @@ -0,0 +1,140 @@ +module Picture.Tree + ( picToLTree + ) + where +import Picture.Data +import Geometry + +import Data.Bifunctor +import Data.List + +picToLTree :: Maybe Int -> Picture -> LTree RenderType +{-# INLINE picToLTree #-} +picToLTree mx (Polygon i ps) + = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black +picToLTree mx (PolygonCol i vs) = + filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs + where (ps,cs) = unzip vs +picToLTree mx (Circle i colC colE r) + = filtB mx i $ LLeaf $ RenderEllipse [( (-r, r,0), colC) + ,( (-r,-r,0), colE) + ,( ( r,-r,0), black) + ] +picToLTree mx (ThickArc i startA endA rad wdth) + = filtB mx i $ LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth)) +picToLTree mx (Line i ps) + = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white +picToLTree mx (LineCol i vs) + = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs + where (ps,cs) = unzip vs +picToLTree mx (Text i s) + = filtB mx i $ LLeaf $ RenderText $ stringToList s +picToLTree j Blank = LBranches [] +picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics +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 + +filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType +{-# INLINE filtB #-} +filtB mx i t | Just i == mx || Nothing == mx = t + | otherwise = LBranches [] + +doubleLine :: [a] -> [a] +{-# INLINE doubleLine #-} +doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs) +doubleLine _ = [] + +white = (1,1,1,1) +black = (0,0,0,1) + +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,Float) -> (Point3,Point4,Point3) -> (Point3,Point4,Point3) +{-# INLINE scaleT #-} +scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y)) + +overPos :: (Point3 -> Point3) -> RenderType -> RenderType +{-# INLINE overPos #-} +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 (RenderEllipse vs) = RenderEllipse $ map (first f) vs +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 +overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs +overCol f (RenderEllipse vs) = RenderEllipse $ map (second $ f) vs +overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs +overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c) + +overSca :: (Point2 -> Point2) -> RenderType -> RenderType +{-# INLINE overSca #-} +overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs +overSca f p = p + +scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType +{-# INLINE scaleRen #-} +scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT (x,y)) vs +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 (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 #-} +colorRen :: RGBA -> RenderType -> RenderType +colorRen c = overCol $ const c + +stringToList :: String -> [(Point3,Point4,Point3)] +{-# 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 +dimText :: Float +dimText = 100 + +charToTuple :: Char -> (Point3,Point4,Point3) +{-# INLINE charToTuple #-} +charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText)) + where offset = fromIntegral (fromEnum c) - 32 + +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) +