{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Svg.Writer -- Copyright : (C) Frank Staals -- License : see the LICENSE file -- Maintainer : Frank Staals -- Description : -- -- Write geometry to svg -- -------------------------------------------------------------------------------- module Data.Geometry.Svg.Writer where import Control.Lens hiding (rmap, Const(..)) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as B8 import Data.Ext import Data.Fixed import qualified Data.Foldable as F import qualified Data.Geometry.Ipe.Attributes as IA import Data.Geometry.Ipe.Color (IpeColor(..)) import Data.Geometry.Ipe.Types import qualified Data.Geometry.Ipe.Types as Ipe import Data.Geometry.Ipe.Value (IpeValue(..)) import Data.Geometry.Point import Data.Geometry.PolyLine import Data.Geometry.Polygon import Data.Geometry.Svg.MathCoordinateSystem import Data.Geometry.Transformation (Matrix) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Monoid (mconcat) import Data.Proxy import Data.Ratio import Data.Semigroup.Foldable (toNonEmpty) import Data.Singletons (Apply) import Data.Vinyl hiding (Label) import Data.Vinyl.Functor import Data.Vinyl.TypeLevel import Text.Blaze (ToMarkup(toMarkup), ToValue(toValue)) import qualified Text.Blaze.Svg as Svg import qualified Text.Blaze.Svg.Renderer.Utf8 as SvgRender import Text.Blaze.Svg11 ((!)) import qualified Text.Blaze.Svg11 as Svg import qualified Text.Blaze.Svg11.Attributes as A -------------------------------------------------------------------------------- -- | Converts an element into a valid svg document (including doctype etc.) -- The size of the resulting svg is set to 800x600. Moreover, we flip the axes -- so that the origin is in the bottom-left. -- -- toSvgXML :: ToMarkup t => t -> B.ByteString toSvgXML = SvgRender.renderSvg . Svg.docTypeSvg . renderCanvas (createCanvas @Double 800 600) [] . svgO -- | Convert an element to Svg using 'toSvgXML' and prints the resulting svg -- (as xml) output to stdout. -- printSvgXML :: ToMarkup t => t -> IO () printSvgXML = B8.putStrLn . toSvgXMLElem -- | Convert an element to Svg svgO :: ToMarkup a => a -> Svg.Svg svgO = Svg.toSvg -- | Convert an element to Svg, and render this svg as xml. Note that the xml -- contains *only* this element. toSvgXMLElem :: ToMarkup t => t -> B.ByteString toSvgXMLElem = SvgRender.renderSvg . Svg.toSvg -- | Convert an element to Svg, and prints the xml output to stdout. printSvgXMLElem :: ToMarkup t => t -> IO () printSvgXMLElem = B8.putStrLn . toSvgXMLElem -------------------------------------------------------------------------------- instance Real r => ToMarkup (IpeObject r) where toMarkup (IpeGroup g) = toMarkup g toMarkup (IpeImage i) = toMarkup i toMarkup (IpeTextLabel t) = toMarkup t toMarkup (IpeMiniPage m) = toMarkup m toMarkup (IpeUse u) = toMarkup u toMarkup (IpePath (p :+ ats)) = toMarkup $ p :+ (ats' <> ats) where ats' = IA.attr IA.SFill $ IpeColor $ Named "transparent" -- svg assumes that by default the filling is set to transparent -- so make sure we do that as well instance ( ToMarkup g , AllConstrained IpeToSvgAttr rs , ReifyConstraint ToValue (IA.Attr f) rs , RMap rs, RecordToList rs , RecAll (IA.Attr f) rs ToValue ) => ToMarkup (g :+ IA.Attributes f rs) where toMarkup (i :+ ats) = toMarkup i `applyAts` svgWriteAttrs ats instance Real r => ToMarkup (TextLabel r) where toMarkup (Label t p) = text_ p [] t instance Real r => ToMarkup (MiniPage r) where toMarkup (MiniPage t p w) = text_ p [A.width (toPValue w)] t instance Real r => ToMarkup (Image r) where toMarkup _ = error "ToMarkup: Image not implemented yet" -- toMarkup (Image i r) = Svg.image t ! A.xlinkHref (toAValue i) -- ! A.y (toPValue $ p^.yCoord) -- ! A.width (toPValue w) instance HasResolution p => ToValue (Fixed p) where toValue = toAValue instance Integral a => ToValue (Ratio a) where toValue = toValue @Pico . realToFrac instance Real r => ToValue (PathSegment r) where toValue = \case PolyLineSegment pl -> Svg.mkPath . toPath $ pl^.points.to toNonEmpty PolygonPath pg -> Svg.mkPath $ do toPath $ pg^.outerBoundary.to toNonEmpty Svg.z EllipseSegment _ -> undefined _ -> error "toValue: not implemented yet" toPath :: Real r => NonEmpty (Point 2 r :+ p) -> Svg.Path toPath pts = case (^.core) <$> pts of (v:|vs) -> do Svg.m (showP $ v^.xCoord) (showP $ v^.yCoord) mapM_ (\(Point2 x y) -> Svg.l (showP x) (showP y)) vs instance Real r => ToMarkup (Ipe.Path r) where toMarkup p = Svg.path ! A.d (toValue p) instance Real r => ToValue (Path r) where toValue (Path s) = mconcat . map toValue . F.toList $ s instance Real r => ToMarkup (Ipe.IpeSymbol r) where toMarkup (Symbol p _) = Svg.circle ! A.cx (toPValue $ p^.xCoord) ! A.cy (toPValue $ p^.yCoord) ! A.r (toPValue 5) -- TODO: for now just draw a disk of fixed radius instance Real r => ToMarkup (Ipe.Group r) where toMarkup (Group os) = Svg.g (mapM_ toMarkup os) -------------------------------------------------------------------------------- -- * Dealing with attributes instance ToValue (Apply f at) => ToValue (IA.Attr f at) where toValue att = maybe mempty toValue $ IA._getAttr att applyAts :: Svg.Markup -> [(SvgF, Svg.AttributeValue)] -> Svg.Markup applyAts x0 = F.foldl' (\x (f,v) -> x ! f v) x0 -- | Functon to write all attributes in a Rec svgWriteAttrs :: ( AllConstrained IpeToSvgAttr rs , RMap rs, RecordToList rs , ReifyConstraint ToValue (IA.Attr f) rs , RecAll (IA.Attr f) rs ToValue ) => IA.Attributes f rs -> [(SvgF, Svg.AttributeValue)] svgWriteAttrs (IA.Attrs r) = catMaybes . recordToList $ IA.zipRecsWith f (writeAttrFunctions r) (writeAttrValues r) where f (Const mn) (Const mv) = Const $ (,) <$> mn <*> mv -- | Writing Attribute names writeAttrFunctions :: AllConstrained IpeToSvgAttr rs => Rec f rs -> Rec (Const (Maybe SvgF)) rs writeAttrFunctions RNil = RNil writeAttrFunctions (x :& xs) = Const (write'' x) :& writeAttrFunctions xs where write'' :: forall f s. IpeToSvgAttr s => f s -> Maybe SvgF write'' _ = attrSvg (Proxy :: Proxy s) -- | Writing the attribute values writeAttrValues :: ( ReifyConstraint ToValue (IA.Attr f) rs, RMap rs , RecAll (IA.Attr f) rs ToValue) => Rec (IA.Attr f) rs -> Rec (Const (Maybe Svg.AttributeValue)) rs writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ toMaybeValue x) . reifyConstraint @ToValue toMaybeValue :: ToValue (IA.Attr f at) => IA.Attr f at -> Maybe Svg.AttributeValue toMaybeValue a = case a of IA.NoAttr -> Nothing IA.Attr _ -> Just $ toValue a type SvgF = Svg.AttributeValue -> Svg.Attribute -- | For the types representing attribute values we can get the name/key to use -- when serializing to ipe. class IpeToSvgAttr (a :: IA.AttributeUniverse) where attrSvg :: proxy a -> Maybe SvgF -- CommonAttributeUnivers instance IpeToSvgAttr IA.Layer where attrSvg _ = Nothing instance IpeToSvgAttr IA.Matrix where attrSvg _ = Nothing -- TODO instance IpeToSvgAttr IA.Pin where attrSvg _ = Nothing instance IpeToSvgAttr IA.Transformations where attrSvg _ = Nothing -- IpeSymbolAttributeUniversre instance IpeToSvgAttr IA.Stroke where attrSvg _ = Just A.stroke instance IpeToSvgAttr IA.Fill where attrSvg _ = Just A.fill instance IpeToSvgAttr IA.Pen where attrSvg _ = Nothing instance IpeToSvgAttr IA.Size where attrSvg _ = Nothing -- PathAttributeUniverse instance IpeToSvgAttr IA.Dash where attrSvg _ = Nothing instance IpeToSvgAttr IA.LineCap where attrSvg _ = Just A.strokeLinecap instance IpeToSvgAttr IA.LineJoin where attrSvg _ = Nothing instance IpeToSvgAttr IA.FillRule where attrSvg _ = Nothing instance IpeToSvgAttr IA.Arrow where attrSvg _ = Nothing instance IpeToSvgAttr IA.RArrow where attrSvg _ = Nothing instance IpeToSvgAttr IA.Opacity where attrSvg _ = Just A.opacity instance IpeToSvgAttr IA.Tiling where attrSvg _ = Nothing instance IpeToSvgAttr IA.Gradient where attrSvg _ = Nothing -- GroupAttributeUniverse instance IpeToSvgAttr IA.Clip where attrSvg _ = Just A.clip -------------------------------------------------------------------------------- deriving instance ToValue LayerName instance Real r => ToValue (IpeColor r) where toValue (IpeColor c) = case c of Named t -> toValue t Valued v -> toAValue $ fmap showP v -- TODO: instance Real r => ToValue (IA.IpePen r) where toValue _ = mempty instance Real r => ToValue (IA.IpeSize r) where toValue _ = mempty instance Real r => ToValue (IA.IpeArrow r) where toValue _ = mempty instance Real r => ToValue (IA.IpeDash r) where toValue _ = mempty instance Real r => ToValue (Matrix 3 3 r) where toValue _ = mempty instance ToValue IA.FillType where toValue _ = mempty instance ToValue IA.PinType where toValue _ = mempty instance ToValue IA.TransformationTypes where toValue _ = mempty