module Wumpus.Core.PictureInternal
(
Picture(..)
, DPicture
, Locale
, AffineTrafo(..)
, GSUpdate(..)
, Primitive(..)
, DPrimitive
, XLink(..)
, PrimPath(..)
, DPrimPath
, PathProps(..)
, PrimPathSegment(..)
, DPrimPathSegment
, PrimLabel(..)
, DPrimLabel
, LabelProps(..)
, PrimEllipse(..)
, EllipseProps(..)
, PrimCTM(..)
, pathBoundary
, mapLocale
, identityCTM
, scaleCTM
, rotateCTM
, matrixRepCTM
, translMatrixRepCTM
, rotatePrimitive
, scalePrimitive
, uniformScalePrimitive
, translatePrimitive
, concatTrafos
, deconsMatrix
, repositionDeltas
) where
import Wumpus.Core.AffineTrans
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.FontSize
import Wumpus.Core.FormatCombinators
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.OneList
import Wumpus.Core.PtSize
import Wumpus.Core.TextInternal
import Wumpus.Core.Utils
import Data.AffineSpace
import qualified Data.Foldable as F
data Picture u = Leaf (Locale u) (OneList (Primitive u))
| Picture (Locale u) (OneList (Picture u))
| Clip (Locale u) (PrimPath u) (Picture u)
| Group (Locale u) GSUpdate (Picture u)
deriving (Show)
newtype GSUpdate = GSUpdate { getGSU :: GraphicsState -> GraphicsState }
instance Show GSUpdate where
show _ = "*function*"
type Locale u = (BoundingBox u, [AffineTrafo u])
type DPicture = Picture Double
data AffineTrafo u = Matrix (Matrix3'3 u)
| Rotate Radian
| RotAbout Radian (Point2 u)
| Scale u u
| Translate u u
deriving (Eq,Show)
data Primitive u = PPath PathProps XLink (PrimPath u)
| PLabel LabelProps XLink (PrimLabel u)
| PEllipse EllipseProps XLink (PrimEllipse u)
deriving (Eq,Show)
type DPrimitive = Primitive Double
data XLink = NoLink
| XLinkHRef 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 PathProps = CFill RGBi
| CStroke [StrokeAttr] RGBi
| OStroke [StrokeAttr] RGBi
| CFillStroke RGBi [StrokeAttr] RGBi
deriving (Eq,Show)
data PrimLabel u = PrimLabel
{ label_baseline_left :: Point2 u
, label_text :: EncodedText
, label_ctm :: PrimCTM u
}
deriving (Eq,Show)
type DPrimLabel = PrimLabel Double
data LabelProps = LabelProps
{ label_colour :: RGBi
, label_font :: FontAttr
}
deriving (Eq,Ord,Show)
data PrimEllipse u = PrimEllipse
{ ellipse_center :: Point2 u
, ellipse_half_width :: u
, ellipse_half_height :: u
, ellipse_ctm :: PrimCTM u
}
deriving (Eq,Show)
data EllipseProps = EFill RGBi
| EStroke [StrokeAttr] RGBi
| EFillStroke RGBi [StrokeAttr] RGBi
deriving (Eq,Show)
data PrimCTM u = PrimCTM
{ ctm_scale_x :: u
, ctm_scale_y :: u
, ctm_rotation :: Radian
}
deriving (Eq,Show)
type instance DUnit (Picture u) = u
type instance DUnit (Primitive u) = u
type instance DUnit (PrimEllipse u) = u
instance (Num u, PSUnit u) => Format (Picture u) where
format (Leaf m prims) = indent 2 $ vcat [ text "** Leaf-pic **"
, fmtLocale m
, fmtPrims 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 ]
format (Group m _ pic) = indent 2 $ vcat [ text "** Group **"
, fmtLocale m
, format pic ]
fmtPics :: PSUnit u => OneList (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])
fmtPrims :: PSUnit u => OneList (Primitive u) -> Doc
fmtPrims ones = snd $ F.foldl' fn (0,empty) ones
where
fn (n,acc) e = (n+1, vcat [ acc, text "-- leaf" <+> 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 ]
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 (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 PSUnit u => Format (PrimCTM u) where
format (PrimCTM x y ang) =
parens (text "CTM" <+> text "sx=" <> dtruncFmt x
<+> text "sy=" <> dtruncFmt y
<+> text "ang=" <> format ang )
instance Format PathProps where
format (CFill rgb) = format rgb <+> text "Fill"
format (CStroke _ rgb) = format rgb <+> text "Closed-stroke"
format (OStroke _ rgb) = format rgb <+> text "Open-stroke"
format (CFillStroke f _ s) = format f <+> text "Fill" <> char '/'
<+> format s <+> text "Stroke"
instance Format LabelProps where
format (LabelProps rgb attr) = format rgb
<+> text (font_name $ font_face attr)
instance Format EllipseProps where
format (EFill rgb) = format rgb <+> text "Fill"
format (EStroke _ rgb) = format rgb <+> text "Stroke"
format (EFillStroke f _ s) = format f <+> text "Fill" <> char '/'
<+> format s <+> text "Stroke"
instance Boundary (Picture u) where
boundary (Leaf (bb,_) _) = bb
boundary (Picture (bb,_) _) = bb
boundary (Clip (bb,_) _ _) = bb
boundary (Group (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
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) xs ctm) =
retraceBoundary (disp . (m33 *#)) untraf_bbox
where
disp = (.+^ V2 x y)
m33 = matrixRepCTM ctm
untraf_bbox = textBounds (font_size attr) zeroPt char_count
char_count = textLength xs
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
mapLocale f (Group lc upd pic) = Group (f lc) upd pic
identityCTM :: Num u => PrimCTM u
identityCTM = PrimCTM { ctm_scale_x = 1, ctm_scale_y = 1, ctm_rotation = 0 }
scaleCTM :: Num u => u -> u -> PrimCTM u -> PrimCTM u
scaleCTM x1 y1 (PrimCTM sx sy ang) = PrimCTM (x1*sx) (y1*sy) ang
rotateCTM :: Radian -> PrimCTM u -> PrimCTM u
rotateCTM ang1 (PrimCTM sx sy ang) = PrimCTM sx sy (circularModulo $ ang1+ang)
matrixRepCTM :: (Floating u, Real u) => PrimCTM u -> Matrix3'3 u
matrixRepCTM (PrimCTM sx sy ang) =
rotationMatrix (circularModulo ang) * scalingMatrix sx sy
translMatrixRepCTM :: (Floating u, Real u)
=> u -> u -> PrimCTM u -> Matrix3'3 u
translMatrixRepCTM x y ctm = translationMatrix x y * matrixRepCTM ctm
rotatePrimitive :: (Real u, Floating u)
=> Radian -> Primitive u -> Primitive u
rotatePrimitive ang (PPath a xl path) = PPath a xl $ rotatePath ang path
rotatePrimitive ang (PLabel a xl lbl) = PLabel a xl $ rotateLabel ang lbl
rotatePrimitive ang (PEllipse a xl ell) = PEllipse a xl $ rotateEllipse ang ell
scalePrimitive :: Num u => u -> u -> Primitive u -> Primitive u
scalePrimitive x y (PPath a xl path) = PPath a xl $ scalePath x y path
scalePrimitive x y (PLabel a xl lbl) = PLabel a xl $ scaleLabel x y lbl
scalePrimitive x y (PEllipse a xl ell) = PEllipse a xl $ scaleEllipse x y ell
uniformScalePrimitive :: Num u => u -> Primitive u -> Primitive u
uniformScalePrimitive d = scalePrimitive d d
translatePrimitive :: Num u => u -> u -> Primitive u -> Primitive u
translatePrimitive x y (PPath a xl path) =
PPath a xl $ translatePath x y path
translatePrimitive x y (PLabel a xl lbl) =
PLabel a xl $ translateLabel x y lbl
translatePrimitive x y (PEllipse a xl ell) =
PEllipse a xl $ translateEllipse x y ell
rotatePath :: (Real u, Floating u) => Radian -> PrimPath u -> PrimPath u
rotatePath ang (PrimPath start xs) = PrimPath start $ map (mapSeg fn) xs
where
fn = rotateAbout ang start
scalePath :: Num u => u -> u -> PrimPath u -> PrimPath u
scalePath x y (PrimPath pt xs) = PrimPath pt $ map (mapSeg fn) xs
where
fn p1 = let dif = p1 .-. pt in pt .+^ (scale x y $ dif)
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 :: Radian -> PrimLabel u -> PrimLabel u
rotateLabel ang (PrimLabel pt txt ctm) = PrimLabel pt txt (rotateCTM ang ctm)
scaleLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
scaleLabel x y (PrimLabel pt txt ctm) = PrimLabel pt txt (scaleCTM x y ctm)
translateLabel :: Num u => u -> u -> PrimLabel u -> PrimLabel u
translateLabel x y (PrimLabel pt txt ctm) = PrimLabel (translate x y pt) txt ctm
rotateEllipse :: Radian -> PrimEllipse u -> PrimEllipse u
rotateEllipse ang (PrimEllipse pt hw hh ctm) =
PrimEllipse pt hw hh (rotateCTM ang ctm)
scaleEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u
scaleEllipse x y (PrimEllipse pt hw hh ctm) =
PrimEllipse (translate x y pt) hw hh (scaleCTM x y ctm)
translateEllipse :: Num u => u -> u -> PrimEllipse u -> PrimEllipse u
translateEllipse x y (PrimEllipse pt hw hh ctm) =
PrimEllipse (translate x y pt) hw hh ctm
concatTrafos :: (Floating u, Real u) => [AffineTrafo u] -> Matrix3'3 u
concatTrafos = foldr (\e ac -> matrixRepr e * ac) identityMatrix
matrixRepr :: (Floating u, Real u) => AffineTrafo u -> Matrix3'3 u
matrixRepr (Matrix mtrx) = mtrx
matrixRepr (Rotate theta) = rotationMatrix theta
matrixRepr (RotAbout theta pt) = originatedRotationMatrix theta pt
matrixRepr (Scale sx sy) = scalingMatrix sx sy
matrixRepr (Translate dx dy) = translationMatrix dx dy
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)