-- | Path type and functions. module Graphics.PS.Path where import Data.List {- base -} import Data.Monoid (Monoid, mappend, mconcat, mempty) {- base (obsolete) -} import Data.CG.Minus {- hcg-minus -} import Graphics.PS.Glyph import Graphics.PS.Font -- | Path data type,in cartesian space. 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 -- | 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 Double] -> 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 Double] -> 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 ordered anticlockwise from lower left. 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] -- | An arc segment, as starting point and values for the curveto operator. type Arc_Seg n = (Pt n,Pt n,Pt n,Pt n) -- | An arc, given as either one or two segments. data Arc n = Arc1 (Arc_Seg n) | Arc2 (Arc_Seg n) (Arc_Seg n) -- | Arc segment, (x,y) = center,r = radius,a = start angle,b = end angle. 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) -- | Arc, 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 segments. 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) -- | 'Path' of 'Arc'. 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 -- | Variant of 'arca' allowing b to be less than a. 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' -- | 'arca_udir' with a and b reversed. 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 given by a central point,a radius,and start and end angles. arc :: Pt Double -> Double -> Double -> Double -> Path arc c r a = arc_to_path . arca_udir c r a -- | Negative arc. 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) -- | (x,y) = center,ir = inner radius,xr = outer radius,sa = start -- angle,a = angle,ea = end angle 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 -- 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 (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 segment. 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" -- | Apply any transformations at path. The resulting path will not -- have any 'PTransform' nodes. flatten :: Path -> Path flatten = flatten_f mx_identity -- | Render each (p1,p2) as a distinct line. renderLines :: [Ln Double] -> Path renderLines = let f pth (Ln p1 p2) = pth +++ MoveTo p1 +++ LineTo p2 in foldl f (MoveTo pt_origin) -- | Collapse line sequences into a single line. 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 {-- 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 --}