{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module : Ipe.FromIpe
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
--
-- Functions that help reading geometric values from ipe images.
--
--------------------------------------------------------------------------------
module Ipe.FromIpe(
-- * Individual readers
_asPoint
, _asLineSegment
, _asRectangle
, _asTriangle
, _asPolyLine
, _asSomePolygon, _asSimplePolygon, _asMultiPolygon
-- * Dealing with Attributes
, _withAttrs
-- * Default readers
, HasDefaultFromIpe(..)
-- * Reading all elements of a particular type
, readAll, readAllFrom
) where
import Control.Lens hiding (Simple)
import Data.Ext
import Data.Geometry.Ball
import Data.Geometry.Box
import Data.Geometry.Ellipse (Ellipse, _EllipseCircle)
import Ipe.Path
import Ipe.Reader
import Ipe.Types
import Data.Geometry.LineSegment
import Data.Geometry.Point
import qualified Data.Geometry.PolyLine as PolyLine
import Data.Geometry.Polygon
import Data.Geometry.Properties
import Data.Geometry.Triangle
import qualified Data.LSeq as LSeq
import Data.List.NonEmpty (NonEmpty(..))
--------------------------------------------------------------------------------
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Ipe.Attributes
-- >>> import Ipe.Color(IpeColor(..))
-- >>> import Data.Geometry.Point
-- >>> :{
-- let testPath :: Path Int
-- testPath = Path . fromSingleton . PolyLineSegment
-- . PolyLine.fromPoints . map ext
-- $ [ origin, Point2 10 10, Point2 200 100 ]
-- testPathAttrs :: IpeAttributes Path Int
-- testPathAttrs = attr SStroke (IpeColor "red")
-- testObject :: IpeObject Int
-- testObject = IpePath (testPath :+ testPathAttrs)
-- :}
-- | Extracts the point from a Symbol. When creating a symbol this
-- creates a disk that supports a stroke color.
_asPoint :: Prism' (IpeSymbol r) (Point 2 r)
_asPoint = prism' (flip Symbol "mark/disk(sx)") (Just . view symbolPoint)
-- | Try to convert a path into a line segment, fails if the path is not a line
-- segment or a polyline with more than two points.
--
--
_asLineSegment :: Prism' (Path r) (LineSegment 2 () r)
_asLineSegment = prism' seg2path path2seg
where
seg2path = review _asPolyLine . PolyLine.fromLineSegment
path2seg p = PolyLine.asLineSegment' =<< preview _asPolyLine p
-- | Convert to a polyline. Ignores all non-polyline parts
--
-- >>> testPath ^? _asPolyLine
-- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])})
_asPolyLine :: Prism' (Path r) (PolyLine.PolyLine 2 () r)
_asPolyLine = prism' poly2path path2poly
where
poly2path = Path . fromSingleton . PolyLineSegment
path2poly = preview (pathSegments.traverse._PolyLineSegment)
-- TODO: Check that the path actually is a polyline, rather
-- than ignoring everything that does not fit
-- | Convert to a simple polygon
_asSimplePolygon :: Prism' (Path r) (Polygon Simple () r)
_asSimplePolygon = _asSomePolygon._Left
-- | Tries to convert a path into a rectangle.
_asRectangle :: forall r. (Num r, Ord r) => Prism' (Path r) (Rectangle () r)
_asRectangle = prism' rectToPath pathToRect
where
rectToPath (corners -> Corners a b c d) = review _asSimplePolygon . fromPoints $ [a,b,c,d]
pathToRect p = p^?_asSimplePolygon >>= asRect
asRect :: SimplePolygon () r -> Maybe (Rectangle () r)
asRect pg = case pg^..outerBoundaryVector.traverse of
[a,b,c,d] | isH a b && isV b c && isH c d && isV d a -> Just (boundingBoxList' [a,c])
[a,b,c,d] | isV a b && isH b c && isV c d && isH d a -> Just (boundingBoxList' [a,c])
_ -> Nothing
isH (p :+ _) (q :+ _) = p^.xCoord == q^.xCoord
isV (p :+ _) (q :+ _) = p^.yCoord == q^.yCoord
-- | Convert to a triangle
_asTriangle :: Prism' (Path r) (Triangle 2 () r)
_asTriangle = prism' triToPath path2tri
where
triToPath (Triangle p q r) = polygonToPath . unsafeFromPoints . map (&extra .~ ()) $ [p,q,r]
path2tri p = case p^..pathSegments.traverse._PolygonPath of
[] -> Nothing
[pg] -> case polygonVertices pg of
(a :| [b,c]) -> Just $ Triangle a b c
_ -> Nothing
_ -> Nothing
-- an ellipse is an affine transformation of the unit disk
-- (Disk origin 1) (Vector2 1 1)
_asEllipse :: Prism' (Path r) (Ellipse r)
_asEllipse = prism' toPath toEllipse
where
toPath = Path . fromSingleton . EllipseSegment
toEllipse p = case p^..pathSegments.traverse._EllipseSegment of
[e] -> Just e
_ -> Nothing
_asCircle :: (Floating r, Eq r) => Prism' (Path r) (Circle () r)
_asCircle = _asEllipse._EllipseCircle
-- FIXME: For reading we should not need the floating constraint!
_asDisk :: (Floating r, Eq r) => Prism' (Path r) (Disk () r)
_asDisk = _asCircle.from _DiskCircle
-- | Convert to a multipolygon
_asMultiPolygon :: Prism' (Path r) (MultiPolygon () r)
_asMultiPolygon = _asSomePolygon._Right
-- _asPolygon :: Prism' (Path r) (forall t. Polygon t () r)
-- _asPolygon = prism' polygonToPath (fmap (either id id) . pathToPolygon)
_asSomePolygon :: Prism' (Path r) (SomePolygon () r)
_asSomePolygon = prism' embed pathToPolygon
where
embed = either polygonToPath polygonToPath
polygonToPath :: Polygon t () r -> Path r
polygonToPath pg@SimplePolygon{} = Path . fromSingleton . PolygonPath $ pg
polygonToPath (MultiPolygon vs hs) = Path . LSeq.fromNonEmpty . fmap PolygonPath
$ vs :| hs
pathToPolygon :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r))
pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of
[] -> Nothing
[pg] -> Just . Left $ pg
vs:hs -> Just . Right $ MultiPolygon vs hs
--------------------------------------------------------------------------------
-- | Use the first prism to select the ipe object to depicle with, and the second
-- how to select the geometry object from there on. Then we can select the geometry
-- object, directly with its attributes here.
--
-- >>> testObject ^? _withAttrs _IpePath _asPolyLine
-- Just (PolyLine {_points = LSeq (fromList [Point2 [0,0] :+ (),Point2 [10,10] :+ (),Point2 [200,100] :+ ()])} :+ Attrs {NoAttr, NoAttr, NoAttr, NoAttr, Attr IpeColor (Named "red"), NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr, NoAttr})
_withAttrs :: Prism' (IpeObject r) (i r :+ IpeAttributes i r) -> Prism' (i r) g
-> Prism' (IpeObject r) (g :+ IpeAttributes i r)
_withAttrs po pg = prism' g2o o2g
where
g2o = review po . over core (review pg)
o2g o = preview po o >>= \(i :+ ats) -> (:+ ats) <$> preview pg i
-- instance HasDefaultIpeObject Path where
-- defaultIpeObject' = _IpePath
-- class HasDefaultFromIpe g where
-- type DefaultFromIpe g :: * -> *
-- defaultIpeObject :: proxy g -> Prism' (IpeObject r) (DefaultFromIpe g r :+ IpeAttributes (DefaultFromIpe g) r)
-- defaultFromIpe :: proxy g -> Prism' (DefaultFromIpe g (NumType g)) g
class HasDefaultFromIpe g where
type DefaultFromIpe g :: * -> *
defaultFromIpe :: (r ~ NumType g)
=> Prism' (IpeObject r) (g :+ IpeAttributes (DefaultFromIpe g) r)
instance HasDefaultFromIpe (Point 2 r) where
type DefaultFromIpe (Point 2 r) = IpeSymbol
defaultFromIpe = _withAttrs _IpeUse _asPoint
where
instance HasDefaultFromIpe (LineSegment 2 () r) where
type DefaultFromIpe (LineSegment 2 () r) = Path
defaultFromIpe = _withAttrs _IpePath _asLineSegment
instance HasDefaultFromIpe (Ellipse r) where
type DefaultFromIpe (Ellipse r) = Path
defaultFromIpe = _withAttrs _IpePath _asEllipse
instance (Floating r, Eq r) => HasDefaultFromIpe (Circle () r) where
type DefaultFromIpe (Circle () r) = Path
defaultFromIpe = _withAttrs _IpePath _asCircle
instance (Floating r, Eq r) => HasDefaultFromIpe (Disk () r) where
type DefaultFromIpe (Disk () r) = Path
defaultFromIpe = _withAttrs _IpePath _asDisk
instance HasDefaultFromIpe (PolyLine.PolyLine 2 () r) where
type DefaultFromIpe (PolyLine.PolyLine 2 () r) = Path
defaultFromIpe = _withAttrs _IpePath _asPolyLine
instance HasDefaultFromIpe (SimplePolygon () r) where
type DefaultFromIpe (SimplePolygon () r) = Path
defaultFromIpe = _withAttrs _IpePath _asSimplePolygon
instance HasDefaultFromIpe (MultiPolygon () r) where
type DefaultFromIpe (MultiPolygon () r) = Path
defaultFromIpe = _withAttrs _IpePath _asMultiPolygon
-- | Read all g's from some ipe page(s).
readAll :: forall g r. (HasDefaultFromIpe g, r ~ NumType g)
=> IpePage r -> [g :+ IpeAttributes (DefaultFromIpe g) r]
readAll p = p^..content.traverse.defaultFromIpe
-- | Convenience function from reading all g's from an ipe file. If there
-- is an error reading or parsing the file the error is "thrown away".
readAllFrom :: forall g r. (HasDefaultFromIpe g, r ~ NumType g, Coordinate r, Eq r)
=> FilePath -> IO [g :+ IpeAttributes (DefaultFromIpe g) r]
readAllFrom fp = foldMap readAll <$> readSinglePageFile fp
fromSingleton :: a -> LSeq.LSeq 1 a
fromSingleton = LSeq.fromNonEmpty . (:| [])