Resplit Picture
This commit is contained in:
+6
-366
@@ -1,373 +1,13 @@
|
|||||||
{-# LANGUAGE TupleSections #-}
|
--{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE BangPatterns #-}
|
--{-# LANGUAGE BangPatterns #-}
|
||||||
module Picture
|
module Picture
|
||||||
( module Picture.Data
|
( module Picture.Data
|
||||||
|
, module Picture.Base
|
||||||
|
, module Picture.Composite
|
||||||
, module Color
|
, 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
|
|
||||||
, mirroryz
|
|
||||||
, mirrorxz
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
import Geometry
|
|
||||||
import Picture.Data
|
import Picture.Data
|
||||||
|
import Picture.Base
|
||||||
|
import Picture.Composite
|
||||||
import Color
|
import Color
|
||||||
|
|
||||||
blank :: Picture
|
|
||||||
{-# INLINE blank #-}
|
|
||||||
blank = []
|
|
||||||
|
|
||||||
polygonWire :: [Point2] -> Picture
|
|
||||||
{-# INLINE polygonWire #-}
|
|
||||||
polygonWire ps = line (ps ++ [head ps])
|
|
||||||
|
|
||||||
-- | Expects clockwise input.
|
|
||||||
polygon :: [Point2] -> Picture
|
|
||||||
{-# INLINE polygon #-}
|
|
||||||
polygon = map f . polyToTris
|
|
||||||
where
|
|
||||||
f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
|
|
||||||
|
|
||||||
polygonZ :: [Point2] -> Float -> Picture
|
|
||||||
{-# INLINE polygonZ #-}
|
|
||||||
polygonZ ps z = map (f . zeroZ) $ polyToTris ps
|
|
||||||
where
|
|
||||||
f pos = Verx pos black [z] BottomLayer polyzNum
|
|
||||||
|
|
||||||
polygonCol :: [(Point2,RGBA)] -> Picture
|
|
||||||
{-# INLINE polygonCol #-}
|
|
||||||
polygonCol = polyToTris . map f
|
|
||||||
where
|
|
||||||
f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer 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 [] BottomLayer 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] BottomLayer 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 :: Layer -> Picture -> Picture
|
|
||||||
{-# INLINE setLayer #-}
|
|
||||||
setLayer i = map 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 = 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 [] BottomLayer 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] BottomLayer 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] BottomLayer 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
|
|
||||||
|
|
||||||
mirrorxz :: Picture -> Picture
|
|
||||||
mirrorxz = map (overPos flipy)
|
|
||||||
where
|
|
||||||
flipy (V3 x y z) = V3 x (negate y) z
|
|
||||||
|
|
||||||
mirroryz :: Picture -> Picture
|
|
||||||
mirroryz = map (overPos flipx)
|
|
||||||
where
|
|
||||||
flipx (V3 x y z) = V3 (negate x) y z
|
|
||||||
|
|||||||
@@ -0,0 +1,373 @@
|
|||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
module Picture.Base
|
||||||
|
( 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
|
||||||
|
, mirroryz
|
||||||
|
, mirrorxz
|
||||||
|
)
|
||||||
|
where
|
||||||
|
import Geometry
|
||||||
|
import Picture.Data
|
||||||
|
import Color
|
||||||
|
|
||||||
|
blank :: Picture
|
||||||
|
{-# INLINE blank #-}
|
||||||
|
blank = []
|
||||||
|
|
||||||
|
polygonWire :: [Point2] -> Picture
|
||||||
|
{-# INLINE polygonWire #-}
|
||||||
|
polygonWire ps = line (ps ++ [head ps])
|
||||||
|
|
||||||
|
-- | Expects clockwise input.
|
||||||
|
polygon :: [Point2] -> Picture
|
||||||
|
{-# INLINE polygon #-}
|
||||||
|
polygon = map f . polyToTris
|
||||||
|
where
|
||||||
|
f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
|
||||||
|
|
||||||
|
polygonZ :: [Point2] -> Float -> Picture
|
||||||
|
{-# INLINE polygonZ #-}
|
||||||
|
polygonZ ps z = map (f . zeroZ) $ polyToTris ps
|
||||||
|
where
|
||||||
|
f pos = Verx pos black [z] BottomLayer polyzNum
|
||||||
|
|
||||||
|
polygonCol :: [(Point2,RGBA)] -> Picture
|
||||||
|
{-# INLINE polygonCol #-}
|
||||||
|
polygonCol = polyToTris . map f
|
||||||
|
where
|
||||||
|
f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer 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 [] BottomLayer 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] BottomLayer 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 :: Layer -> Picture -> Picture
|
||||||
|
{-# INLINE setLayer #-}
|
||||||
|
setLayer i = map 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 = 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 [] BottomLayer 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] BottomLayer 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] BottomLayer 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
|
||||||
|
|
||||||
|
mirrorxz :: Picture -> Picture
|
||||||
|
mirrorxz = map (overPos flipy)
|
||||||
|
where
|
||||||
|
flipy (V3 x y z) = V3 x (negate y) z
|
||||||
|
|
||||||
|
mirroryz :: Picture -> Picture
|
||||||
|
mirroryz = map (overPos flipx)
|
||||||
|
where
|
||||||
|
flipx (V3 x y z) = V3 (negate x) y z
|
||||||
@@ -0,0 +1,16 @@
|
|||||||
|
module Picture.Composite where
|
||||||
|
import Picture.Data
|
||||||
|
import Picture.Base
|
||||||
|
import Geometry
|
||||||
|
--import Color
|
||||||
|
|
||||||
|
arrowPath :: [Point2] -> Picture
|
||||||
|
arrowPath xs = mconcat $ zipWith arrow xs $ tail xs
|
||||||
|
|
||||||
|
arrow :: Point2 -> Point2 -> Picture
|
||||||
|
arrow a b = line [a,b]
|
||||||
|
<> line [b +.+ n -.- v,b]
|
||||||
|
<> line [b -.- n -.- v,b]
|
||||||
|
where
|
||||||
|
v = 5 *.* normalizeV (b -.- a)
|
||||||
|
n = vNormal v
|
||||||
Reference in New Issue
Block a user