250 lines
6.5 KiB
Haskell
250 lines
6.5 KiB
Haskell
--{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE Strict #-}
|
|
module Picture
|
|
( module Picture.Data
|
|
, polygon
|
|
, arc
|
|
, arcSolid
|
|
, thickArc
|
|
, thickCircle
|
|
, circleSolid
|
|
, circle
|
|
, line
|
|
, text
|
|
, pictures
|
|
, translate
|
|
, rotate
|
|
, rotateRad
|
|
, scale
|
|
, blank
|
|
, color
|
|
, withAlpha
|
|
, greyN
|
|
, red
|
|
, green
|
|
, blue
|
|
, yellow
|
|
, cyan
|
|
, magenta
|
|
, rose
|
|
, violet
|
|
, azure
|
|
, aquamarine
|
|
, chartreuse
|
|
, orange
|
|
, white
|
|
, black
|
|
, dim
|
|
, light
|
|
, dark
|
|
, bright
|
|
, mixColors
|
|
, zeroZ
|
|
, setDepth
|
|
)
|
|
where
|
|
import Geometry
|
|
import Geometry.Data
|
|
|
|
import Picture.Data
|
|
|
|
import Data.Bifunctor
|
|
import qualified Data.DList as DL
|
|
|
|
import Graphics.Rendering.OpenGL (lineWidth, ($=),PrimitiveMode (..))
|
|
|
|
import Control.Lens
|
|
|
|
black :: RGBA
|
|
black = (0,0,0,1)
|
|
|
|
polygonD :: Float -> [Point2] -> Picture
|
|
{-# INLINE polygonD #-}
|
|
polygonD d (a:b:c:ps) = blank
|
|
{ _scPosTri = DL.fromList $ map (\(x,y) -> (x,y,d)) tris
|
|
, _scColTri = DL.fromList $ map (const black) tris
|
|
}
|
|
where twoPs = zip (b:c:ps) (c:ps)
|
|
tris = concatMap (\(x,y)-> [a,x,y]) twoPs
|
|
polygonD _ _ = blank
|
|
|
|
polygon :: [Point2] -> Picture
|
|
{-# INLINE polygon #-}
|
|
polygon (a:b:c:ps) = blank
|
|
{ _scPosTri = DL.fromList $ map zeroZ tris
|
|
, _scColTri = DL.fromList $ map (const black) tris
|
|
}
|
|
where twoPs = zip (b:c:ps) (c:ps)
|
|
tris = concatMap (\(x,y)-> [a,x,y]) twoPs
|
|
polygon _ = blank
|
|
|
|
color :: RGBA -> Picture -> Picture
|
|
{-# INLINE color #-}
|
|
color c = over scColTri (DL.map $ const c) . over scColChar (DL.map $ 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 = over scPosTri (DL.map $ translate3 x y) . over scPosChar (DL.map $ translate3 x y)
|
|
|
|
setDepth :: Float -> Picture -> Picture
|
|
setDepth d = over scPosTri (DL.map $ (\(x,y,z)->(x,y,d)))
|
|
. over scPosChar (DL.map $ (\(x,y,z)->(x,y,d)))
|
|
|
|
--overVs' :: (CPoint2 -> CPoint) -> Picture -> Picture
|
|
----{-# INLINE overVs' #-}
|
|
--overVs' f !(Scene a b) = let !a' = map f a
|
|
-- !b' = map g b
|
|
-- in Scene a' b'
|
|
-- where g !(x,y,z) = let !(x',y') = f (x,y)
|
|
-- in (x',y',z)
|
|
|
|
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 = over scPosTri (DL.map $ scale3 x y) . over scPosChar (DL.map $ scale3 x y)
|
|
|
|
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 = over scPosTri (DL.map $ rotate3 (0 - degToRad a))
|
|
. over scPosChar (DL.map $ rotate3 (0 - degToRad a))
|
|
|
|
-- -- this rotation uses radians, and is anticlockwise
|
|
rotateRad :: Float -> Picture -> Picture
|
|
{-# INLINE rotateRad #-}
|
|
rotateRad a = over scPosTri (DL.map $ rotate3 a)
|
|
. over scPosChar (DL.map $ rotate3 a)
|
|
|
|
pictures :: [Picture] -> Picture
|
|
{-# INLINE pictures #-}
|
|
pictures = mconcat
|
|
|
|
|
|
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.1
|
|
|
|
circleSolidD :: Float -> Float -> Picture
|
|
circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
|
|
|
|
circleSolid :: Float -> Picture
|
|
{-# INLINE circleSolid #-}
|
|
circleSolid rad = polygon $ makeArc rad (0,2*pi)
|
|
|
|
circle :: Float -> Picture
|
|
{-# INLINE circle #-}
|
|
circle rad = line $ makeArc rad (0,2*pi)
|
|
|
|
--text :: String -> Picture
|
|
--text s = zipWith (\x -> overVs $ first $ translate3 x 0)
|
|
-- [0,0.25..]
|
|
-- $ map charToShape s
|
|
|
|
text :: String -> Picture
|
|
{-# INLINE text #-}
|
|
text s = mconcat $ zipWith (\x -> translate x (0-dimText))
|
|
[0,0.9*dimText..]
|
|
(map charToScene s)
|
|
|
|
charToScene :: Char -> Picture
|
|
charToScene c = Scene
|
|
{_scPosTri = DL.empty
|
|
,_scColTri = DL.empty
|
|
,_scPosChar = DL.fromList [(0.0 ,0.0 ,0)
|
|
,(dimText,0.0 ,0)
|
|
,(dimText,dimText*2,0)
|
|
,(0.0 ,0.0 ,0)
|
|
,(dimText,dimText*2,0)
|
|
,(0.0 ,dimText*2,0)
|
|
]
|
|
,_scColChar = DL.fromList $ take 6 $ repeat white
|
|
,_scTexChar = DL.fromList $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
|
|
}
|
|
where x = 1/128
|
|
s = offset * x
|
|
e = s + x
|
|
offset = fromIntegral (fromEnum c) - 32
|
|
|
|
|
|
dimText = 100
|
|
|
|
line :: [Point2] -> Picture
|
|
{-# INLINE line #-}
|
|
line ps = thickLine ps 1
|
|
|
|
thickLine :: [Point2] -> Float -> Picture
|
|
{-# INLINE thickLine #-}
|
|
thickLine ps x = blank
|
|
|
|
thickCircle :: Float -> Float -> Picture
|
|
{-# INLINE thickCircle #-}
|
|
thickCircle rad wdth = thickLine (makeArc rad (0,2*pi)) 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 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)
|