module Graphics.PS.Path ( Path(..), (+++)
, line, polygon, rectangle
, arc, arcNegative, annular
, flatten ) where
import Graphics.PS.Pt
import Graphics.PS.Matrix
import Graphics.PS.Glyph
import Graphics.PS.Font
data Path = MoveTo Pt
| LineTo Pt
| CurveTo Pt Pt Pt
| Text Font [Glyph]
| PTransform Matrix Path
| Join Path Path
deriving (Eq, Show)
(+++) :: Path -> Path -> Path
(+++) = Join
combine :: [Path] -> Path
combine = foldl1 Join
line :: [Pt] -> Path
line (p:ps) = combine (MoveTo p : map LineTo ps)
line _ = error "line: illegal data"
polygon :: [Pt] -> Path
polygon (p:ps) = line (p:ps) `Join` LineTo p
polygon _ = error "polygon: illegal data"
rectangle :: Pt -> Double -> Double -> Path
rectangle (Pt x y) w h =
let ll = Pt x y
lr = Pt (x + w) y
ur = Pt (x + w) (y + h)
ul = Pt x (y + h)
in polygon [ll, lr, ur, ul]
type ArcP = (Pt, Pt, Pt, Pt)
data Arc = Arc1 ArcP
| Arc2 ArcP ArcP
arcp :: Pt -> Double -> Double -> Double -> ArcP
arcp (Pt x y) r a b =
let ca = cos a
sa = sin a
cb = cos b
sb = sin b
bcp = 4 / 3 * (1 cos ((b a) / 2)) / sin ((b a) / 2)
p0 = Pt (x + r * ca) (y + r * sa)
p1 = Pt (x + r * (ca bcp * sa)) (y + r * (sa + bcp * ca))
p2 = Pt (x + r * (cb + bcp * sb)) (y + r * (sb bcp * cb))
p3 = Pt (x + r * cb) (y + r * sb)
in (p0, p1, p2, p3)
arca :: Pt -> Double -> Double -> Double -> Arc
arca c r a b =
let d = abs (b a)
b' = b (d / 2)
in if d > pi
then Arc2 (arcp c r a b') (arcp c r b' b)
else Arc1 (arcp c r a b)
arc' :: Arc -> Path
arc' (Arc1 (p0, p1, p2, p3)) =
let m = MoveTo p0
c = CurveTo p1 p2 p3
in m `Join` c
arc' (Arc2 (p0, p1, p2, p3) (_, p5, p6, p7)) =
let m = MoveTo p0
c1 = CurveTo p1 p2 p3
c2 = CurveTo p5 p6 p7
in m `Join` c1 `Join` c2
arc :: Pt -> Double -> Double -> Double -> Path
arc c r a b =
let f n = if n < a then f (n + 2 * pi) else n
in arc' (arca c r a (f b))
arcNegative :: Pt -> Double -> Double -> Double -> Path
arcNegative c r a b =
let f n = if n > a then f (n 2 * pi) else n
in arc' (arca c r (f b) a)
annular :: Pt -> Double -> Double -> Double -> Double -> Path
annular (Pt x y) ir xr sa a =
let ea = sa + a
x2 = x + ir * cos sa
y2 = y + ir * sin sa
x3 = x + xr * cos sa
y3 = y + xr * sin sa
x4 = x + ir * cos ea
y4 = y + ir * sin ea
in combine [MoveTo (Pt x2 y2)
,LineTo (Pt x3 y3)
,arc (Pt x y) xr sa ea
,LineTo (Pt x4 y4)
,arcNegative (Pt x y) ir ea sa]
flatten' :: Matrix -> Path -> Path
flatten' m (MoveTo p) = MoveTo (ptTransform m p)
flatten' m (LineTo p) = LineTo (ptTransform m p)
flatten' m (PTransform m' p) = flatten' (m' * m) p
flatten' m (Join a b) = Join (flatten' m a) (flatten' m b)
flatten' m (CurveTo p q r) =
let f = ptTransform m
in CurveTo (f p) (f q) (f r)
flatten' _ (Text _ _) = error "cannot flatten text"
flatten :: Path -> Path
flatten = flatten' identity