379 lines
11 KiB
Haskell
379 lines
11 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module Picture
|
|
( module Picture.Data
|
|
, polygon
|
|
, polygonZ
|
|
, polygonCol
|
|
, poly3
|
|
, poly3Col
|
|
, bezierQuad
|
|
, arc
|
|
, arcSolid
|
|
, thickArc
|
|
, thickCircle
|
|
, thickLine
|
|
, circleSolid
|
|
, circleSolidCol
|
|
, circle
|
|
, line
|
|
, lineCol
|
|
, text
|
|
, pictures
|
|
, translate
|
|
, rotate
|
|
, scale
|
|
, color
|
|
, withAlpha
|
|
, greyN
|
|
, red
|
|
, green
|
|
, blue
|
|
, yellow
|
|
, cyan
|
|
, magenta
|
|
, rose
|
|
, violet
|
|
, azure
|
|
, aquamarine
|
|
, chartreuse
|
|
, orange
|
|
, white
|
|
, black
|
|
, dim
|
|
, light
|
|
, dark
|
|
, bright
|
|
, mixColors
|
|
, zeroZ
|
|
, setDepth
|
|
, addDepth
|
|
, setLayer
|
|
)
|
|
where
|
|
import Geometry
|
|
import Geometry.Vector3D
|
|
import Geometry.Data
|
|
import Picture.Data
|
|
|
|
import Data.List
|
|
import Data.Bifunctor
|
|
--import qualified Data.DList as DL
|
|
--import Graphics.Rendering.OpenGL (lineWidth, ($=))
|
|
--import Control.Lens
|
|
|
|
black :: RGBA
|
|
black = (0,0,0,1)
|
|
|
|
zl :: RenderType -> [(Int,RenderType)]
|
|
zl rt = [(0,rt)]
|
|
|
|
polygon :: [Point2] -> Picture
|
|
{-# INLINE polygon #-}
|
|
polygon ps = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
|
|
|
polygonZ :: [Point2] -> Float -> Picture
|
|
{-# INLINE polygonZ #-}
|
|
polygonZ ps z = zl $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
|
|
|
|
polygonCol :: [(Point2,RGBA)] -> Picture
|
|
{-# INLINE polygonCol #-}
|
|
polygonCol vs = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
|
where
|
|
(ps,cs) = unzip vs
|
|
|
|
poly3 :: [Point3] -> Picture
|
|
{-# INLINE poly3 #-}
|
|
poly3 = poly3Col . map (, black)
|
|
|
|
poly3Col :: [(Point3,RGBA)] -> Picture
|
|
{-# INLINE poly3Col #-}
|
|
poly3Col vs = zl $ RenderPoly $ polyToTris vs
|
|
|
|
-- note that much of work computing the width of the bezier curve is done here
|
|
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
|
|
bezierQuad cola colc ra rc a b c
|
|
| a == b && b == c = blank
|
|
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
|
|
| otherwise = bzhelp
|
|
[-- ( (0,0) , cola, (0,0), (0,0) )
|
|
(aIn, cola, (fa aIn,fc aIn) , (1,0) )
|
|
,(aIn, cola, (fa aIn,fc aIn) , (1,0) )
|
|
,(cIn, colc, (fa cIn,fc cIn) , (0,1) )
|
|
,( aX, cola, (1,0) , (fa' aX,fc' aX) )
|
|
,( cX, colc, (0,1) , (fa' cX,fc' cX) )
|
|
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
|
|
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
|
|
]
|
|
where
|
|
colb = mixColors 0.5 0.5 cola colc
|
|
b2a | isLHS a b c = a -.- b
|
|
| otherwise = b -.- a
|
|
aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
|
|
aX = a -.- aRadVec
|
|
aIn = a +.+ aRadVec
|
|
b2c | isLHS a b c = b -.- c
|
|
| otherwise = c -.- b
|
|
cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
|
|
cX = c -.- cRadVec
|
|
cIn = c +.+ cRadVec
|
|
bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
|
|
bX = b +.+ bRadVec
|
|
bIn = b -.- bRadVec
|
|
fa = extrapolate aX cX bX
|
|
fc = extrapolate cX aX bX
|
|
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
|
|
|
|
|
|
-- given a one and two zeros of a linear function over x and y,
|
|
-- determine the function
|
|
-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
|
|
extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float
|
|
extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) =
|
|
( x * ( ay - by )
|
|
+ y * ( bx - ax )
|
|
+ (ax * by - bx * ay)
|
|
)
|
|
/
|
|
( ox * ( ay - by )
|
|
+ ax * ( by - oy )
|
|
+ bx * ( oy - ay )
|
|
)
|
|
|
|
color :: RGBA -> Picture -> Picture
|
|
{-# INLINE color #-}
|
|
color c = map $ second $ overCol (const c)
|
|
|
|
translate3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE translate3 #-}
|
|
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)
|
|
|
|
setDepth :: Float -> Picture -> Picture
|
|
{-# INLINE setDepth #-}
|
|
setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
|
|
|
|
addDepth :: Float -> Picture -> Picture
|
|
{-# INLINE addDepth #-}
|
|
addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
|
|
|
|
setLayer :: Int -> Picture -> Picture
|
|
{-# INLINE setLayer #-}
|
|
setLayer = map . first . const
|
|
|
|
scale3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE scale3 #-}
|
|
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)
|
|
|
|
rotate :: Float -> Picture -> Picture
|
|
{-# INLINE rotate #-}
|
|
rotate a = map $ second $ overPos $ (rotate3 a)
|
|
|
|
pictures :: [Picture] -> Picture
|
|
{-# INLINE pictures #-}
|
|
pictures = concat
|
|
|
|
makeArc :: Float -> (Float,Float) -> [Point2]
|
|
{-# INLINE makeArc #-}
|
|
makeArc rad (a,b) = map (`rotateV` (0,rad)) angles
|
|
where
|
|
angles = [a,a+step.. b]
|
|
step = pi * 0.2
|
|
|
|
circleSolid :: Float -> Picture
|
|
{-# INLINE circleSolid #-}
|
|
circleSolid = circleSolidCol white white
|
|
|
|
circleSolidCol :: Color -> Color -> Float -> Picture
|
|
{-# INLINE circleSolidCol #-}
|
|
circleSolidCol colC colE r = zl $ RenderEllipse
|
|
[( (-r, r,0), colC)
|
|
,( (-r,-r,0), colE)
|
|
,( ( r,-r,0), black)
|
|
]
|
|
|
|
circle :: Float -> Picture
|
|
{-# INLINE circle #-}
|
|
circle rad = thickArc 0 (2*pi) rad 1
|
|
|
|
text :: String -> Picture
|
|
{-# INLINE text #-}
|
|
text s = zl $ RenderText $ stringToList s
|
|
|
|
line :: [Point2] -> Picture
|
|
{-# INLINE line #-}
|
|
--line = Line
|
|
line = flip thickLine 1
|
|
|
|
lineCol :: [(Point2,RGBA)] -> Picture
|
|
{-# INLINE lineCol #-}
|
|
--lineCol = LineCol
|
|
lineCol = flip thickLineCol 1
|
|
|
|
thickLine :: [Point2] -> Float -> Picture
|
|
{-# INLINE thickLine #-}
|
|
thickLine ps t = pictures $ f ps
|
|
where
|
|
f (x:y:ys)
|
|
| x == y = f (x:ys)
|
|
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
|
|
f _ = []
|
|
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
|
|
|
|
thickLineCol :: [(Point2,RGBA)] -> Float -> Picture
|
|
{-# INLINE thickLineCol #-}
|
|
thickLineCol ps t = pictures $ f ps
|
|
where
|
|
f ((x,c):(y,c'):ys)
|
|
| x == y = f ((x,c):ys)
|
|
| otherwise = polygonCol
|
|
[(x +.+ n x y,c)
|
|
,(x -.- n x y,c)
|
|
,(y -.- n x y,c')
|
|
,(y +.+ n x y,c')
|
|
] : f ((y,c'):ys)
|
|
f _ = []
|
|
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
|
|
|
|
thickCircle :: Float -> Float -> Picture
|
|
{-# INLINE thickCircle #-}
|
|
thickCircle = thickArc 0 (2*pi)
|
|
|
|
arcSolid
|
|
:: Float -- ^ Start angle
|
|
-> Float -- ^ End angle
|
|
-> Float -- ^ Radius
|
|
-> Picture
|
|
{-# INLINE arcSolid #-}
|
|
arcSolid startA endA rad = polygon $ (0,0) : makeArc rad (startA,endA)
|
|
|
|
arc
|
|
:: Float -- ^ Start angle
|
|
-> Float -- ^ End angle
|
|
-> Float -- ^ Radius
|
|
-> Picture
|
|
arc startA endA rad = thickArc startA endA rad 1
|
|
{-# INLINE arc #-}
|
|
|
|
thickArc :: Float -> Float -> Float -> Float -> Picture
|
|
{-# INLINE thickArc #-}
|
|
thickArc startA endA rad wdth
|
|
| endA - startA > pi = pictures
|
|
[ thickArc (startA + pi) endA rad wdth
|
|
, thickArcHelp startA (startA + pi) r w
|
|
]
|
|
| otherwise = thickArcHelp startA endA r w
|
|
where
|
|
r = rad + 0.5 * wdth
|
|
w = 1 - wdth / r
|
|
|
|
thickArcHelp :: Float -> Float -> Float -> Float -> [(Int, RenderType)]
|
|
thickArcHelp startA endA rad wdth = zl $ RenderArc
|
|
[( (0,0,0),black,(0,0,wdth))
|
|
,((xa,ya,0),black,(1,0,wdth))
|
|
,((xb,yb,0),black,(1,1,wdth))
|
|
,( (0,0,0),black,(0,0,wdth))
|
|
,((xb,yb,0),black,(1,1,wdth))
|
|
,((xc,yc,0),black,(0,1,wdth))
|
|
]
|
|
where
|
|
(xa,ya) = rotateV startA (rad,0)
|
|
(xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
|
|
(xc,yc) = rotateV endA (rad,0)
|
|
|
|
withAlpha :: Float -> RGBA -> RGBA
|
|
{-# INLINE withAlpha #-}
|
|
withAlpha a (x,y,z,a') = (x,y,z,a*a')
|
|
|
|
red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color
|
|
red = (1,0,0,1)
|
|
green = (0,1,0,1)
|
|
blue = (0,0,1,1)
|
|
yellow = (1,1,0,1)
|
|
cyan = (0,1,1,1)
|
|
magenta = (1,0,1,1)
|
|
rose = (1,0,0.5,1)
|
|
violet = (0.5,0,1,1)
|
|
azure = (0,0.5,1,1)
|
|
aquamarine= (0,1,0.5,1)
|
|
chartreuse= (0.5,1,0,1)
|
|
orange = (1,0.5,0,1)
|
|
white = (1,1,1,1)
|
|
|
|
mixColors :: Float -> Float -> Color -> Color -> Color
|
|
mixColors rata ratb (r0,g0,b0,a0) (r2,g2,b2,a2) =
|
|
let fullrat = rata + ratb
|
|
normrata = rata / fullrat
|
|
normratb = ratb / fullrat
|
|
f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
|
|
in (f r0 r2 , f g0 g2 , f b0 b2 , normrata * a0 + normratb * a2)
|
|
|
|
light :: Color -> Color
|
|
light (r,g,b,a) = (r+0.2,g+0.2,b+0.2,a)
|
|
|
|
dark :: Color -> Color
|
|
dark (r,g,b,a) = (r-0.2,g-0.2,b-0.2,a)
|
|
|
|
dim :: Color -> Color
|
|
dim (r,g,b,a) = (r/1.2,g/1.2,b/1.2,a)
|
|
|
|
bright :: Color -> Color
|
|
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) -> RenderType -> RenderType
|
|
--{-# 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 _ _ = 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
|
|
|
|
-- no premature optimisation, consider changing to use texture arrays
|
|
stringToList :: String -> [(Point3,Point4,Point2)]
|
|
{-# INLINE stringToList #-}
|
|
--stringToList s = concat $ zipWith charToTuple [0,0.9*dimText ..] s
|
|
stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
|
|
where
|
|
dimText = 100
|
|
|
|
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
|
|
{-# INLINE charToTuple #-}
|
|
charToTuple x c =
|
|
[((x-50,-100,0), white,(offset,1))
|
|
,((x-50,100,0), white,(offset,0))
|
|
,((x+50,100,0), white,(offset+1,0))
|
|
,((x-50,-100,0), white,(offset,1))
|
|
,((x+50,-100,0), white,(offset+1,1))
|
|
,((x+50,100,0), white,(offset+1,0))
|
|
]
|
|
where
|
|
offset = fromIntegral (fromEnum c) - 32
|