344 lines
9.0 KiB
Haskell
344 lines
9.0 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Picture.Base (
|
|
module Picture.Data,
|
|
module Picture.Arc,
|
|
module Color,
|
|
blank,
|
|
polygon,
|
|
polygonWire,
|
|
polygonCol,
|
|
poly3,
|
|
poly3Col,
|
|
arc,
|
|
arcSolid,
|
|
thickArc,
|
|
--thickArcFull,
|
|
thickCircle,
|
|
thickLine,
|
|
lineThick,
|
|
thickLineCol,
|
|
circleSolid,
|
|
circleSolidCol,
|
|
circle,
|
|
line,
|
|
lineCol,
|
|
text,
|
|
textRight,
|
|
textJustifyLeft,
|
|
textJustifyRight,
|
|
textJustifyCenter,
|
|
textVMirror,
|
|
drawText,
|
|
centerText,
|
|
stackText,
|
|
tranRot,
|
|
translate,
|
|
translate3,
|
|
rotate,
|
|
scale,
|
|
color,
|
|
zeroZ,
|
|
setDepth,
|
|
addDepth,
|
|
setLayer,
|
|
mirroryz,
|
|
mirrorxz,
|
|
overPos,
|
|
picMap,
|
|
fold,
|
|
) where
|
|
|
|
import Color
|
|
import Data.Foldable
|
|
import Geometry
|
|
import Picture.Arc
|
|
import Picture.Data
|
|
|
|
blank :: Picture
|
|
{-# INLINE blank #-}
|
|
blank = mempty
|
|
|
|
polygonWire :: [Point2] -> Picture
|
|
{-# INLINE polygonWire #-}
|
|
polygonWire ps = line (ps ++ [head ps])
|
|
|
|
picMap :: (Verx -> Verx) -> Picture -> Picture
|
|
{-# INLINE picMap #-}
|
|
picMap = map
|
|
|
|
-- | Expects clockwise input.
|
|
polygon :: [Point2] -> Picture
|
|
{-# INLINE polygon #-}
|
|
polygon = map f . polyToTris
|
|
where
|
|
f (V2 x y) = Verx (V3 x y 0) black [] minBound PolyShad
|
|
|
|
polygonCol :: [(Point2, RGBA)] -> Picture
|
|
{-# INLINE polygonCol #-}
|
|
polygonCol = polyToTris . map f
|
|
where
|
|
f (V2 x y, col) = Verx (V3 x y 0) col [] minBound PolyShad
|
|
|
|
poly3 :: [Point3] -> Picture
|
|
{-# INLINE poly3 #-}
|
|
poly3 = poly3Col . map (,black)
|
|
|
|
poly3Col :: [(Point3, RGBA)] -> Picture
|
|
{-# INLINE poly3Col #-}
|
|
poly3Col = map f . polyToTris
|
|
where
|
|
f (pos, col) = Verx pos col [] minBound PolyShad
|
|
|
|
---- 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 (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 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 = picMap . overCol . const
|
|
|
|
translateH :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE translateH #-}
|
|
translateH !a !b (V3 x y z) = V3 (x + a) (y + b) z
|
|
|
|
translate :: Float -> Float -> Picture -> Picture
|
|
{-# INLINE translate #-}
|
|
translate x = picMap . overPos . translateH x
|
|
|
|
translate3 :: Point3 -> Picture -> Picture
|
|
{-# INLINE translate3 #-}
|
|
translate3 = picMap . overPos . (+.+.+)
|
|
|
|
tranRot :: V2 Float -> Float -> Picture -> Picture
|
|
{-# INLINE tranRot #-}
|
|
tranRot (V2 x y) r = picMap $ overPos (translateH x y . rotate3 r)
|
|
|
|
setDepth :: Float -> Picture -> Picture
|
|
{-# INLINE setDepth #-}
|
|
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
|
|
setDepth d = picMap $ overPos (\(V3 x y _) -> V3 x y d)
|
|
|
|
addDepth :: Float -> Picture -> Picture
|
|
{-# INLINE addDepth #-}
|
|
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
|
|
addDepth d = picMap $ overPos (\(V3 x y z) -> V3 x y (z + d))
|
|
|
|
-- TODO change the Int here to a dedicated type
|
|
setLayer :: Layer -> Picture -> Picture
|
|
{-# INLINE setLayer #-}
|
|
setLayer i = picMap f
|
|
where
|
|
f v = v{_vxLayer = i}
|
|
|
|
scale3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE scale3 #-}
|
|
scale3 a b (V3 x y z) = V3 (x * a) (y * b) z
|
|
|
|
scale :: Float -> Float -> Picture -> Picture
|
|
{-# INLINE scale #-}
|
|
scale x = picMap . overPos . scale3 x
|
|
|
|
rotate :: Float -> Picture -> Picture
|
|
{-# INLINE rotate #-}
|
|
rotate = picMap . overPos . rotate3
|
|
|
|
makeArc :: Float -> Point2 -> [Point2]
|
|
{-# INLINE makeArc #-}
|
|
makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
|
|
where
|
|
angles = [a, a + step .. b]
|
|
step = pi * 0.2
|
|
|
|
circleSolid :: Float -> Picture
|
|
{-# INLINE circleSolid #-}
|
|
circleSolid = circleSolidCol white white
|
|
|
|
circleSolidCol :: Color -> Color -> Float -> Picture
|
|
{-# INLINE circleSolidCol #-}
|
|
circleSolidCol colC colE r =
|
|
map
|
|
f
|
|
[ (V3 (- r) r 0, colC)
|
|
, (V3 (- r) (- r) 0, colE)
|
|
, (V3 r (- r) 0, black)
|
|
]
|
|
where
|
|
f (pos, col) = Verx pos col [] minBound EllShad
|
|
|
|
circle :: Float -> Picture
|
|
{-# INLINE circle #-}
|
|
circle rad = thickArc 0 (2 * pi) rad 1
|
|
|
|
centerText :: String -> Picture
|
|
{-# INLINE centerText #-}
|
|
centerText s = translate (25 + 50 * (negate . fromIntegral $ length s - 1)) 0 $ text s
|
|
|
|
stackText :: [String] -> Picture
|
|
{-# INLINE stackText #-}
|
|
stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..]
|
|
|
|
-- character size 100 x 200, no gaps between
|
|
text :: String -> Picture
|
|
{-# INLINE text #-}
|
|
text = drawText 0
|
|
|
|
-- lines up the rightmost part of the last character with 0
|
|
textJustifyRight :: String -> Picture
|
|
{-# INLINE textJustifyRight #-}
|
|
textJustifyRight str = translate (12.5 + (-100) * fromIntegral (length str)) 0 $ text str
|
|
|
|
-- translate the text so its bottom right coordinate is at (0,0)
|
|
textRight :: String -> Picture
|
|
{-# INLINE textRight #-}
|
|
textRight str = translate ((-100) * fromIntegral (length str)) 0 $ text str
|
|
|
|
-- lines up the leftmost part of the first character with 0
|
|
textJustifyLeft :: String -> Picture
|
|
{-# INLINE textJustifyLeft #-}
|
|
textJustifyLeft = translate (-12.5) 0 . text
|
|
|
|
textJustifyCenter :: String -> Picture
|
|
{-# INLINE textJustifyCenter #-}
|
|
textJustifyCenter str = translate ((-50) * fromIntegral (length str)) 0 $ text str
|
|
|
|
textVMirror :: String -> Picture
|
|
{-# INLINE textVMirror #-}
|
|
textVMirror = translate 0 200 . scale 1 (-1) . text
|
|
|
|
drawText :: Float -> String -> [Verx]
|
|
{-# INLINE drawText #-}
|
|
drawText gap = map f . stringToList gap
|
|
where
|
|
f (pos, col, V3 a b c) = Verx pos col [a, b, c, 1] minBound TextShad
|
|
|
|
line :: [Point2] -> Picture
|
|
{-# INLINE line #-}
|
|
line = thickLine 1
|
|
|
|
lineCol :: [(Point2, RGBA)] -> Picture
|
|
{-# INLINE lineCol #-}
|
|
lineCol = thickLineCol 1
|
|
|
|
lineThick :: Float -> [Point2] -> Picture
|
|
{-# INLINE lineThick #-}
|
|
lineThick t = fold . f
|
|
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))
|
|
|
|
thickLine :: Float -> [Point2] -> Picture
|
|
{-# INLINE thickLine #-}
|
|
thickLine t = fold . f
|
|
where
|
|
f (x : y : ys)
|
|
| x == y = f (x : ys)
|
|
| otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y : ys)
|
|
where
|
|
n = (t * 0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
|
|
f _ = []
|
|
|
|
thickLineCol :: Float -> [(Point2, RGBA)] -> Picture
|
|
{-# INLINE thickLineCol #-}
|
|
thickLineCol t = fold . f
|
|
where
|
|
f ((x, c) : (y, c') : ys)
|
|
| x == y = f ((x, c) : ys)
|
|
| otherwise =
|
|
polygonCol
|
|
[ (x +.+ n x y, c)
|
|
, (x -.- n x y, c)
|
|
, (y -.- n x y, c')
|
|
, (y +.+ n x y, c')
|
|
] :
|
|
f ((y, c') : ys)
|
|
f _ = []
|
|
n a b = (t * 0.5) *.* squashNormalizeV (vNormal (a -.- b))
|
|
|
|
thickCircle :: Float -> Float -> Picture
|
|
{-# INLINE thickCircle #-}
|
|
thickCircle = thickArc 0 (2 * pi)
|
|
|
|
arcSolid ::
|
|
-- | Start angle
|
|
Float ->
|
|
-- | End angle
|
|
Float ->
|
|
-- | Radius
|
|
Float ->
|
|
Picture
|
|
{-# INLINE arcSolid #-}
|
|
arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)
|
|
|
|
arc ::
|
|
-- | Start angle
|
|
Float ->
|
|
-- | End angle
|
|
Float ->
|
|
-- | Radius
|
|
Float ->
|
|
Picture
|
|
arc startA endA rad = thickArc startA endA rad 1
|
|
{-# INLINE arc #-}
|
|
|
|
thickArc :: Float -> Float -> Float -> Float -> Picture
|
|
{-# INLINE thickArc #-}
|
|
thickArc startA endA rad wdth = arcFull startA wdth white endA wdth white rad white
|
|
|
|
-- Currently the lens version is much slower
|
|
overPos :: (Point3 -> Point3) -> Verx -> Verx
|
|
{-# INLINE overPos #-}
|
|
--overPos = over vxPos
|
|
overPos f vx = vx{_vxPos = f (_vxPos vx)}
|
|
|
|
overCol :: (Point4 -> Point4) -> Verx -> Verx
|
|
{-# INLINE overCol #-}
|
|
overCol f vx = vx{_vxCol = f (_vxCol vx)}
|
|
|
|
-- no premature optimisation, consider changing to use texture arrays
|
|
stringToList :: Float -> String -> [(Point3, Point4, Point3)]
|
|
{-# INLINE stringToList #-}
|
|
stringToList gap = concatMap (uncurry charToTuple) . zip [0, 100 + gap ..]
|
|
|
|
charToTuple :: Float -> Char -> [(Point3, Point4, Point3)]
|
|
{-# INLINE charToTuple #-}
|
|
charToTuple xoff c
|
|
| fromEnum c == 32 = [] -- don't draw space characters
|
|
| otherwise = [f 0 0, f 1 0, f 1 1, f 0 0, f 1 1, f 0 1]
|
|
where
|
|
f x y = (V3 (xoff + x * 100) (y * 200) 0, white, V3 x (1 - y) charnum)
|
|
-- textures in opengl have origins at the lower left, my char array has its
|
|
-- origin at the upper left
|
|
charnum = fromIntegral (fromEnum c) -- - 32
|
|
|
|
--charToTuple' :: Float -> Char -> [(Point3, Point4, Point3)]
|
|
--{-# INLINE charToTuple' #-}
|
|
--charToTuple' xoff c = [f 0 0, f 1 0, f 1 1, f 0 0, f 1 1, f 0 1]
|
|
-- where
|
|
-- f x y = (V3 (xoff + x * 100) (y * 200) 0, white, V3 x y offset)
|
|
-- offset = fromIntegral (fromEnum c) - 32
|
|
|
|
mirrorxz :: Picture -> Picture
|
|
mirrorxz = picMap (overPos flipy)
|
|
where
|
|
flipy (V3 x y z) = V3 x (negate y) z
|
|
|
|
mirroryz :: Picture -> Picture
|
|
mirroryz = picMap (overPos flipx)
|
|
where
|
|
flipx (V3 x y z) = V3 (negate x) y z
|