265 lines
7.1 KiB
Haskell
265 lines
7.1 KiB
Haskell
--{-# LANGUAGE BangPatterns #-}
|
|
--{-# LANGUAGE Strict #-}
|
|
module Picture
|
|
( module Picture.Data
|
|
, polygon
|
|
, polygonCol
|
|
, bezierQuad
|
|
, arc
|
|
, arcSolid
|
|
, thickArc
|
|
, thickCircle
|
|
, 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
|
|
, setLayer
|
|
)
|
|
where
|
|
import Geometry
|
|
import Geometry.Data
|
|
|
|
import Picture.Data
|
|
|
|
import Data.Bifunctor
|
|
import qualified Data.DList as DL
|
|
|
|
import Graphics.Rendering.OpenGL (lineWidth, ($=))
|
|
|
|
import Control.Lens
|
|
|
|
black :: RGBA
|
|
black = (0,0,0,1)
|
|
|
|
polygon :: [Point2] -> Picture
|
|
{-# INLINE polygon #-}
|
|
polygon = Polygon 0
|
|
|
|
polygonCol :: [(Point2,RGBA)] -> Picture
|
|
{-# INLINE polygonCol #-}
|
|
polygonCol = PolygonCol 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
|
|
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 = BezierQuad 0 [-- ( (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
|
|
|
|
-- 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 pic = OverPic id id 0 (const c) pic
|
|
|
|
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 pic = OverPic (translate3 x y) id 0 id pic
|
|
|
|
setDepth :: Float -> Picture -> Picture
|
|
{-# INLINE setDepth #-}
|
|
setDepth d pic = OverPic (\(x,y,_) -> (x,y,-d)) id 0 id pic
|
|
|
|
setLayer :: Int -> Picture -> Picture
|
|
{-# INLINE setLayer #-}
|
|
setLayer i pic = OnLayer i pic
|
|
|
|
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 pic = OverPic (scale3 x y) (\(a,b) ->(a*x,b*y)) 0 id pic
|
|
|
|
rotate3 :: Float -> Point3 -> Point3
|
|
{-# INLINE rotate3 #-}
|
|
rotate3 a (x,y,z) = (x',y',z)
|
|
where (x',y') = rotateV a (x,y)
|
|
|
|
rotate :: Float -> Picture -> Picture
|
|
{-# INLINE rotate #-}
|
|
rotate a pic = OverPic (rotate3 a) id a id pic
|
|
|
|
--rotateRad a = Rotate a
|
|
--{-# INLINE rotateRad #-}
|
|
|
|
pictures :: [Picture] -> Picture
|
|
{-# INLINE pictures #-}
|
|
pictures = Pictures
|
|
|
|
|
|
makeArc :: Float -> (Float,Float) -> [Point2]
|
|
{-# INLINE makeArc #-}
|
|
makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
|
|
where as = [a,a+step.. b]
|
|
step = pi * 0.2
|
|
|
|
circleSolid :: Float -> Picture
|
|
{-# INLINE circleSolid #-}
|
|
circleSolid = Circle 0 white white
|
|
|
|
circleSolidCol :: Color -> Color -> Float -> Picture
|
|
{-# INLINE circleSolidCol #-}
|
|
circleSolidCol = Circle 0
|
|
|
|
circle :: Float -> Picture
|
|
{-# INLINE circle #-}
|
|
circle rad = thickArc 0 (2*pi) rad 1
|
|
|
|
text :: String -> Picture
|
|
{-# INLINE text #-}
|
|
text = Text 1
|
|
|
|
line :: [Point2] -> Picture
|
|
{-# INLINE line #-}
|
|
line = Line 0
|
|
|
|
lineCol :: [(Point2,RGBA)] -> Picture
|
|
{-# INLINE lineCol #-}
|
|
lineCol = LineCol 0
|
|
|
|
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))
|
|
|
|
thickCircle :: Float -> Float -> Picture
|
|
{-# INLINE thickCircle #-}
|
|
--thickCircle rad wdth = thickLine (makeArc rad (0,2*pi)) wdth
|
|
thickCircle rad wdth = thickArc 0 (2*pi) rad wdth
|
|
|
|
arcSolid :: Float -> Float -> Float -> Picture
|
|
{-# INLINE arcSolid #-}
|
|
arcSolid startA endA rad
|
|
= polygon $ (0,0) : makeArc rad (startA,endA)
|
|
|
|
arc startA endA rad = thickArc startA endA rad 1
|
|
{-# INLINE arc #-}
|
|
|
|
thickArc :: Float -> Float -> Float -> Float -> Picture
|
|
{-# INLINE thickArc #-}
|
|
thickArc = ThickArc 0
|
|
--thickArc startA endA rad wdth
|
|
-- = thickLine (makeArc rad (startA,endA)) wdth
|
|
|
|
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 + normratb * y^2
|
|
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)
|