Refactor picture rendering code
This commit is contained in:
+3
-35
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+7
-248
@@ -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 $
|
||||
|
||||
@@ -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)
|
||||
|
||||
Reference in New Issue
Block a user