216 lines
5.0 KiB
Haskell
216 lines
5.0 KiB
Haskell
--{-# LANGUAGE BangPatterns #-}
|
|
--{-# LANGUAGE Strict #-}
|
|
module Picture
|
|
( module Picture.Data
|
|
, polygon
|
|
, polygonCol
|
|
, 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
|
|
|
|
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)
|