module Wumpus.Core.PictureInternal
(
Picture(..)
, DPicture
, Locale
, FontCtx(..)
, Primitive(..)
, DPrimitive
, XLink(..)
, PrimPath(..)
, DPrimPath
, PrimPathSegment(..)
, DPrimPathSegment
, 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.Latin1
import Wumpus.Core.Text.TextInternal
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
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)
| PLink XLink (Primitive u)
| PGroup (JoinList (Primitive u))
deriving (Eq,Show)
type DPrimitive = Primitive Double
newtype FontCtx = FontCtx { getFontCtx :: FontAttr }
deriving (Eq,Show)
newtype XLink = XLink { getXLink :: String }
deriving (Eq,Show)
data PrimPath u = PrimPath (Point2 u) [PrimPathSegment u]
deriving (Eq,Show)
type DPrimPath = PrimPath Double
data PrimPathSegment u = PCurveTo (Point2 u) (Point2 u) (Point2 u)
| PLineTo (Point2 u)
deriving (Eq,Show)
type DPrimPathSegment = PrimPathSegment Double
data PrimLabel u = PrimLabel
{ label_baseline_left :: Point2 u
, label_body :: LabelBody u
, label_ctm :: PrimCTM u
}
deriving (Eq,Show)
type DPrimLabel = PrimLabel Double
data LabelBody u = StdLayout EncodedText
| KernTextH [KerningChar u]
| KernTextV [KerningChar u]
deriving (Eq,Show)
type DLabelBody = LabelBody Double
type KerningChar u = (u,EncodedChar)
type DKerningChar = KerningChar Double
data PrimEllipse u = PrimEllipse
{ ellipse_center :: Point2 u
, 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 (PLink _ a) =
vcat [ text "-- svg link " , 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 (PCurveTo p1 p2 p3) =
text "curve_to " <> format p1 <+> format p2 <+> format p3
format (PLineTo pt) = text "line_to " <> format pt
instance PSUnit u => Format (PrimLabel u) where
format (PrimLabel pt s ctm) =
vcat [ dquotes (format s)
, text "baseline_left=" <> format pt
<+> 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 ctr hw hh ctm) = text "center=" <> format ctr
<+> text "hw=" <> dtruncFmt hw
<+> text "hh=" <> dtruncFmt hh
<+> text "ctm=" <> format ctm
instance Format XLink where
format (XLink ss) = text "xlink" <+> 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 (PLink _ 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 :: Ord u => PrimPath u -> BoundingBox u
pathBoundary (PrimPath st xs) = step (st,st) xs
where
step (lo,hi) [] = BBox lo hi
step (lo,hi) (PLineTo p1:rest) = step (lo2 lo p1, hi2 hi p1) rest
step (lo,hi) (PCurveTo p1 p2 p3:rest) = let lo' = lo4 lo p1 p2 p3
hi' = hi4 hi p1 p2 p3
in step (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 (P2 x y) body ctm) =
retraceBoundary (disp . (m33 *#)) untraf_bbox
where
disp = (.+^ V2 x y)
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 -> EncodedText -> BoundingBox u
stdLayoutBB sz etxt = textBoundsEnc sz zeroPt etxt
hKerningBB :: (Num u, Ord u, FromPtSize u)
=> FontSize -> [(u,EncodedChar)] -> 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,EncodedChar)] -> 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 pt hw0 hh0 (PrimCTM sx sy theta)) =
traceBoundary $ applyIf (theta /= 0) (map (rotm *#)) [ll,lr,ur,ul]
where
hw = hw0 * sx
hh = hh0 * sy
ll = pt .+^ V2 (hw) (hh)
lr = pt .+^ V2 hw (hh)
ur = pt .+^ V2 hw hh
ul = pt .+^ V2 (hw) hh
rotm = rotationMatrix theta
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 (PLink a chi) = PLink 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 (PLink a chi) = PLink 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 (PLink a chi) = PLink 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 (PLink a chi) = PLink 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)
rotateAboutPath :: (Real u, Floating u)
=> Radian -> Point2 u -> PrimPath u -> PrimPath u
rotateAboutPath ang pt = mapPath (rotateAbout ang pt)
scalePath :: Num u => u -> u -> PrimPath u -> PrimPath u
scalePath sx sy = mapPath (scale sx sy)
translatePath :: Num u => u -> u -> PrimPath u -> PrimPath u
translatePath x y = mapPath (translate x y)
mapPath :: (Point2 u -> Point2 u) -> PrimPath u -> PrimPath u
mapPath fn (PrimPath st xs) = PrimPath (fn st) (map (mapSeg fn) xs)
mapSeg :: (Point2 u -> Point2 u) -> PrimPathSegment u -> PrimPathSegment u
mapSeg fn (PLineTo p) = PLineTo (fn p)
mapSeg fn (PCurveTo p1 p2 p3) = PCurveTo (fn p1) (fn p2) (fn p3)
rotateLabel :: (Real u, Floating u)
=> Radian -> PrimLabel u -> PrimLabel u
rotateLabel ang (PrimLabel pt txt ctm) =
PrimLabel (rotate ang pt) txt (rotateCTM ang ctm)
rotateAboutLabel :: (Real u, Floating u)
=> Radian -> Point2 u -> PrimLabel u -> PrimLabel u
rotateAboutLabel ang pt0 (PrimLabel pt txt ctm) =
PrimLabel (rotateAbout ang pt0 pt) txt (rotateCTM ang ctm)
scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
scaleLabel sx sy (PrimLabel pt txt ctm) =
PrimLabel (scale sx sy pt) txt (scaleCTM sx sy ctm)
translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
translateLabel dx dy (PrimLabel pt txt ctm) =
PrimLabel (translate dx dy pt) txt ctm
rotateEllipse :: (Real u, Floating u)
=> Radian -> PrimEllipse u -> PrimEllipse u
rotateEllipse ang (PrimEllipse pt hw hh ctm) =
PrimEllipse (rotate ang pt) hw hh (rotateCTM ang ctm)
rotateAboutEllipse :: (Real u, Floating u)
=> Radian -> Point2 u -> PrimEllipse u -> PrimEllipse u
rotateAboutEllipse ang pt0 (PrimEllipse pt hw hh ctm) =
PrimEllipse (rotateAbout ang pt0 pt) hw hh (rotateCTM ang ctm)
scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u
scaleEllipse sx sy (PrimEllipse pt hw hh ctm) =
PrimEllipse (scale sx sy pt) hw hh (scaleCTM sx sy ctm)
translateEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u
translateEllipse dx dy (PrimEllipse pt hw hh ctm) =
PrimEllipse (translate dx dy pt) hw hh 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 latin1_font_encoder