Add source files, commit before reverting pictures to lists
This commit is contained in:
+249
@@ -0,0 +1,249 @@
|
||||
--{-# 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)
|
||||
Reference in New Issue
Block a user