Reduce rendertype down to vertex information
This commit is contained in:
+39
-63
@@ -59,7 +59,7 @@ import Data.List
|
||||
import Data.Bifunctor
|
||||
--import qualified Data.DList as DL
|
||||
--import Graphics.Rendering.OpenGL (lineWidth, ($=))
|
||||
--import Control.Lens
|
||||
import Control.Lens
|
||||
|
||||
black :: RGBA
|
||||
black = (0,0,0,1)
|
||||
@@ -69,17 +69,21 @@ zl rt = [(0,rt)]
|
||||
|
||||
polygon :: [Point2] -> Picture
|
||||
{-# INLINE polygon #-}
|
||||
polygon ps = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
polygon ps = map (f . zeroZ) $ polyToTris ps
|
||||
where
|
||||
f pos = Verx pos black PolyV 0
|
||||
|
||||
polygonZ :: [Point2] -> Float -> Picture
|
||||
{-# INLINE polygonZ #-}
|
||||
polygonZ ps z = zl $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
|
||||
polygonZ ps z = map (f . zeroZ) $ polyToTris ps
|
||||
where
|
||||
f pos = Verx pos black (PolyzV z) 0
|
||||
|
||||
polygonCol :: [(Point2,RGBA)] -> Picture
|
||||
{-# INLINE polygonCol #-}
|
||||
polygonCol vs = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
where
|
||||
(ps,cs) = unzip vs
|
||||
polygonCol vs = map f $ polyToTris vs
|
||||
where
|
||||
f ((x,y),col) = Verx (x,y,0) col PolyV 0
|
||||
|
||||
poly3 :: [Point3] -> Picture
|
||||
{-# INLINE poly3 #-}
|
||||
@@ -87,7 +91,9 @@ poly3 = poly3Col . map (, black)
|
||||
|
||||
poly3Col :: [(Point3,RGBA)] -> Picture
|
||||
{-# INLINE poly3Col #-}
|
||||
poly3Col vs = zl $ RenderPoly $ polyToTris vs
|
||||
poly3Col vs = map f $ polyToTris vs
|
||||
where
|
||||
f (pos,col) = Verx pos col PolyV 0
|
||||
|
||||
-- note that much of work computing the width of the bezier curve is done here
|
||||
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
|
||||
@@ -124,12 +130,10 @@ bezierQuad cola colc ra rc a b c
|
||||
fa' = extrapolate aIn cIn bIn
|
||||
fc' = extrapolate cIn aIn bIn
|
||||
|
||||
bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> [(Int, RenderType)]
|
||||
bzhelp vs = zl $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
|
||||
where
|
||||
(ps,cols,offps,rads) = unzip4 vs
|
||||
rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
|
||||
|
||||
bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> Picture
|
||||
bzhelp = map f
|
||||
where
|
||||
f ((x,y),col,(a,b),(c,d)) = Verx (x,y,0) col (BezV (a,b,c,d)) 0
|
||||
|
||||
-- given a one and two zeros of a linear function over x and y,
|
||||
-- determine the function
|
||||
@@ -148,8 +152,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) =
|
||||
|
||||
color :: RGBA -> Picture -> Picture
|
||||
{-# INLINE color #-}
|
||||
--color c = map $ second $ overCol (const c)
|
||||
color c = map $ overCol' (const c)
|
||||
color c = map $ overCol (const c)
|
||||
|
||||
translate3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE translate3 #-}
|
||||
@@ -158,21 +161,23 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
|
||||
translate :: Float -> Float -> Picture -> Picture
|
||||
--{-# INLINE translate #-}
|
||||
--translate x y = map $ second $ overPos (translate3 x y)
|
||||
translate x y = map $ overPos' (translate3 x y)
|
||||
translate x y = map $ overPos (translate3 x y)
|
||||
|
||||
setDepth :: Float -> Picture -> Picture
|
||||
--{-# INLINE setDepth #-}
|
||||
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
|
||||
setDepth d = map $ overPos' (\(x,y,_) -> (x,y,d))
|
||||
setDepth d = map $ overPos (\(x,y,_) -> (x,y,d))
|
||||
|
||||
addDepth :: Float -> Picture -> Picture
|
||||
--{-# INLINE addDepth #-}
|
||||
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
|
||||
addDepth d = map $ overPos' (\(x,y,z) -> (x,y,z+d))
|
||||
addDepth d = map $ overPos (\(x,y,z) -> (x,y,z+d))
|
||||
|
||||
setLayer :: Int -> Picture -> Picture
|
||||
{-# INLINE setLayer #-}
|
||||
setLayer = map . first . const
|
||||
setLayer i = map $ f
|
||||
where
|
||||
f v = v {_vxLayer = i}
|
||||
|
||||
scale3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE scale3 #-}
|
||||
@@ -181,12 +186,11 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
|
||||
scale :: Float -> Float -> Picture -> Picture
|
||||
--{-# INLINE scale #-}
|
||||
--scale x y = map . second . overPos $ scale3 x y
|
||||
scale x y = map $ overPos' $ scale3 x y
|
||||
scale x y = map $ overPos $ scale3 x y
|
||||
|
||||
rotate :: Float -> Picture -> Picture
|
||||
--{-# INLINE rotate #-}
|
||||
--rotate a = map . second . overPos $ rotate3 a
|
||||
rotate a = map $ overPos' $ rotate3 a
|
||||
rotate a = map $ overPos $ rotate3 a
|
||||
|
||||
pictures :: [Picture] -> Picture
|
||||
{-# INLINE pictures #-}
|
||||
@@ -205,11 +209,13 @@ circleSolid = circleSolidCol white white
|
||||
|
||||
circleSolidCol :: Color -> Color -> Float -> Picture
|
||||
{-# INLINE circleSolidCol #-}
|
||||
circleSolidCol colC colE r = zl $ RenderEllipse
|
||||
circleSolidCol colC colE r = map f
|
||||
[( (-r, r,0), colC)
|
||||
,( (-r,-r,0), colE)
|
||||
,( ( r,-r,0), black)
|
||||
]
|
||||
where
|
||||
f (pos,col) = Verx pos col EllV 0
|
||||
|
||||
circle :: Float -> Picture
|
||||
{-# INLINE circle #-}
|
||||
@@ -217,7 +223,9 @@ circle rad = thickArc 0 (2*pi) rad 1
|
||||
|
||||
text :: String -> Picture
|
||||
{-# INLINE text #-}
|
||||
text s = zl $ RenderText $ stringToList s
|
||||
text s = map f $ stringToList s
|
||||
where
|
||||
f (pos,col,val) = Verx pos col (TextV val) 0
|
||||
|
||||
line :: [Point2] -> Picture
|
||||
{-# INLINE line #-}
|
||||
@@ -286,8 +294,8 @@ thickArc startA endA rad wdth
|
||||
r = rad + 0.5 * wdth
|
||||
w = 1 - wdth / r
|
||||
|
||||
thickArcHelp :: Float -> Float -> Float -> Float -> [(Int, RenderType)]
|
||||
thickArcHelp startA endA rad wdth = zl $ RenderArc
|
||||
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
|
||||
thickArcHelp startA endA rad wdth = map f
|
||||
[( (0,0,0),black,(0,0,wdth))
|
||||
,((xa,ya,0),black,(1,0,wdth))
|
||||
,((xb,yb,0),black,(1,1,wdth))
|
||||
@@ -299,6 +307,7 @@ thickArcHelp startA endA rad wdth = zl $ RenderArc
|
||||
(xa,ya) = rotateV startA (rad,0)
|
||||
(xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
|
||||
(xc,yc) = rotateV endA (rad,0)
|
||||
f (pos,col,val) = Verx pos col (ArcV val) 0
|
||||
|
||||
withAlpha :: Float -> RGBA -> RGBA
|
||||
{-# INLINE withAlpha #-}
|
||||
@@ -342,45 +351,12 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
|
||||
greyN :: Float -> Color
|
||||
greyN x = (x,x,x,1)
|
||||
|
||||
overPos' :: (Point3 -> Point3) -> (Int,RenderType) -> (Int,RenderType)
|
||||
--{-# INLINE overPos' #-}
|
||||
overPos' f (i,RenderPoly vs) = (i, RenderPoly $ map (first f) vs )
|
||||
overPos' f (i,RenderText vs) = (i, RenderText $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' f (i,RenderBezQ vs) = (i, RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' f (i,RenderEllipse vs) = (i, RenderEllipse $ map (first f) vs )
|
||||
overPos' f (i,RenderArc vs) = (i, RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' f (i,RenderPolyZ vs) = (i, RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' _ rt = rt
|
||||
|
||||
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
|
||||
overPos :: (Point3 -> Point3) -> Verx -> Verx
|
||||
{-# INLINE overPos #-}
|
||||
overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
|
||||
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
|
||||
overPos f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos _ rt = rt
|
||||
overPos = over vxPos
|
||||
|
||||
overCol' :: (Point4 -> Point4) -> (Int,RenderType) -> (Int,RenderType)
|
||||
--{-# INLINE overCol #-}
|
||||
overCol' f (i,(RenderPoly vs) ) = (i,RenderPoly $ map (second f) vs )
|
||||
overCol' f (i,(RenderEllipse vs)) = (i,RenderEllipse $ map (second f) vs )
|
||||
overCol' f (i,(RenderText vs) ) = (i,RenderText $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' f (i,(RenderBezQ vs) ) = (i,RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' f (i,(RenderArc vs) ) = (i,RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' f (i,(RenderPolyZ vs) ) = (i,RenderPolyZ $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' _ _ = undefined
|
||||
|
||||
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
|
||||
--{-# INLINE overCol #-}
|
||||
overCol f (RenderPoly vs) = RenderPoly $ 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 (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol _ _ = undefined
|
||||
overCol :: (Point4 -> Point4) -> Verx -> Verx
|
||||
overCol = over vxCol
|
||||
|
||||
-- no premature optimisation, consider changing to use texture arrays
|
||||
stringToList :: String -> [(Point3,Point4,Point2)]
|
||||
|
||||
Reference in New Issue
Block a user