305 lines
7.7 KiB
Haskell
305 lines
7.7 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
|
|
, 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, ($=))
|
|
|
|
import Control.Lens
|
|
|
|
black :: RGBA
|
|
black = (0,0,0,1)
|
|
|
|
--polygonD :: Float -> [Point2] -> Picture
|
|
--{-# INLINE polygonD #-}
|
|
--polygonD d (a:b:c:ps) = blank
|
|
-- { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
|
|
-- , _scColTri = mapVC (const black) tris
|
|
-- }
|
|
-- where twoPs = zip (b:c:ps) (c:ps)
|
|
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
|
|
--polygonD _ _ = blank
|
|
|
|
polygon :: [Point2] -> Picture
|
|
{-# INLINE polygon #-}
|
|
polygon = Polygon
|
|
|
|
--polygon :: [Point2] -> Picture
|
|
--{-# INLINE polygon #-}
|
|
--polygon (a:b:c:ps) = NLeaf $ emptyScene
|
|
-- { _scPosTri = fmap zeroZ tris
|
|
-- , _scColTri = fmap (const black) tris
|
|
-- }
|
|
-- where twoPs = zip (b:c:ps) (c:ps)
|
|
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
|
|
--polygon _ = blank
|
|
|
|
color' :: RGBA -> Scene -> Scene
|
|
{-# INLINE color' #-}
|
|
color' c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
|
|
pic {_scColTri = mapVC (const c) colTri
|
|
,_scColChar = mapVC (const c) colChar
|
|
}
|
|
color :: RGBA -> Picture -> Picture
|
|
{-# INLINE color #-}
|
|
color c pic = Color c pic
|
|
|
|
overPos :: (Point3 -> Point3) -> Scene -> Scene
|
|
{-# INLINE overPos #-}
|
|
overPos f pic@(Scene {_scPosTri = posTri,_scPosChar= posChar}) =
|
|
pic {_scPosTri = mapVC f posTri
|
|
,_scPosChar = mapVC f posChar
|
|
}
|
|
|
|
translate3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE translate3 #-}
|
|
translate3 a b (x,y,z) = (x+a,y+b,z)
|
|
|
|
translate' :: Float -> Float -> Scene -> Scene
|
|
{-# INLINE translate' #-}
|
|
--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
|
|
translate' x y = overPos $ translate3 x y
|
|
|
|
translate :: Float -> Float -> Picture -> Picture
|
|
{-# INLINE translate #-}
|
|
translate x y pic = Translate x y pic
|
|
|
|
setDepth' :: Float -> Scene -> Scene
|
|
{-# INLINE setDepth' #-}
|
|
setDepth' d = overPos $ \(x,y,z) -> (x,y,d)
|
|
|
|
setDepth :: Float -> Picture -> Picture
|
|
{-# INLINE setDepth #-}
|
|
setDepth d pic = SetDepth d pic
|
|
|
|
scale3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE scale3 #-}
|
|
scale3 a b (x,y,z) = (x*a,y*b,z)
|
|
|
|
scale' :: Float -> Float -> Scene -> Scene
|
|
{-# INLINE scale' #-}
|
|
--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
|
|
scale' x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
|
|
|
|
scale :: Float -> Float -> Picture -> Picture
|
|
{-# INLINE scale #-}
|
|
scale x y pic = Scale x y pic
|
|
|
|
rotate3 :: Float -> Point3 -> Point3
|
|
{-# INLINE rotate3 #-}
|
|
rotate3 a (x,y,z) = (x',y',z)
|
|
where (x',y') = rotateV a (x,y)
|
|
|
|
rotate' :: Float -> Scene -> Scene
|
|
{-# INLINE rotate' #-}
|
|
rotate' a = overPos $ rotate3 $ 0 - degToRad a
|
|
|
|
--rotate :: Float -> Picture -> Picture
|
|
--{-# INLINE rotate #-}
|
|
--rotate a pic = NBranch (rotate' a) pic
|
|
--
|
|
---- -- this rotation uses radians, and is anticlockwise
|
|
--rotateRad' :: Float -> Scene -> Scene
|
|
--{-# INLINE rotateRad' #-}
|
|
--rotateRad' a = overPos $ rotate3 a
|
|
--
|
|
--rotateRad :: Float -> Picture -> Picture
|
|
--{-# INLINE rotateRad #-}
|
|
--rotateRad a pic = NBranch (rotateRad' a) pic
|
|
|
|
rotate a = rotateRad (0 - degToRad a)
|
|
{-# INLINE rotate #-}
|
|
|
|
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
|
|
|
|
--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 = Text
|
|
|
|
----text :: String -> Picture
|
|
----{-# INLINE text #-}
|
|
----text s = pictures $ zipWith (\x -> translate x (0-dimText))
|
|
---- [0,0.9*dimText..]
|
|
---- (map charToScene s)
|
|
----
|
|
----charToScene :: Char -> Picture
|
|
----charToScene c = NLeaf $ Scene
|
|
---- {_scPosTri = mempty
|
|
---- ,_scColTri = mempty
|
|
---- ,_scPosChar = toVC [(0.0,0.0,0)]
|
|
---- ,_scColChar = toVC [white]
|
|
---- ,_scTexChar = toVC [(offset,100)]
|
|
---- }
|
|
---- where x = 1/128
|
|
---- s = offset * x
|
|
---- offset = fromIntegral (fromEnum c) - 32
|
|
--charToScene :: Char -> Picture
|
|
--charToScene c = Scene
|
|
-- {_scPosTri = mempty
|
|
-- ,_scColTri = mempty
|
|
-- ,_scPosChar = toVC [(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 = toVC $ take 6 $ repeat white
|
|
-- ,_scTexChar = toVC $ [(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)
|
|
|
|
|
|
--zeroZ :: Point2 -> Point3
|
|
--{-# INLINE zeroZ #-}
|
|
--zeroZ (x,y) = (x,y,0)
|
|
|