justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity
Files
901fab762a9765d61447c782862bf578eae2166a
loop/src/Picture.hs
T

361 lines
10 KiB
Haskell
Raw Blame History

{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
module Picture
( module Picture.Data
, module Color
, blank
, polygon
, polygonWire
, polygonZ
, polygonCol
, poly3
, poly3Col
, bezierQuad
, arc
, arcSolid
, thickArc
, thickCircle
, thickLine
, lineThick
, thickLineCol
, circleSolid
, circleSolidCol
, circle
, line
, lineCol
, text
, centerText
, stackText
, pictures
, concatMapPic
, appendPic
, tranRot
, translate
, translate3
, rotate
, scale
, color
, zeroZ
, setDepth
, addDepth
, setLayer
)
where
import Geometry
import Picture.Data
import Color
blank :: Picture
{-# INLINE blank #-}
blank = []
polygonWire :: [Point2] -> Picture
{-# INLINE polygonWire #-}
polygonWire ps = line (ps ++ [head ps])
polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon = map f . polyToTris
where
f (V2 x y) = Verx (V3 x y 0) black [] (LayNum 0) polyNum
polygonZ :: [Point2] -> Float -> Picture
{-# INLINE polygonZ #-}
polygonZ ps z = map (f . zeroZ) $ polyToTris ps
where
f pos = Verx pos black [z] (LayNum 0) polyzNum
polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = polyToTris . map f
where
f (V2 x y,col) = Verx (V3 x y 0) col [] (LayNum 0) polyNum
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 [] (LayNum 0) polyNum
-- note that much of work computing the width of the bezier curve is done here
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
bezierQuad cola colc ra rc a b c
| a == b && b == c = blank
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
| otherwise = bzhelp
[(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 )
,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 )
,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0 1 )
,( aX, cola, V2 1 0 , V2 (fa' aX) (fc' aX) )
,( cX, colc, V2 0 1 , V2 (fa' cX) (fc' cX) )
,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) )
,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) )
]
where
colb = mixColors 0.5 0.5 cola colc
b2a | isLHS a b c = a -.- b
| otherwise = b -.- a
aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
aX = a -.- aRadVec
aIn = a +.+ aRadVec
b2c | isLHS a b c = b -.- c
| otherwise = c -.- b
cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
cX = c -.- cRadVec
cIn = c +.+ cRadVec
bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
bX = b +.+ bRadVec
bIn = b -.- bRadVec
fa = extrapolate aX cX bX
fc = extrapolate cX aX bX
fa' = extrapolate aIn cIn bIn
fc' = extrapolate cIn aIn bIn
bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = map f
where
f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] (LayNum 0) bezNum
-- 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 c = map $ overCol (const c)
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 = map . overPos . translateH x
translate3 :: Point3 -> Picture -> Picture
{-# INLINE translate3 #-}
translate3 = map . overPos . (+.+.+)
tranRot :: V2 Float -> Float -> Picture -> Picture
{-# INLINE tranRot #-}
tranRot (V2 x y) r = map $ overPos (translateH x y . rotate3 r)
setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
setDepth d = map $ 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 = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
-- TODO change the Int here to a dedicated type
setLayer :: Int -> Picture -> Picture
{-# INLINE setLayer #-}
setLayer i = map f
where
f v = v {_vxLayer = LayNum 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 = map . overPos . scale3 x
rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
rotate = map . overPos . rotate3
concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture
{-# INLINE concatMapPic #-}
concatMapPic = concatMap
appendPic :: Picture -> Picture -> Picture
{-# INLINE appendPic #-}
appendPic = (++)
pictures :: Foldable t => t Picture -> Picture
{-# INLINABLE pictures #-}
pictures = concat
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 [] (LayNum 0) ellNum
circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = thickArc 0 (2*pi) rad 1
centerText :: String -> Picture
{-# INLINE centerText #-}
centerText s = translate (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..]
text :: String -> Picture
{-# INLINE text #-}
text = map f . stringToList
where
f (pos,col,V2 a b) = Verx pos col [a,b] (LayNum 0) textNum
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 = pictures . 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 = pictures . 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 = pictures . 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
:: Float -- ^ Start angle
-> Float -- ^ End angle
-> Float -- ^ Radius
-> Picture
{-# INLINE arcSolid #-}
arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)
arc
:: Float -- ^ Start angle
-> Float -- ^ End angle
-> Float -- ^ Radius
-> 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
| endA - startA > (pi/ 2) = pictures
[ thickArc (startA + pi/2) endA rad wdth
, thickArcHelp startA (startA + pi/2) r w
]
| otherwise = thickArcHelp startA endA r w
where
r = rad + 0.5 * wdth
w = 1 - wdth / r
thickArcHelp :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArcHelp #-}
thickArcHelp startA endA rad wdth = map f
[ (V3 0 0 0,black,V3 0 0 wdth)
,(V3 xa ya 0,black,V3 1 0 wdth)
,(V3 xb yb 0,black,V3 1 1 wdth)
, (V3 0 0 0,black,V3 0 0 wdth)
,(V3 xb yb 0,black,V3 1 1 wdth)
,(V3 xc yc 0,black,V3 0 1 wdth)
]
where
(V2 xa ya) = rotateV startA (V2 rad 0)
(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
--(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0)
(V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,V3 a b c) = Verx pos col [a,b,c] (LayNum 0) arcNum
-- 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 :: String -> [(Point3,Point4,Point2)]
{-# INLINE stringToList #-}
stringToList = concatMap (uncurry charToTuple) . zip [0,0.9*dimText ..]
where
dimText = 100
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
{-# INLINE charToTuple #-}
charToTuple x c =
[(V3 (x-50) (-100) 0, white,V2 offset 1)
,(V3 (x-50) 100 0, white,V2 offset 0)
,(V3 (x+50) 100 0, white,V2 (offset+1) 0)
,(V3 (x-50) (-100) 0, white,V2 offset 1)
,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1)
,(V3 (x+50) 100 0, white,V2 (offset+1) 0)
]
where
offset = fromIntegral (fromEnum c) - 32
Reference in New Issue View Git Blame Copy Permalink