Make pictures directly create render list
This commit is contained in:
+2
-2
@@ -63,9 +63,9 @@ main = do
|
||||
(lightsForGloom' w)
|
||||
(worldPictures w)
|
||||
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
renderTree (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
|
||||
renderTree 1 (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
|
||||
(_windowX w,_windowY w)
|
||||
(picToLTree 1 $ fixedCoordPictures w)
|
||||
(fixedCoordPictures w)
|
||||
endRenderTicks <- SDL.ticks
|
||||
playSoundQueue (_soundData preData) (_soundQueue w)
|
||||
newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
|
||||
|
||||
+80
-44
@@ -49,46 +49,35 @@ import Geometry.Data
|
||||
import Picture.Data
|
||||
|
||||
import Data.Bifunctor
|
||||
import Data.List
|
||||
import qualified Data.DList as DL
|
||||
|
||||
import Graphics.Rendering.OpenGL (lineWidth, ($=))
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
black :: RGBA
|
||||
black = (0,0,0,1)
|
||||
|
||||
--polygonD :: Float -> [Point2] -> Picture
|
||||
--{-# INLINE polygonD #-}
|
||||
--polygonD d (a:b:c:ps) = blank
|
||||
-- { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
|
||||
-- , _scColTri = mapVC (const black) tris
|
||||
-- }
|
||||
-- where twoPs = zip (b:c:ps) (c:ps)
|
||||
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
|
||||
--polygonD _ _ = blank
|
||||
|
||||
polygon :: [Point2] -> Picture
|
||||
{-# INLINE polygon #-}
|
||||
polygon = Polygon 0
|
||||
polygon ps = pure $ (,) 0 $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
|
||||
polygonCol :: [(Point2,RGBA)] -> Picture
|
||||
{-# INLINE polygonCol #-}
|
||||
polygonCol = PolygonCol 0
|
||||
polygonCol ls = pure $ (,) 0 $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
where (ps,cs) = unzip ls
|
||||
|
||||
--polygon :: [Point2] -> Picture
|
||||
--{-# INLINE polygon #-}
|
||||
--polygon (a:b:c:ps) = NLeaf $ emptyScene
|
||||
-- { _scPosTri = fmap zeroZ tris
|
||||
-- , _scColTri = fmap (const black) tris
|
||||
-- }
|
||||
-- where twoPs = zip (b:c:ps) (c:ps)
|
||||
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
|
||||
--polygon _ = blank
|
||||
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 _ = []
|
||||
|
||||
color :: RGBA -> Picture -> Picture
|
||||
{-# INLINE color #-}
|
||||
color c pic = Color c pic
|
||||
color c pic = fmap (second $ colorRen c) pic
|
||||
|
||||
translate3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE translate3 #-}
|
||||
@@ -96,26 +85,14 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
|
||||
|
||||
translate :: Float -> Float -> Picture -> Picture
|
||||
{-# INLINE translate #-}
|
||||
translate x y pic = Translate x y pic
|
||||
translate x y pic = fmap (second $ translateRen x y) pic
|
||||
|
||||
setDepth :: Float -> Picture -> Picture
|
||||
{-# INLINE setDepth #-}
|
||||
setDepth d pic = SetDepth d pic
|
||||
setDepth d pic = fmap (second $ setDepthRen d) pic
|
||||
|
||||
setLayer :: Int -> Picture -> Picture
|
||||
setLayer _ Blank = Blank
|
||||
setLayer i (Polygon _ ps) = Polygon i ps
|
||||
setLayer i (PolygonCol _ ps) = PolygonCol i ps
|
||||
setLayer i (Circle _ x) = Circle i x
|
||||
setLayer i (ThickArc _ a b r w) = ThickArc i a b r w
|
||||
setLayer i (Line _ x) = Line i x
|
||||
setLayer i (Scale x y p) = Scale x y $ setLayer i p
|
||||
setLayer i (Translate x y p) = Translate x y $ setLayer i p
|
||||
setLayer i (Rotate x p) = Rotate x $ setLayer i p
|
||||
setLayer i (SetDepth x p) = SetDepth x $ setLayer i p
|
||||
setLayer i (Color x p) = Color x $ setLayer i p
|
||||
setLayer i (Pictures p) = Pictures $ map (setLayer i) p
|
||||
|
||||
setLayer i pic = fmap (first $ const i) pic
|
||||
|
||||
scale3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE scale3 #-}
|
||||
@@ -123,22 +100,23 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
|
||||
|
||||
scale :: Float -> Float -> Picture -> Picture
|
||||
{-# INLINE scale #-}
|
||||
scale x y pic = Scale x y pic
|
||||
scale x y pic = fmap (second $ scaleRen x y) pic
|
||||
|
||||
rotate3 :: Float -> Point3 -> Point3
|
||||
{-# INLINE rotate3 #-}
|
||||
rotate3 a (x,y,z) = (x',y',z)
|
||||
where (x',y') = rotateV a (x,y)
|
||||
|
||||
rotate = Rotate
|
||||
rotate :: Float -> Picture -> Picture
|
||||
{-# INLINE rotate #-}
|
||||
rotate a pic = fmap (second $ rotateRen a) pic
|
||||
|
||||
--rotateRad a = Rotate a
|
||||
--{-# INLINE rotateRad #-}
|
||||
|
||||
pictures :: [Picture] -> Picture
|
||||
{-# INLINE pictures #-}
|
||||
pictures = Pictures
|
||||
pictures = mconcat
|
||||
|
||||
|
||||
makeArc :: Float -> (Float,Float) -> [Point2]
|
||||
@@ -150,7 +128,7 @@ makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
|
||||
circleSolid :: Float -> Picture
|
||||
{-# INLINE circleSolid #-}
|
||||
--circleSolid rad = polygon $ makeArc rad (0,2*pi)
|
||||
circleSolid = Circle 0
|
||||
circleSolid r = pure $ (,) 0 $ RenderCirc $ ((0,0,0),black,r)
|
||||
|
||||
circle :: Float -> Picture
|
||||
{-# INLINE circle #-}
|
||||
@@ -158,11 +136,27 @@ circle rad = thickArc 0 (2*pi) rad 1
|
||||
|
||||
text :: String -> Picture
|
||||
{-# INLINE text #-}
|
||||
text = Text 1
|
||||
text s = pure $ (,) 1 $ RenderText $ stringToList s
|
||||
|
||||
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
|
||||
|
||||
line :: [Point2] -> Picture
|
||||
{-# INLINE line #-}
|
||||
line = Line 0
|
||||
line ps = pure $ (,) 0 $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
|
||||
doubleLine :: [Point2] -> [Point2]
|
||||
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
||||
doubleLine _ = []
|
||||
|
||||
thickLine :: [Point2] -> Float -> Picture
|
||||
{-# INLINE thickLine #-}
|
||||
@@ -189,7 +183,7 @@ arc startA endA rad = thickArc startA endA rad 1
|
||||
|
||||
thickArc :: Float -> Float -> Float -> Float -> Picture
|
||||
{-# INLINE thickArc #-}
|
||||
thickArc = ThickArc 0
|
||||
thickArc startA endA rad wdth = pure $ (,) 0 $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
--thickArc startA endA rad wdth
|
||||
-- = thickLine (makeArc rad (startA,endA)) wdth
|
||||
|
||||
@@ -234,3 +228,45 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
|
||||
|
||||
greyN :: Float -> Color
|
||||
greyN x = (x,x,x,1)
|
||||
|
||||
|
||||
|
||||
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
|
||||
{-# 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 (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
|
||||
{-# INLINE overCol #-}
|
||||
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 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
|
||||
|
||||
+3
-16
@@ -52,23 +52,10 @@ data RenderType
|
||||
| RenderLine [(Point3,Point4)]
|
||||
| RenderBlank
|
||||
|
||||
data Picture
|
||||
= Blank
|
||||
| Text Int String
|
||||
| Polygon Int [Point2]
|
||||
| PolygonCol Int [(Point2,RGBA)]
|
||||
| Circle Int Float
|
||||
| ThickArc Int Float Float Float Float
|
||||
| Line Int [Point2]
|
||||
| Scale Float Float Picture
|
||||
| Translate Float Float Picture
|
||||
| Rotate Float Picture
|
||||
| SetDepth Float Picture
|
||||
| Color RGBA Picture
|
||||
| Pictures [Picture]
|
||||
| OverPos (Point3 -> Point3) (Float -> Float) Picture
|
||||
type RenderTypeL = (Int,RenderType)
|
||||
|
||||
type Picture = [RenderTypeL]
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = Blank
|
||||
blank = []
|
||||
|
||||
+258
-212
@@ -42,226 +42,238 @@ 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 _ = []
|
||||
--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
|
||||
--{-# 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 (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
|
||||
--{-# INLINE overCol #-}
|
||||
--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 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,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
|
||||
--
|
||||
--picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
|
||||
--{-# INLINE picToAlt #-}
|
||||
--picToAlt x (Polygon i ps)
|
||||
-- | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
-- | otherwise = Ap.empty
|
||||
--picToAlt x (PolygonCol i vs)
|
||||
-- | i /= x = Ap.empty
|
||||
-- | otherwise =
|
||||
-- let (ps,cs) = unzip vs
|
||||
-- in Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
--picToAlt x (Circle i r)
|
||||
-- | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
|
||||
-- | otherwise = Ap.empty
|
||||
--picToAlt x (ThickArc i startA endA rad wdth)
|
||||
-- | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
-- | otherwise = Ap.empty
|
||||
--picToAlt x (Line i ps)
|
||||
-- | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
-- | otherwise = Ap.empty
|
||||
--picToAlt x (Text i s)
|
||||
-- | i == x = Ap.pure $ RenderText $ stringToList s
|
||||
-- | otherwise = Ap.empty
|
||||
--picToAlt j Blank = Ap.empty
|
||||
--picToAlt j (Scale x y pic) = fmap (scaleRen x y) $ picToAlt j pic
|
||||
--picToAlt j (Translate x y pic) = fmap (translateRen x y) $ picToAlt j pic
|
||||
--picToAlt j (Rotate a pic) = fmap (rotateRen a) $ picToAlt j pic
|
||||
--picToAlt j (SetDepth a pic) = fmap (setDepthRen a) $ picToAlt j pic
|
||||
--picToAlt j (Color c pic) = fmap (colorRen c) $ picToAlt j pic
|
||||
--picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
|
||||
--
|
||||
--picToList :: Int -> Picture -> [RenderType]
|
||||
--{-# INLINE picToList #-}
|
||||
--picToList x (Polygon i ps)
|
||||
-- | i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black]
|
||||
-- | otherwise = []
|
||||
--picToList x (PolygonCol i vs)
|
||||
-- | i /= x = []
|
||||
-- | otherwise =
|
||||
-- let (ps,cs) = unzip vs
|
||||
-- in [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs]
|
||||
--picToList x (Circle i r)
|
||||
-- | i == x = [RenderCirc $ ((0,0,0),black,r)]
|
||||
-- | otherwise = []
|
||||
--picToList x (ThickArc i startA endA rad wdth)
|
||||
-- | i == x = [RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))]
|
||||
-- | otherwise = []
|
||||
--picToList x (Line i ps)
|
||||
-- | i == x = [RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white]
|
||||
-- | otherwise = []
|
||||
--picToList x (Text i s)
|
||||
-- | i == x = [RenderText $ stringToList s]
|
||||
-- | otherwise = []
|
||||
--picToList j Blank = []
|
||||
--picToList j (Scale x y pic) = fmap (scaleRen x y) $ picToList j pic
|
||||
--picToList j (Translate x y pic) = fmap (translateRen x y) $ picToList j pic
|
||||
--picToList j (Rotate a pic) = fmap (rotateRen a) $ picToList j pic
|
||||
--picToList j (SetDepth a pic) = fmap (setDepthRen a) $ picToList j pic
|
||||
--picToList j (Color c pic) = fmap (colorRen c) $ picToList j pic
|
||||
--picToList j (Pictures pics) = concatMap (picToList j) pics
|
||||
--
|
||||
---- picToFTree :: Int -> Picture -> FTree RenderType
|
||||
---- {-# INLINE picToFTree #-}
|
||||
---- picToFTree x (Polygon i ps)
|
||||
---- | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
---- | otherwise = FLeaf RenderBlank
|
||||
---- picToFTree x (PolygonCol i vs)
|
||||
---- | i /= x = FLeaf RenderBlank
|
||||
---- | otherwise =
|
||||
---- let (ps,cs) = unzip vs
|
||||
---- in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
---- picToFTree x (Circle i r)
|
||||
---- | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
---- | otherwise = FLeaf RenderBlank
|
||||
---- picToFTree x (ThickArc i startA endA rad wdth)
|
||||
---- | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
---- | otherwise = FLeaf RenderBlank
|
||||
---- picToFTree x (Line i ps)
|
||||
---- | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
---- | otherwise = FLeaf RenderBlank
|
||||
---- picToFTree x (Text i s)
|
||||
---- | i == x = FLeaf $ RenderText $ stringToList s
|
||||
---- | otherwise = FLeaf RenderBlank
|
||||
---- picToFTree j Blank = FLeaf RenderBlank
|
||||
---- picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
|
||||
---- picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
|
||||
---- picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
|
||||
---- picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
|
||||
---- picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
|
||||
---- picToFTree j (Pictures pics) = FBranches $ map (picToFTree 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)
|
||||
--
|
||||
--picToLTree :: Int -> Picture -> LTree RenderType
|
||||
--{-# INLINE picToLTree #-}
|
||||
--picToLTree x (Polygon i ps)
|
||||
-- | i == x = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
-- | otherwise = LLeaf RenderBlank
|
||||
--picToLTree x (PolygonCol i vs)
|
||||
-- | i /= x = LLeaf RenderBlank
|
||||
-- | otherwise =
|
||||
-- let (ps,cs) = unzip vs
|
||||
-- in LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
--picToLTree x (Circle i r)
|
||||
-- | i == x = LLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
-- | otherwise = LLeaf RenderBlank
|
||||
--picToLTree x (ThickArc i startA endA rad wdth)
|
||||
-- | i == x = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
-- | otherwise = LLeaf RenderBlank
|
||||
--picToLTree x (Line i ps)
|
||||
-- | i == x = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
-- | otherwise = LLeaf RenderBlank
|
||||
--picToLTree x (Text i s)
|
||||
-- | i == x = LLeaf $ RenderText $ stringToList s
|
||||
-- | otherwise = LLeaf RenderBlank
|
||||
--picToLTree j Blank = LLeaf RenderBlank
|
||||
--picToLTree j (Scale x y pic) = fmap (scaleRen x y) $ picToLTree j pic
|
||||
--picToLTree j (Translate x y pic) = fmap (translateRen x y) $ picToLTree j pic
|
||||
--picToLTree j (Rotate a pic) = fmap (rotateRen a) $ picToLTree j pic
|
||||
--picToLTree j (SetDepth a pic) = fmap (setDepthRen a) $ picToLTree j pic
|
||||
--picToLTree j (Color c pic) = fmap (colorRen c) $ picToLTree j pic
|
||||
--picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
|
||||
--
|
||||
--doubleLine :: [Point2] -> [Point2]
|
||||
--doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
||||
--doubleLine _ = []
|
||||
|
||||
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
|
||||
{-# 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 (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
|
||||
{-# INLINE overCol #-}
|
||||
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 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,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
|
||||
|
||||
picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
|
||||
{-# INLINE picToAlt #-}
|
||||
picToAlt x (Polygon i ps)
|
||||
| i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
| otherwise = Ap.empty
|
||||
picToAlt x (PolygonCol i vs)
|
||||
| i /= x = Ap.empty
|
||||
| otherwise =
|
||||
let (ps,cs) = unzip vs
|
||||
in Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
picToAlt x (Circle i r)
|
||||
| i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
|
||||
| otherwise = Ap.empty
|
||||
picToAlt x (ThickArc i startA endA rad wdth)
|
||||
| i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
| otherwise = Ap.empty
|
||||
picToAlt x (Line i ps)
|
||||
| i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
| otherwise = Ap.empty
|
||||
picToAlt x (Text i s)
|
||||
| i == x = Ap.pure $ RenderText $ stringToList s
|
||||
| otherwise = Ap.empty
|
||||
picToAlt j Blank = Ap.empty
|
||||
picToAlt j (Scale x y pic) = fmap (scaleRen x y) $ picToAlt j pic
|
||||
picToAlt j (Translate x y pic) = fmap (translateRen x y) $ picToAlt j pic
|
||||
picToAlt j (Rotate a pic) = fmap (rotateRen a) $ picToAlt j pic
|
||||
picToAlt j (SetDepth a pic) = fmap (setDepthRen a) $ picToAlt j pic
|
||||
picToAlt j (Color c pic) = fmap (colorRen c) $ picToAlt j pic
|
||||
picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
|
||||
|
||||
picToList :: Int -> Picture -> [RenderType]
|
||||
{-# INLINE picToList #-}
|
||||
picToList x (Polygon i ps)
|
||||
| i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black]
|
||||
| otherwise = []
|
||||
picToList x (PolygonCol i vs)
|
||||
| i /= x = []
|
||||
| otherwise =
|
||||
let (ps,cs) = unzip vs
|
||||
in [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs]
|
||||
picToList x (Circle i r)
|
||||
| i == x = [RenderCirc $ ((0,0,0),black,r)]
|
||||
| otherwise = []
|
||||
picToList x (ThickArc i startA endA rad wdth)
|
||||
| i == x = [RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))]
|
||||
| otherwise = []
|
||||
picToList x (Line i ps)
|
||||
| i == x = [RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white]
|
||||
| otherwise = []
|
||||
picToList x (Text i s)
|
||||
| i == x = [RenderText $ stringToList s]
|
||||
| otherwise = []
|
||||
picToList j Blank = []
|
||||
picToList j (Scale x y pic) = fmap (scaleRen x y) $ picToList j pic
|
||||
picToList j (Translate x y pic) = fmap (translateRen x y) $ picToList j pic
|
||||
picToList j (Rotate a pic) = fmap (rotateRen a) $ picToList j pic
|
||||
picToList j (SetDepth a pic) = fmap (setDepthRen a) $ picToList j pic
|
||||
picToList j (Color c pic) = fmap (colorRen c) $ picToList j pic
|
||||
picToList j (Pictures pics) = concatMap (picToList j) pics
|
||||
|
||||
-- picToFTree :: Int -> Picture -> FTree RenderType
|
||||
-- {-# INLINE picToFTree #-}
|
||||
-- picToFTree x (Polygon i ps)
|
||||
-- | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
-- | otherwise = FLeaf RenderBlank
|
||||
-- picToFTree x (PolygonCol i vs)
|
||||
-- | i /= x = FLeaf RenderBlank
|
||||
-- | otherwise =
|
||||
-- let (ps,cs) = unzip vs
|
||||
-- in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
-- picToFTree x (Circle i r)
|
||||
-- | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
-- | otherwise = FLeaf RenderBlank
|
||||
-- picToFTree x (ThickArc i startA endA rad wdth)
|
||||
-- | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
-- | otherwise = FLeaf RenderBlank
|
||||
-- picToFTree x (Line i ps)
|
||||
-- | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
-- | otherwise = FLeaf RenderBlank
|
||||
-- picToFTree x (Text i s)
|
||||
-- | i == x = FLeaf $ RenderText $ stringToList s
|
||||
-- | otherwise = FLeaf RenderBlank
|
||||
-- picToFTree j Blank = FLeaf RenderBlank
|
||||
-- picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
|
||||
-- picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
|
||||
-- picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
|
||||
-- picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
|
||||
-- picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
|
||||
-- picToFTree j (Pictures pics) = FBranches $ map (picToFTree 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)
|
||||
|
||||
picToLTree :: Int -> Picture -> LTree RenderType
|
||||
{-# INLINE picToLTree #-}
|
||||
picToLTree x (Polygon i ps)
|
||||
| i == x = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
| otherwise = LLeaf RenderBlank
|
||||
picToLTree x (PolygonCol i vs)
|
||||
| i /= x = LLeaf RenderBlank
|
||||
| otherwise =
|
||||
let (ps,cs) = unzip vs
|
||||
in LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
picToLTree x (Circle i r)
|
||||
| i == x = LLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
| otherwise = LLeaf RenderBlank
|
||||
picToLTree x (ThickArc i startA endA rad wdth)
|
||||
| i == x = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
| otherwise = LLeaf RenderBlank
|
||||
picToLTree x (Line i ps)
|
||||
| i == x = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
| otherwise = LLeaf RenderBlank
|
||||
picToLTree x (Text i s)
|
||||
| i == x = LLeaf $ RenderText $ stringToList s
|
||||
| otherwise = LLeaf RenderBlank
|
||||
picToLTree j Blank = LLeaf RenderBlank
|
||||
picToLTree j (Scale x y pic) = fmap (scaleRen x y) $ picToLTree j pic
|
||||
picToLTree j (Translate x y pic) = fmap (translateRen x y) $ picToLTree j pic
|
||||
picToLTree j (Rotate a pic) = fmap (rotateRen a) $ picToLTree j pic
|
||||
picToLTree j (SetDepth a pic) = fmap (setDepthRen a) $ picToLTree j pic
|
||||
picToLTree j (Color c pic) = fmap (colorRen c) $ picToLTree j pic
|
||||
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
|
||||
|
||||
doubleLine :: [Point2] -> [Point2]
|
||||
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
||||
doubleLine _ = []
|
||||
|
||||
theFold :: TwoPtrs
|
||||
theFold :: Int
|
||||
-> TwoPtrs
|
||||
-> ThreePtrs
|
||||
-> ThreePtrs
|
||||
-> TwoPtrs
|
||||
-> ThreePtrs
|
||||
-> F.FoldM IO RenderType (Int,Int,Int,Int,Int)
|
||||
theFold pas pbs pcs pds pes
|
||||
-> F.FoldM IO (Int,RenderType) (Int,Int,Int,Int,Int)
|
||||
theFold i pas pbs pcs pds pes
|
||||
-- = (,,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
|
||||
= (,,,,) <$> pokeTwoPtrsWith pokePoly pas
|
||||
<*> pokeThreePtrsWith pokeText pbs
|
||||
<*> pokeThreePtrsWith pokeCirc pcs
|
||||
<*> pokeTwoPtrsWith pokeLine pds
|
||||
<*> pokeThreePtrsWith pokeArc pes
|
||||
= (,,,,) <$> pokeTwoPtrsWith (pokePolyN i) pas
|
||||
<*> pokeThreePtrsWith (pokeTextN i) pbs
|
||||
<*> pokeThreePtrsWith (pokeCircN i) pcs
|
||||
<*> pokeTwoPtrsWith (pokeLineN i) pds
|
||||
<*> pokeThreePtrsWith (pokeArcN i) 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 :: (ThreePtrs -> Int -> (Int,RenderType) -> IO Int)
|
||||
-> ThreePtrs -> F.FoldM IO (Int,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
|
||||
pokeTwoPtrsWith :: (TwoPtrs -> Int -> (Int,RenderType) -> IO Int)
|
||||
-> TwoPtrs -> F.FoldM IO (Int,RenderType) Int
|
||||
{-# INLINE pokeTwoPtrsWith #-}
|
||||
pokeTwoPtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
|
||||
|
||||
pokeArcN :: Int -> ThreePtrs -> Int -> (Int,RenderType) -> IO Int
|
||||
{-# INLINE pokeArcN #-}
|
||||
pokeArcN i (pa,pb,pc) n (j,RenderArc (p,c,s))
|
||||
| n > 20000 * 2 || i /= j = return n
|
||||
| otherwise = do
|
||||
pokeThreeOff pa n p
|
||||
pokeFourOff pb n c
|
||||
pokeFourOff pc n s
|
||||
return $ n + 1
|
||||
pokeArcN _ _ n _ = return n
|
||||
|
||||
pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
|
||||
{-# INLINE pokeArc #-}
|
||||
pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
|
||||
@@ -293,6 +305,13 @@ pokeFourOff ptr n (x,y,z,w) = do
|
||||
pokeElemOff ptr (4*n+3) w
|
||||
|
||||
|
||||
pokeLineN :: Int -> TwoPtrs -> Int -> (Int,RenderType) -> IO Int
|
||||
{-# INLINE pokeLineN #-}
|
||||
pokeLineN i (pa,pb) n (j,RenderLine vs)
|
||||
| i == j = foldM (pokeLineVert pa pb) n vs
|
||||
| otherwise = return n
|
||||
pokeLineN _ _ n _ = return n
|
||||
|
||||
pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int
|
||||
{-# INLINE pokeLine #-}
|
||||
pokeLine (pa,pb) n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
|
||||
@@ -307,6 +326,17 @@ pokeLineVert pa pb n (p,c)
|
||||
pokeFourOff pb n c
|
||||
return (n+1)
|
||||
|
||||
pokeCircN :: Int -> ThreePtrs -> Int -> (Int,RenderType) -> IO Int
|
||||
{-# INLINE pokeCircN #-}
|
||||
pokeCircN i (pa,pb,pc) n (j,RenderCirc (p,c,s))
|
||||
| n > 20000 * 2 || i /= j = return n
|
||||
| otherwise = do
|
||||
pokeThreeOff pa n p
|
||||
pokeFourOff pb n c
|
||||
pokeElemOff pc n s
|
||||
return (n+1)
|
||||
pokeCircN _ _ n _ = return n
|
||||
|
||||
pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
|
||||
{-# INLINE pokeCirc #-}
|
||||
pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s))
|
||||
@@ -323,6 +353,14 @@ 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
|
||||
|
||||
pokeTextN :: Int -> (Ptr Float, Ptr Float, Ptr Float) -> Int -> (Int,RenderType) -> IO Int
|
||||
{-# INLINE pokeTextN #-}
|
||||
pokeTextN i (pa,pb,pc) n (j,RenderText vs)
|
||||
| i == j = foldM (pokeTextVert pa pb pc) n vs
|
||||
| otherwise = return n
|
||||
pokeTextN i _ n _ = return n
|
||||
|
||||
|
||||
pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point2) -> IO Int
|
||||
{-# INLINE pokeTextVert #-}
|
||||
pokeTextVert pa pb pc n (p,c,t)
|
||||
@@ -333,6 +371,13 @@ pokeTextVert pa pb pc n (p,c,t)
|
||||
pokeTwoOff pc n t
|
||||
return (n+1)
|
||||
|
||||
pokePolyN :: Int -> TwoPtrs -> Int -> (Int, RenderType) -> IO Int
|
||||
{-# INLINE pokePolyN #-}
|
||||
pokePolyN j (pa,pb) n (i,RenderPoly vs)
|
||||
| i == j = foldM (pokeVert pa pb) n vs
|
||||
| otherwise = return n
|
||||
pokePolyN _ _ n _ = return n
|
||||
|
||||
pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
|
||||
{-# INLINE pokePoly #-}
|
||||
pokePoly (pa,pb) n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
|
||||
@@ -456,15 +501,15 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
|
||||
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
||||
clear [DepthBuffer]
|
||||
-- draw layer 0
|
||||
ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 0 pic
|
||||
ticks2 <- renderTree 0 pdata rot zoom (tranx,trany) (winx,winy) $ pic
|
||||
--((picToAlt 0 pic) :: [RenderType])
|
||||
-- reset blend so that light map doesn't apply
|
||||
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 1 pic
|
||||
ticks3 <- renderTree 1 pdata rot zoom (tranx,trany) (winx,winy) $ pic
|
||||
-- set drawing for on top
|
||||
aticks <- SDL.ticks
|
||||
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
||||
ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 2 pic
|
||||
ticks4 <- renderTree 2 pdata rot zoom (tranx,trany) (winx,winy) $ pic
|
||||
bticks <- SDL.ticks
|
||||
-- reset uniforms (hacky for now)
|
||||
idmat <- (newMatrix RowMajor [1,0,0,0
|
||||
@@ -499,15 +544,16 @@ bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
-- the following code draws a picture tree
|
||||
-- it does not set nor change the blend function or depth buffer
|
||||
-- nor does it set uniforms
|
||||
renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
|
||||
-> f RenderType -> IO Word32
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
||||
renderTree :: Foldable f => Int -> RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
|
||||
-> f (Int,RenderType) -> IO Word32
|
||||
renderTree i pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
||||
|
||||
pokeStartTicks <- SDL.ticks
|
||||
-- poke necessary data
|
||||
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
|
||||
-- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
|
||||
<- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
|
||||
<- F.foldM (theFold i
|
||||
(twoPtrsVAO $ _triVAO pdata)
|
||||
(threePtrsVAO $ _textVAO pdata)
|
||||
(threePtrsVAO $ _circVAO pdata)
|
||||
(twoPtrsVAO $ _lineVAO pdata)
|
||||
|
||||
Reference in New Issue
Block a user