Path.hs

-- | Path type and functions.
module Graphics.PS.Path (Path(..),(+++)
                        ,line,polygon,rectangle
                        ,arc,arcNegative,annular
                        ,flatten
                        ,renderLines,renderLines') where

import Data.List
import Graphics.PS.Pt
import Graphics.PS.Matrix
import Graphics.PS.Glyph
import Graphics.PS.Font

-- | Path data type,in cartesian space.
data Path = MoveTo Pt
          | LineTo Pt
          | CurveTo Pt Pt Pt
          | ClosePath Pt
          | Text Font [Glyph]
          | PTransform Matrix Path
          | Join Path Path
            deriving (Eq,Show)

-- | Infix notation for 'Join'.
(+++) :: Path -> Path -> Path
(+++) = Join

-- | Left fold of 'Join'.
combine :: [Path] -> Path
combine = foldl1 Join

-- | Line segments though list of 'Pt'.
line :: [Pt] -> Path
line x =
    case x of
      [] -> error "line: illegal data"
      (p:ps) -> combine (MoveTo p : map LineTo ps)

-- | Variant of 'line' connecting the last 'Pt' to the first.
polygon :: [Pt] -> Path
polygon x =
    case x of
      [] -> error "polygon: illegal data"
      (p:ps) -> line (p:ps) +++ ClosePath p

-- | Rectangle with lower left at 'Pt' and of specified width and
-- height.  Polygon is oredered anticlockwise from lower left.
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

-- (x,y) = center,r = radius,a = start angle,b = end angle
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)

-- c = center,r = radius,a = start angle,b = end angle
-- if the arc angle is greater than pi the arc must be drawn in two
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 +++ 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 +++ c1 +++ c2

-- | Arc given by a central point,a radius,and start and end angles.
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))

-- | Negative arc.
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)

-- (x,y) = center,ir = inner radius,xr = outer radius,sa = start
-- angle,a = angle,ea = end angle

-- | Annular segment.
annular :: Pt -> Double -> Double -> Double -> Double -> Path
annular (Pt x y) ir xr sa a =
    let ea = sa + a
        x2 = x + ir * cos sa -- ll
        y2 = y + ir * sin sa
        x3 = x + xr * cos sa -- ul
        y3 = y + xr * sin sa
        x4 = x + ir * cos ea -- lr
        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 path =
    case path of
      MoveTo p -> MoveTo (ptTransform m p)
      LineTo p -> LineTo (ptTransform m p)
      ClosePath p -> ClosePath (ptTransform m p)
      PTransform m' p -> flatten' (m' * m) p
      Join a b -> Join (flatten' m a) (flatten' m b)
      CurveTo p q r -> let f = ptTransform m
                       in CurveTo (f p) (f q) (f r)
      Text _ _ -> error "cannot flatten text"

-- | Apply any transformations at path.  The resulting path will not
--   have any 'PTransform' nodes.
flatten :: Path -> Path
flatten = flatten' identity

-- | Render each (p1,p2) as a distinct line.
renderLines :: [(Pt,Pt)] -> Path
renderLines =
    let f pth (p1,p2) = pth +++ MoveTo p1 +++ LineTo p2
    in foldl f (MoveTo origin)

-- | Collapse line sequences into a single line.
renderLines' :: [(Pt,Pt)] -> Path
renderLines' =
    let g p (a,b) = if p == a
                    then (b,Right b)
                    else (b,Left (a,b))
        f path e = case e of
                     Left (p1,p2) -> path +++ MoveTo p1 +++ LineTo p2
                     Right p2 -> path +++ LineTo p2
    in foldl f (MoveTo origin) . snd . mapAccumL g origin

{--

curve :: Pt -> Pt -> Pt -> Pt -> Path
curve p c1 c2 q = MoveTo p +++ CurveTo c1 c2 q

-- | Polar variant.
pMoveTo :: Pt -> Path
pMoveTo p = MoveTo (polarToRectangular p)

-- | Polar variant.
pLineTo :: Pt -> Path
pLineTo p = LineTo (polarToRectangular p)

-- | Apply a funtion to leaf nodes.
p_apply :: (Path -> Path) -> Path -> Path
p_apply f (Join p q) = Join (f p) (f q)
p_apply f (PTransform m p) = PTransform m (f p)
p_apply f p = f p

--}