diff --git a/hgeometry-ipe.cabal b/hgeometry-ipe.cabal --- a/hgeometry-ipe.cabal +++ b/hgeometry-ipe.cabal @@ -1,5 +1,5 @@ name: hgeometry-ipe -version: 0.11.0.0 +version: 0.12.0.0 synopsis: Reading and Writing ipe7 files. description: Reading and Writing ipe7 files and converting them to and from HGeometry types. @@ -83,7 +83,6 @@ , linear >= 1.10 , semigroupoids >= 5 , semigroups >= 0.18 - , singletons >= 2.0 , text >= 1.1.1.0 , vinyl >= 0.10 , deepseq >= 1.1 @@ -94,8 +93,8 @@ , QuickCheck >= 2.5 , quickcheck-instances >= 0.3 - , hgeometry-combinatorial >= 0.11.0.0 - , hgeometry >= 0.11.0.0 + , hgeometry-combinatorial >= 0.12.0.0 + , hgeometry >= 0.12.0.0 -- , validation >= 0.4 @@ -117,12 +116,20 @@ -- , hslua + if impl(ghc == 9.*) + build-depends: singletons == 3.* + , singletons-th == 3.* + else + build-depends: singletons == 2.* hs-source-dirs: src -- examples/demo default-language: Haskell2010 + if impl(ghc >= 8.10) + default-extensions: StandaloneKindSignatures + default-extensions: TypeFamilies , GADTs , KindSignatures @@ -181,13 +188,18 @@ , vector , containers , random - , singletons , colour , filepath , directory , yaml , MonadRandom + if impl(ghc == 9.*) + build-depends: singletons == 3.* + , singletons-th == 3.* + else + build-depends: singletons == 2.* + default-extensions: TypeFamilies , GADTs , KindSignatures @@ -211,8 +223,6 @@ , DeriveFunctor , DeriveFoldable , DeriveTraversable - - , AutoDeriveTypeable , FlexibleInstances , FlexibleContexts diff --git a/src/Data/Geometry/Ipe/Content.hs b/src/Data/Geometry/Ipe/Content.hs --- a/src/Data/Geometry/Ipe/Content.hs +++ b/src/Data/Geometry/Ipe/Content.hs @@ -211,7 +211,7 @@ transformBy t (Group s) = Group $ fmap (transformBy t) s -type family AttributesOf (t :: * -> *) :: [u] where +type family AttributesOf (t :: * -> *) :: [AttributeUniverse] where AttributesOf Group = GroupAttributes AttributesOf Image = CommonAttributes AttributesOf TextLabel = CommonAttributes diff --git a/src/Data/Geometry/Ipe/FromIpe.hs b/src/Data/Geometry/Ipe/FromIpe.hs --- a/src/Data/Geometry/Ipe/FromIpe.hs +++ b/src/Data/Geometry/Ipe/FromIpe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Ipe.FromIpe @@ -105,7 +106,7 @@ pathToRect p = p^?_asSimplePolygon >>= asRect asRect :: SimplePolygon () r -> Maybe (Rectangle () r) - asRect pg = case pg^..outerBoundary.traverse of + 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 @@ -118,7 +119,7 @@ _asTriangle :: Prism' (Path r) (Triangle 2 () r) _asTriangle = prism' triToPath path2tri where - triToPath (Triangle p q r) = polygonToPath . fromPoints . map (&extra .~ ()) $ [p,q,r] + 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 @@ -162,16 +163,16 @@ polygonToPath :: Polygon t () r -> Path r -polygonToPath pg@(SimplePolygon _) = Path . fromSingleton . PolygonPath $ pg +polygonToPath pg@SimplePolygon{} = Path . fromSingleton . PolygonPath $ pg polygonToPath (MultiPolygon vs hs) = Path . LSeq.fromNonEmpty . fmap PolygonPath - $ (SimplePolygon vs) :| hs + $ vs :| hs pathToPolygon :: Path r -> Maybe (Either (SimplePolygon () r) (MultiPolygon () r)) pathToPolygon p = case p^..pathSegments.traverse._PolygonPath of - [] -> Nothing - [pg] -> Just . Left $ pg - SimplePolygon vs: hs -> Just . Right $ MultiPolygon vs hs + [] -> Nothing + [pg] -> Just . Left $ pg + vs:hs -> Just . Right $ MultiPolygon vs hs @@ -249,7 +250,7 @@ -- | Read all g's from some ipe page(s). -readAll :: (HasDefaultFromIpe g, r ~ NumType g) +readAll :: forall g r. (HasDefaultFromIpe g, r ~ NumType g) => IpePage r -> [g :+ IpeAttributes (DefaultFromIpe g) r] readAll p = p^..content.traverse.defaultFromIpe diff --git a/src/Data/Geometry/Ipe/IpeOut.hs b/src/Data/Geometry/Ipe/IpeOut.hs --- a/src/Data/Geometry/Ipe/IpeOut.hs +++ b/src/Data/Geometry/Ipe/IpeOut.hs @@ -22,10 +22,10 @@ import Data.Ext import Data.Foldable (toList) import Data.Geometry.Ball -import Data.Geometry.Ellipse(Ellipse, circleToEllipse) -import Data.Geometry.BezierSpline import Data.Geometry.Boundary import Data.Geometry.Box +import Data.Geometry.Ellipse (Ellipse, circleToEllipse) +import Data.Geometry.HalfLine import Data.Geometry.Ipe.Attributes import Data.Geometry.Ipe.Color (IpeColor(..)) import Data.Geometry.Ipe.FromIpe @@ -42,6 +42,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as Text +import Data.Vinyl (Rec(..)) import Data.Vinyl.CoRec import Linear.Affine ((.+^)) @@ -137,14 +138,12 @@ instance (Fractional r, Ord r) => HasDefaultIpeOut (Line 2 r) where type DefaultIpeOut (Line 2 r) = Path - defIO = ipeLineSegment . toSeg - where - b :: Rectangle () r - b = box (ext $ Point2 (-200) (-200)) (ext $ Point2 1200 1200) - naive (Line p v) = ClosedLineSegment (ext p) (ext $ p .+^ v) - toSeg l = fromMaybe (naive l) . asA @(LineSegment 2 () r) - $ l `intersect` b + defIO = ipeLine +instance (Fractional r, Ord r) => HasDefaultIpeOut (HalfLine 2 r) where + type DefaultIpeOut (HalfLine 2 r) = Path + defIO = ipeHalfLine + instance HasDefaultIpeOut (Polygon t p r) where type DefaultIpeOut (Polygon t p r) = Path defIO = ipePolygon @@ -185,6 +184,46 @@ -------------------------------------------------------------------------------- -- * Path Converters +-- | Size of the default bounding box used to clip lines and +-- half-lines in the default IpeOuts. +defaultBox :: Num r => Rectangle () r +defaultBox = let z = 1000 + z' = negate z + in box (ext $ Point2 z' z') (ext $ Point2 z z) + +-- | Renders a line as a Path. The line is clipped to the 'defaultBox' +ipeLine :: (Ord r, Fractional r) => IpeOut (Line 2 r) Path r +ipeLine = ipeLineIn defaultBox + +-- | Renders the line in the given box. +-- +-- pre: the intersection of the box with the line is non-empty +ipeLineIn :: forall p r. (Ord r, Fractional r) + => Rectangle p r -> IpeOut (Line 2 r) Path r +ipeLineIn bBox l = match (l `intersect` bBox) $ + H (\NoIntersection -> error "ipeLineIn: precondition failed, no intersection") + :& H (\(_p :: Point 2 r) -> error "ipeLineIn: precondition failed, single point") + :& H ipeLineSegment + :& RNil + +-- | Renders an Halfine. +-- +-- +-- pre: the intersection of the box with the line is non-empty +ipeHalfLine :: (Ord r, Fractional r) => IpeOut (HalfLine 2 r) Path r +ipeHalfLine = ipeHalfLineIn defaultBox + +-- | Renders the HalfLine in the given box. +-- +-- pre: the intersection of the box with the line is non-empty +ipeHalfLineIn :: forall p r. (Ord r, Fractional r) + => Rectangle p r -> IpeOut (HalfLine 2 r) Path r +ipeHalfLineIn bBox l = match (l `intersect` bBox) $ + H (\NoIntersection -> error "ipeHalfLineIn: precondition failed, no intersection") + :& H (\(_p :: Point 2 r) -> error "ipeHalfLineIn: precondition failed, single point") + :& H ipeLineSegment + :& RNil + ipeLineSegment :: IpeOut (LineSegment 2 p r) Path r ipeLineSegment s = (path . pathSegment $ s) :+ mempty @@ -192,7 +231,7 @@ ipePolyLine p = (path . PolyLineSegment . first (const ()) $ p) :+ mempty ipeEllipse :: IpeOut (Ellipse r) Path r -ipeEllipse = \e -> (path $ EllipseSegment e) :+ mempty +ipeEllipse = \e -> path (EllipseSegment e) :+ mempty ipeCircle :: Floating r => IpeOut (Circle p r) Path r ipeCircle = ipeEllipse . circleToEllipse @@ -210,13 +249,13 @@ -- | Draw a polygon ipePolygon :: IpeOut (Polygon t p r) Path r ipePolygon (first (const ()) -> pg) = case pg of - (SimplePolygon _) -> pg^.re _asSimplePolygon :+ mempty - (MultiPolygon _ _) -> pg^.re _asMultiPolygon :+ mempty + SimplePolygon{} -> pg^.re _asSimplePolygon :+ mempty + MultiPolygon{} -> pg^.re _asMultiPolygon :+ mempty -- | Draw a Rectangle ipeRectangle :: Num r => IpeOut (Rectangle p r) Path r -ipeRectangle r = ipePolygon $ fromPoints [tl,tr,br,bl] +ipeRectangle r = ipePolygon $ unsafeFromPoints [tl,tr,br,bl] where Corners tl tr br bl = corners r diff --git a/src/Data/Geometry/Ipe/Reader.hs b/src/Data/Geometry/Ipe/Reader.hs --- a/src/Data/Geometry/Ipe/Reader.hs +++ b/src/Data/Geometry/Ipe/Reader.hs @@ -5,6 +5,7 @@ readRawIpeFile , readIpeFile , readSinglePageFile + , readSinglePageFileThrow , ConversionError -- * Reading XML directly @@ -26,32 +27,33 @@ , Coordinate(..) ) where -import Control.Applicative((<|>)) +import Control.Applicative ((<|>)) import Control.Lens hiding (Const, rmap) +import Data.Bifunctor import qualified Data.ByteString as B import Data.Colour.SRGB (RGB(..)) import Data.Either (rights) import Data.Ext -import Data.Geometry.Box import Data.Geometry.BezierSpline -import Data.Geometry.Ellipse(ellipseMatrix) +import Data.Geometry.Box +import Data.Geometry.Ellipse (ellipseMatrix) import Data.Geometry.Ipe.Attributes +import Data.Geometry.Ipe.Color (IpeColor(..)) +import Data.Geometry.Ipe.Matrix import Data.Geometry.Ipe.ParserPrimitives (pInteger, pWhiteSpace) -import Data.Geometry.Ipe.PathParser import Data.Geometry.Ipe.Path -import Data.Geometry.Ipe.Matrix +import Data.Geometry.Ipe.PathParser import Data.Geometry.Ipe.Types import Data.Geometry.Ipe.Value -import Data.Geometry.Ipe.Color(IpeColor(..)) +import qualified Data.Geometry.Matrix as Matrix import Data.Geometry.Point import Data.Geometry.PolyLine import qualified Data.Geometry.Polygon as Polygon -import qualified Data.Geometry.Matrix as Matrix +import qualified Data.LSeq as LSeq import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe, mapMaybe) import Data.Proxy -import qualified Data.LSeq as LSeq import Data.Singletons import Data.Text (Text) import qualified Data.Text as T @@ -78,7 +80,7 @@ -- This function applies all matrices to objects. readIpeFile :: (Coordinate r, Eq r) => FilePath -> IO (Either ConversionError (IpeFile r)) -readIpeFile = fmap (bimap id applyMatrices) . readRawIpeFile +readIpeFile = fmap (second applyMatrices) . readRawIpeFile -- | Since most Ipe file contain only one page, we provide a shortcut for that @@ -94,6 +96,13 @@ f :: IpeFile r -> IpePage r f i = withDefaults . NonEmpty.head $ i^.pages +-- | Tries to read a single page file, throws an error when this +-- fails. See 'readSinglePageFile' for further details. +readSinglePageFileThrow :: (Coordinate r, Eq r) => FilePath -> IO (IpePage r) +readSinglePageFileThrow fp = readSinglePageFile fp >>= \case + Left err -> fail (show err) + Right p -> pure p + -- | Given a Bytestring, try to parse the bytestring into anything that is -- IpeReadable, i.e. any of the Ipe elements. fromIpeXML :: IpeRead (t r) => B.ByteString -> Either ConversionError (t r) @@ -101,7 +110,7 @@ -- | Reads the data from a Bytestring into a proper Node readXML :: B.ByteString -> Either ConversionError (Node Text Text) -readXML = bimap (T.pack . show) id . parse' defaultParseOptions +readXML = first (T.pack . show) . parse' defaultParseOptions -------------------------------------------------------------------------------- @@ -205,7 +214,7 @@ fromOps' _ [] = Left "Found only a MoveTo operation" fromOps' s (LineTo q:ops) = let (ls,xs) = span' _LineTo ops pts = map ext $ s:q:mapMaybe (^?_LineTo) ls - poly = Polygon.fromPoints . dropRepeats $ pts + poly = Polygon.unsafeFromPoints . dropRepeats $ pts pl = fromPointsUnsafe pts in case xs of (ClosePath : xs') -> PolygonPath poly <<| xs' @@ -242,8 +251,8 @@ ipeReadAttr _ _ = Left "IpeReadAttr: Element expected, Text found" -- | Combination of zipRecWith and traverse -zipTraverseWith :: forall f g h i (rs :: [u]). Applicative h - => (forall (x :: u). f x -> g x -> h (i x)) +zipTraverseWith :: forall f g h i (rs :: [AttributeUniverse]). Applicative h + => (forall (x :: AttributeUniverse). f x -> g x -> h (i x)) -> Rec f rs -> Rec g rs -> h (Rec i rs) zipTraverseWith _ RNil RNil = pure RNil zipTraverseWith f (x :& xs) (y :& ys) = (:&) <$> f x y <*> zipTraverseWith f xs ys diff --git a/src/Data/Geometry/Ipe/Writer.hs b/src/Data/Geometry/Ipe/Writer.hs --- a/src/Data/Geometry/Ipe/Writer.hs +++ b/src/Data/Geometry/Ipe/Writer.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | @@ -22,41 +22,42 @@ , ipeWriteAttrs, writeAttrValues ) where -import Control.Lens (view, (^.), (^..), (.~), (&)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Colour.SRGB (RGB(..)) +import Control.Lens (view, (&), (.~), (^.), (^..)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.Colour.SRGB (RGB (..)) import Data.Ext import Data.Fixed -import qualified Data.Foldable as F +import qualified Data.Foldable as F +import Data.Geometry.BezierSpline import Data.Geometry.Box -import Data.Geometry.Ellipse(ellipseMatrix) +import Data.Geometry.Ellipse (ellipseMatrix) import Data.Geometry.Ipe.Attributes import qualified Data.Geometry.Ipe.Attributes as IA -import Data.Geometry.Ipe.Color (IpeColor(..)) -import Data.Geometry.Ipe.Types +import Data.Geometry.Ipe.Color (IpeColor (..)) import Data.Geometry.Ipe.Path +import Data.Geometry.Ipe.Types import Data.Geometry.Ipe.Value import Data.Geometry.LineSegment +import qualified Data.Geometry.Matrix as Matrix import Data.Geometry.Point -import Data.Geometry.BezierSpline import Data.Geometry.PolyLine -import Data.Geometry.Polygon (Polygon, outerBoundary, holeList, asSimplePolygon) -import qualified Data.Geometry.Matrix as Matrix +import Data.Geometry.Polygon (Polygon, holeList, outerBoundary, + outerBoundaryVector) import Data.Geometry.Vector -import qualified Data.LSeq as LSeq -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (catMaybes, mapMaybe, fromMaybe) +import qualified Data.LSeq as LSeq +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Ratio import Data.RealNumber.Rational import Data.Singletons -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Vinyl hiding (Label) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vinyl hiding (Label) import Data.Vinyl.Functor import Data.Vinyl.TypeLevel -import System.IO (hPutStrLn,stderr) -import Text.XML.Expat.Format (format') +import System.IO (hPutStrLn, stderr) +import Text.XML.Expat.Format (format') import Text.XML.Expat.Tree -------------------------------------------------------------------------------- @@ -297,9 +298,9 @@ -- the polyline type guarantees that there is at least one point instance IpeWriteText r => IpeWriteText (Polygon t () r) where - ipeWriteText pg = fmap mconcat . traverse f $ asSimplePolygon pg : holeList pg + ipeWriteText pg = fmap mconcat . traverse f $ pg^.outerBoundary : holeList pg where - f pg' = case pg'^..outerBoundary.traverse.core of + f pg' = case pg'^..outerBoundaryVector.traverse.core of (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest ++ [ClosePath] _ -> Nothing diff --git a/src/Data/Geometry/QuadTree/Draw.hs b/src/Data/Geometry/QuadTree/Draw.hs --- a/src/Data/Geometry/QuadTree/Draw.hs +++ b/src/Data/Geometry/QuadTree/Draw.hs @@ -9,11 +9,8 @@ import Data.Geometry.Ipe.Types import Data.Geometry.QuadTree import Data.Geometry.QuadTree.Cell -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T import Data.Tree.Util (TreeNode(..)) -import Data.Vinyl.Notation -import Data.Vinyl.Core -------------------------------------------------------------------------------- drawCell :: Fractional r => IpeOut (Cell r) Path r diff --git a/src/Data/Geometry/Triangulation/Draw.hs b/src/Data/Geometry/Triangulation/Draw.hs --- a/src/Data/Geometry/Triangulation/Draw.hs +++ b/src/Data/Geometry/Triangulation/Draw.hs @@ -10,5 +10,5 @@ drawTriangulation :: IpeOut (Triangulation p r) Group r drawTriangulation tr = ipeGroup [ iO $ ipeLineSegment e - | e <- map (uncurry ClosedLineSegment) . triangulationEdges $ tr + | e <- map (uncurry ClosedLineSegment) . edgesAsPoints $ tr ]