module Wumpus.Core.PictureInternal
(
Picture(..)
, DPicture
, Locale
, FontCtx(..)
, Primitive(..)
, DPrimitive
, SvgAnno(..)
, XLink(..)
, SvgAttr(..)
, PrimPath(..)
, DPrimPath
, PrimPathSegment(..)
, DPrimPathSegment
, AbsPathSegment(..)
, DAbsPathSegment
, PrimLabel(..)
, DPrimLabel
, LabelBody(..)
, DLabelBody
, KerningChar
, DKerningChar
, PrimEllipse(..)
, GraphicsState(..)
, pathBoundary
, mapLocale
, concatTrafos
, deconsMatrix
, repositionDeltas
, zeroGS
) where
import Wumpus.Core.AffineTrans
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.FontSize
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicProps
import Wumpus.Core.PtSize
import Wumpus.Core.Text.Base
import Wumpus.Core.TrafoInternal
import Wumpus.Core.Utils.Common
import Wumpus.Core.Utils.FormatCombinators
import Wumpus.Core.Utils.JoinList
import Data.AffineSpace
import qualified Data.Foldable as F
import qualified Data.IntMap as IntMap
data Picture u = Leaf (Locale u) (JoinList (Primitive u))
| Picture (Locale u) (JoinList (Picture u))
| Clip (Locale u) (PrimPath u) (Picture u)
deriving (Show)
type DPicture = Picture Double
type Locale u = (BoundingBox u, [AffineTrafo u])
data Primitive u = PPath PathProps (PrimPath u)
| PLabel LabelProps (PrimLabel u)
| PEllipse EllipseProps (PrimEllipse u)
| PContext FontCtx (Primitive u)
| PSVG SvgAnno (Primitive u)
| PGroup (JoinList (Primitive u))
deriving (Eq,Show)
type DPrimitive = Primitive Double
newtype FontCtx = FontCtx { getFontCtx :: FontAttr }
deriving (Eq,Show)
data SvgAnno = ALink XLink
| GAnno [SvgAttr]
| SvgAG XLink [SvgAttr]
deriving (Eq,Show)
newtype XLink = XLink { getXLink :: String }
deriving (Eq,Show)
data SvgAttr = SvgAttr
{ svg_attr_name :: String
, svg_attr_value :: String
}
deriving (Eq,Show)
data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u]
deriving (Eq,Show)
type DPrimPath = PrimPath Double
data PrimPathSegment u = RelCurveTo (Vec2 u) (Vec2 u) (Vec2 u)
| RelLineTo (Vec2 u)
deriving (Eq,Show)
type DPrimPathSegment = PrimPathSegment Double
data AbsPathSegment u = AbsCurveTo (Point2 u) (Point2 u) (Point2 u)
| AbsLineTo (Point2 u)
deriving (Eq,Show)
type DAbsPathSegment = AbsPathSegment Double
data PrimLabel u = PrimLabel
{ label_body :: LabelBody u
, label_ctm :: PrimCTM u
}
deriving (Eq,Show)
type DPrimLabel = PrimLabel Double
data LabelBody u = StdLayout EscapedText
| KernTextH [KerningChar u]
| KernTextV [KerningChar u]
deriving (Eq,Show)
type DLabelBody = LabelBody Double
type KerningChar u = (u,EscapedChar)
type DKerningChar = KerningChar Double
data PrimEllipse u = PrimEllipse
{ ellipse_half_width :: u
, ellipse_half_height :: u
, ellipse_ctm :: PrimCTM u
}
deriving (Eq,Show)
data GraphicsState = GraphicsState
{ gs_draw_colour :: RGBi
, gs_font_size :: Int
, gs_font_face :: FontFace
, gs_stroke_attr :: StrokeAttr
}
deriving (Eq,Show)
type instance DUnit (Picture u) = u
type instance DUnit (Primitive u) = u
type instance DUnit (PrimEllipse u) = u
type instance DUnit (PrimLabel u) = u
type instance DUnit (PrimPath u) = u
instance (Num u, PSUnit u) => Format (Picture u) where
format (Leaf m prims) = indent 2 $ vcat [ text "** Leaf-pic **"
, fmtLocale m
, fmtPrimlist prims ]
format (Picture m pics) = indent 2 $ vcat [ text "** Tree-pic **"
, fmtLocale m
, fmtPics pics ]
format (Clip m path pic) = indent 2 $ vcat [ text "** Clip-path **"
, fmtLocale m
, format path
, format pic ]
fmtPics :: PSUnit u => JoinList (Picture u) -> Doc
fmtPics ones = snd $ F.foldl' fn (0,empty) ones
where
fn (n,acc) e = (n+1, vcat [ acc, text "-- " <+> int n, format e, line])
fmtLocale :: (Num u, PSUnit u) => Locale u -> Doc
fmtLocale (bb,_) = format bb
instance PSUnit u => Format (Primitive u) where
format (PPath props p) =
indent 2 $ vcat [ text "path:" <+> format props, format p ]
format (PLabel props l) =
indent 2 $ vcat [ text "label:" <+> format props, format l ]
format (PEllipse props e) =
indent 2 $ vcat [ text "ellipse:" <+> format props, format e ]
format (PContext _ a) =
vcat [ text "-- svg ctx change " , format a ]
format (PSVG _ a) =
vcat [ text "-- svg:", format a ]
format (PGroup ones) =
vcat [ text "-- group ", fmtPrimlist ones ]
fmtPrimlist :: PSUnit u => JoinList (Primitive u) -> Doc
fmtPrimlist ones = snd $ F.foldl' fn (0,empty) ones
where
fn (n,acc) e = (n+1, vcat [ acc, text "-- leaf" <+> int n, format e, line])
instance PSUnit u => Format (PrimPath u) where
format (PrimPath pt ps) = vcat (start : map format ps)
where
start = text "start_point " <> format pt
instance PSUnit u => Format (PrimPathSegment u) where
format (RelCurveTo p1 p2 p3) =
text "rel_curve_to " <> format p1 <+> format p2 <+> format p3
format (RelLineTo pt) = text "rel_line_to " <> format pt
instance PSUnit u => Format (PrimLabel u) where
format (PrimLabel s ctm) =
vcat [ dquotes (format s)
, text "ctm=" <> format ctm
]
instance PSUnit u => Format (LabelBody u) where
format (StdLayout enctext) = format enctext
format (KernTextH xs) = text "(KernH)" <+> hcat (map (format .snd) xs)
format (KernTextV xs) = text "(KernV)" <+> hcat (map (format .snd) xs)
instance PSUnit u => Format (PrimEllipse u) where
format (PrimEllipse hw hh ctm) = text "hw=" <> dtruncFmt hw
<+> text "hh=" <> dtruncFmt hh
<+> text "ctm=" <> format ctm
instance Format XLink where
format (XLink ss) = text "xlink:href" <+> text ss
instance Boundary (Picture u) where
boundary (Leaf (bb,_) _) = bb
boundary (Picture (bb,_) _) = bb
boundary (Clip (bb,_) _ _) = bb
instance (Real u, Floating u, FromPtSize u) => Boundary (Primitive u) where
boundary (PPath _ p) = pathBoundary p
boundary (PLabel a l) = labelBoundary (label_font a) l
boundary (PEllipse _ e) = ellipseBoundary e
boundary (PContext _ a) = boundary a
boundary (PSVG _ a) = boundary a
boundary (PGroup ones) = outer $ viewl ones
where
outer (OneL a) = boundary a
outer (a :< as) = inner (boundary a) (viewl as)
inner bb (OneL a) = bb `boundaryUnion` boundary a
inner bb (a :< as) = inner (bb `boundaryUnion` boundary a) (viewl as)
pathBoundary :: (Num u, Ord u) => PrimPath u -> BoundingBox u
pathBoundary (PrimPath st xs) = step st (st,st) xs
where
step _ (lo,hi) [] = BBox lo hi
step pt (lo,hi) (RelLineTo v1:rest) =
let p1 = pt .+^ v1
in step p1 (lo2 lo p1, hi2 hi p1) rest
step pt (lo,hi) (RelCurveTo v1 v2 v3:rest) =
let p1 = pt .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
lo' = lo4 lo p1 p2 p3
hi' = hi4 hi p1 p2 p3
in step p3 (lo',hi') rest
lo2 (P2 x1 y1) (P2 x2 y2) = P2 (min x1 x2) (min y1 y2)
hi2 (P2 x1 y1) (P2 x2 y2) = P2 (max x1 x2) (max y1 y2)
lo4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) =
P2 (min x1 $ min x2 $ min x3 x4) (min y1 $ min y2 $ min y3 y4)
hi4 (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) (P2 x4 y4) =
P2 (max x1 $ max x2 $ max x3 x4) (max y1 $ max y2 $ max y3 y4)
labelBoundary :: (Floating u, Real u, FromPtSize u)
=> FontAttr -> PrimLabel u -> BoundingBox u
labelBoundary attr (PrimLabel body ctm) =
retraceBoundary (m33 *#) untraf_bbox
where
m33 = matrixRepCTM ctm
untraf_bbox = labelBodyBoundary (font_size attr) body
labelBodyBoundary :: (Num u, Ord u, FromPtSize u)
=> FontSize -> LabelBody u -> BoundingBox u
labelBodyBoundary sz (StdLayout etxt) = stdLayoutBB sz etxt
labelBodyBoundary sz (KernTextH xs) = hKerningBB sz xs
labelBodyBoundary sz (KernTextV xs) = vKerningBB sz xs
stdLayoutBB :: (Num u, Ord u, FromPtSize u)
=> FontSize -> EscapedText -> BoundingBox u
stdLayoutBB sz etxt = textBoundsEsc sz zeroPt etxt
hKerningBB :: (Num u, Ord u, FromPtSize u)
=> FontSize -> [(u,EscapedChar)] -> BoundingBox u
hKerningBB sz xs = rightGrow (sumDiffs xs) $ textBounds sz zeroPt "A"
where
sumDiffs = foldr (\(u,_) i -> i+u) 0
rightGrow u (BBox ll (P2 x1 y1)) = BBox ll (P2 (x1+u) y1)
vKerningBB :: (Num u, Ord u, FromPtSize u)
=> FontSize -> [(u,EscapedChar)] -> BoundingBox u
vKerningBB sz xs = downGrow (sumDiffs xs) $ textBounds sz zeroPt "A"
where
sumDiffs = foldr (\(u,_) i -> i+u) 0
downGrow u (BBox (P2 x0 y0) (P2 x1 y1)) = BBox (P2 x0 (y0u)) (P2 x1 y1)
ellipseBoundary :: (Real u, Floating u) => PrimEllipse u -> BoundingBox u
ellipseBoundary (PrimEllipse hw hh ctm) =
traceBoundary $ map (m33 *#) [sw,se,ne,nw]
where
sw = P2 (hw) (hh)
se = P2 hw (hh)
ne = P2 hw hh
nw = P2 (hw) hh
m33 = matrixRepCTM ctm
instance (Num u, Ord u) => Transform (Picture u) where
transform mtrx =
mapLocale $ \(bb,xs) -> (transform mtrx bb, Matrix mtrx:xs)
instance (Real u, Floating u) => Rotate (Picture u) where
rotate theta =
mapLocale $ \(bb,xs) -> (rotate theta bb, Rotate theta:xs)
instance (Real u, Floating u) => RotateAbout (Picture u) where
rotateAbout theta pt =
mapLocale $ \(bb,xs) -> (rotateAbout theta pt bb, RotAbout theta pt:xs)
instance (Num u, Ord u) => Scale (Picture u) where
scale sx sy =
mapLocale $ \(bb,xs) -> (scale sx sy bb, Scale sx sy : xs)
instance (Num u, Ord u) => Translate (Picture u) where
translate dx dy =
mapLocale $ \(bb,xs) -> (translate dx dy bb, Translate dx dy:xs)
mapLocale :: (Locale u -> Locale u) -> Picture u -> Picture u
mapLocale f (Leaf lc ones) = Leaf (f lc) ones
mapLocale f (Picture lc ones) = Picture (f lc) ones
mapLocale f (Clip lc pp pic) = Clip (f lc) pp pic
instance (Real u, Floating u) => Rotate (Primitive u) where
rotate r (PPath a path) = PPath a $ rotatePath r path
rotate r (PLabel a lbl) = PLabel a $ rotateLabel r lbl
rotate r (PEllipse a ell) = PEllipse a $ rotateEllipse r ell
rotate r (PContext a chi) = PContext a $ rotate r chi
rotate r (PSVG a chi) = PSVG a $ rotate r chi
rotate r (PGroup xs) = PGroup $ fmap (rotate r) xs
instance (Real u, Floating u) => RotateAbout (Primitive u) where
rotateAbout r pt (PPath a path) = PPath a $ rotateAboutPath r pt path
rotateAbout r pt (PLabel a lbl) = PLabel a $ rotateAboutLabel r pt lbl
rotateAbout r pt (PEllipse a ell) = PEllipse a $ rotateAboutEllipse r pt ell
rotateAbout r pt (PContext a chi) = PContext a $ rotateAbout r pt chi
rotateAbout r pt (PSVG a chi) = PSVG a $ rotateAbout r pt chi
rotateAbout r pt (PGroup xs) = PGroup $ fmap (rotateAbout r pt) xs
instance Num u => Scale (Primitive u) where
scale sx sy (PPath a path) = PPath a $ scalePath sx sy path
scale sx sy (PLabel a lbl) = PLabel a $ scaleLabel sx sy lbl
scale sx sy (PEllipse a ell) = PEllipse a $ scaleEllipse sx sy ell
scale sx sy (PContext a chi) = PContext a $ scale sx sy chi
scale sx sy (PSVG a chi) = PSVG a $ scale sx sy chi
scale sx sy (PGroup xs) = PGroup $ fmap (scale sx sy) xs
instance Num u => Translate (Primitive u) where
translate dx dy (PPath a path) = PPath a $ translatePath dx dy path
translate dx dy (PLabel a lbl) = PLabel a $ translateLabel dx dy lbl
translate dx dy (PEllipse a ell) = PEllipse a $ translateEllipse dx dy ell
translate dx dy (PContext a chi) = PContext a $ translate dx dy chi
translate dx dy (PSVG a chi) = PSVG a $ translate dx dy chi
translate dx dy (PGroup xs) = PGroup $ fmap (translate dx dy) xs
rotatePath :: (Real u, Floating u) => Radian -> PrimPath u -> PrimPath u
rotatePath ang = mapPath (rotate ang) (rotate ang)
rotateAboutPath :: (Real u, Floating u)
=> Radian -> Point2 u -> PrimPath u -> PrimPath u
rotateAboutPath ang pt = mapPath (rotateAbout ang pt) (rotateAbout ang pt)
scalePath :: Num u => u -> u -> PrimPath u -> PrimPath u
scalePath sx sy = mapPath (scale sx sy) (scale sx sy)
translatePath :: Num u => u -> u -> PrimPath u -> PrimPath u
translatePath x y (PrimPath st xs) = PrimPath (translate x y st) xs
mapPath :: (Point2 u -> Point2 u) -> (Vec2 u -> Vec2 u)
-> PrimPath u -> PrimPath u
mapPath f g (PrimPath st xs) = PrimPath (f st) (map (mapSeg g) xs)
mapSeg :: (Vec2 u -> Vec2 u) -> PrimPathSegment u -> PrimPathSegment u
mapSeg fn (RelLineTo p) = RelLineTo (fn p)
mapSeg fn (RelCurveTo p1 p2 p3) = RelCurveTo (fn p1) (fn p2) (fn p3)
rotateLabel :: (Real u, Floating u)
=> Radian -> PrimLabel u -> PrimLabel u
rotateLabel ang (PrimLabel txt ctm) = PrimLabel txt (rotateCTM ang ctm)
rotateAboutLabel :: (Real u, Floating u)
=> Radian -> Point2 u -> PrimLabel u -> PrimLabel u
rotateAboutLabel ang pt (PrimLabel txt ctm) =
PrimLabel txt (rotateAboutCTM ang pt ctm)
scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
scaleLabel sx sy (PrimLabel txt ctm) = PrimLabel txt (scaleCTM sx sy ctm)
translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
translateLabel dx dy (PrimLabel txt ctm) =
PrimLabel txt (translateCTM dx dy ctm)
rotateEllipse :: (Real u, Floating u)
=> Radian -> PrimEllipse u -> PrimEllipse u
rotateEllipse ang (PrimEllipse hw hh ctm) =
PrimEllipse hw hh (rotateCTM ang ctm)
rotateAboutEllipse :: (Real u, Floating u)
=> Radian -> Point2 u -> PrimEllipse u -> PrimEllipse u
rotateAboutEllipse ang pt (PrimEllipse hw hh ctm) =
PrimEllipse hw hh (rotateAboutCTM ang pt ctm)
scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u
scaleEllipse sx sy (PrimEllipse hw hh ctm) =
PrimEllipse hw hh (scaleCTM sx sy ctm)
translateEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u
translateEllipse dx dy (PrimEllipse hw hh ctm) =
PrimEllipse hw hh (translateCTM dx dy ctm)
deconsMatrix :: Matrix3'3 u -> (u,u,u,u,u,u)
deconsMatrix (M3'3 e0x e1x ox
e0y e1y oy
_ _ _ ) = (e0x,e0y, e1x,e1y, ox,oy)
repositionDeltas :: (Num u, Ord u)
=> Picture u -> (BoundingBox u, Maybe (Vec2 u))
repositionDeltas = step . boundary
where
step bb@(BBox (P2 llx lly) (P2 urx ury))
| llx < 4 || lly < 4 = (BBox ll ur, Just $ V2 x y)
| otherwise = (bb, Nothing)
where
x = 4 llx
y = 4 lly
ll = P2 (llx+x) (lly+y)
ur = P2 (urx+x) (ury+y)
zeroGS :: GraphicsState
zeroGS = GraphicsState { gs_draw_colour = black
, gs_font_size = (1)
, gs_font_face = unmatchable_face
, gs_stroke_attr = default_stroke_attr
}
where
unmatchable_face = FontFace "DONT_MATCH" ""
SVG_BOLD_OBLIQUE no_encoding
no_encoding = IntMap.empty