module Graphics.PS.Path where
import Data.List
import Data.Monoid (Monoid, mappend, mconcat, mempty)
import Data.CG.Minus
import Graphics.PS.Glyph
import Graphics.PS.Font
data Path = MoveTo (Pt Double)
| LineTo (Pt Double)
| CurveTo (Pt Double) (Pt Double) (Pt Double)
| ClosePath (Pt Double)
| Text Font [Glyph]
| PTransform (Matrix Double) Path
| Join Path Path
deriving (Eq,Show)
instance Monoid Path where
mempty = MoveTo (Pt 0 0)
mappend = Join
mconcat [] = mempty
mconcat paths = combine paths
(+++) :: Path -> Path -> Path
(+++) = Join
combine :: [Path] -> Path
combine = foldl1 Join
line :: [Pt Double] -> Path
line x =
case x of
[] -> error "line: illegal data"
(p:ps) -> combine (MoveTo p : map LineTo ps)
polygon :: [Pt Double] -> Path
polygon x =
case x of
[] -> error "polygon: illegal data"
(p:ps) -> line (p:ps) +++ ClosePath p
rectangle :: Pt Double -> 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 Arc_Seg n = (Pt n,Pt n,Pt n,Pt n)
data Arc n = Arc1 (Arc_Seg n)
| Arc2 (Arc_Seg n) (Arc_Seg n)
arcp :: Pt Double -> Double -> Double -> Double -> Arc_Seg Double
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 -> Double -> Arc Double
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_to_path :: Arc Double -> Path
arc_to_path a =
case a of
Arc1 (p0,p1,p2,p3) -> MoveTo p0 +++ CurveTo p1 p2 p3
Arc2 (p0,p1,p2,p3) (_,p5,p6,p7) -> MoveTo p0 +++ CurveTo p1 p2 p3 +++ CurveTo p5 p6 p7
arca_udir :: Pt Double -> Double -> Double -> Double -> Arc Double
arca_udir c r a b =
let b' = if b < a then b + 2 * pi else b
in arca c r a b'
arcNegative_udir :: Pt Double -> Double -> Double -> Double -> Arc Double
arcNegative_udir c r a b =
let b' = if b > a then b 2 * pi else b
in arca c r b' a
arc :: Pt Double -> Double -> Double -> Double -> Path
arc c r a = arc_to_path . arca_udir c r a
arcNegative :: Pt Double -> Double -> Double -> Double -> Path
arcNegative c r a = arc_to_path . arcNegative_udir c r a
type Annular n = (Pt n,Pt n,Arc n,Pt n,Arc n)
annular_f :: Pt Double -> Double -> Double -> Double -> Double -> Annular Double
annular_f (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 (Pt x2 y2
,Pt x3 y3
,arca_udir (Pt x y) xr sa ea
,Pt x4 y4
,arcNegative_udir (Pt x y) ir ea sa)
annular :: Pt Double -> Double -> Double -> Double -> Double -> Path
annular c ir xr sa a =
let (p1,p2,a1,p3,a2) = annular_f c ir xr sa a
in combine [MoveTo p1,LineTo p2,arc_to_path a1,LineTo p3,arc_to_path a2]
flatten_f :: Matrix Double -> Path -> Path
flatten_f m path =
case path of
MoveTo p -> MoveTo (pt_transform m p)
LineTo p -> LineTo (pt_transform m p)
ClosePath p -> ClosePath (pt_transform m p)
PTransform m' p -> flatten_f (m' * m) p
Join a b -> Join (flatten_f m a) (flatten_f m b)
CurveTo p q r -> let f = pt_transform m
in CurveTo (f p) (f q) (f r)
Text _ _ -> error "cannot flatten text"
flatten :: Path -> Path
flatten = flatten_f mx_identity
renderLines :: [Ln Double] -> Path
renderLines =
let f pth (Ln p1 p2) = pth +++ MoveTo p1 +++ LineTo p2
in foldl f (MoveTo pt_origin)
renderLines_jn :: [Ln Double] -> Path
renderLines_jn =
let g p (Ln a b) = if p == a
then (b,Right b)
else (b,Left (Ln a b))
f path e = case e of
Left (Ln p1 p2) -> path +++ MoveTo p1 +++ LineTo p2
Right p2 -> path +++ LineTo p2
in foldl f (MoveTo pt_origin) . snd . mapAccumL g pt_origin