hgeometry 0.12.0.1 → 0.12.0.2

raw patch · 4 files changed

+108/−170 lines, 4 filesdep −directorydep −filepathdep −reanimatedep ~basedep ~hashabledep ~hgeometry-combinatorialPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: directory, filepath, reanimate, reanimate-svg

Dependency ranges changed: base, hashable, hgeometry-combinatorial, lens, linear, text, vector, vector-circular

API changes (from Hackage documentation)

Files

• hgeometry.cabal +2/−26
• planargraph.hs +0/−136
• src/Data/Geometry/BezierSpline.hs +52/−8
• src/Data/Geometry/Polygon/Bezier.hs +54/−0

@@ -1,5 +1,5 @@ name:                hgeometry-version:             0.12.0.1+version:             0.12.0.2 synopsis:            Geometric Algorithms, Data structures, and Data types. description:   HGeometry provides some basic geometry types, and geometric algorithms and@@ -31,10 +31,6 @@   type:     git   location: https://github.com/noinia/hgeometry -flag planargraph-  default: False-  manual: True- library   ghc-options: -O2 -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults @@ -85,6 +81,7 @@                     Data.Geometry.Ellipse                      Data.Geometry.Polygon+                    Data.Geometry.Polygon.Bezier                     Data.Geometry.Polygon.Inflate                     Data.Geometry.Polygon.Convex                     Data.Geometry.Polygon.Monotone@@ -400,24 +397,3 @@                     , FlexibleInstances                     , FlexibleContexts                     , MultiParamTypeClasses--executable planargraph-  main-is: planargraph.hs-  if flag(planargraph)-    buildable: True-  else-    buildable: False-  default-language:     Haskell2010-  build-depends:  base,-                  vector,-                  vector-circular,-                  linear,-                  text,-                  hashable,-                  lens,-                  directory,-                  filepath,-                  hgeometry,-                  hgeometry-combinatorial,-                  reanimate,-                  reanimate-svg

@@ -1,136 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-module Main where--import Data.PlanarGraph.Immutable-import qualified Data.PlanarGraph.Mutable as Mut--import           Control.Lens          ()-import           Control.Monad.ST-import           Data.Ext-import           Data.Foldable         as F-import           Data.Geometry.Point-import           Data.Geometry.Polygon-import           Data.STRef-import           Data.Hashable-import qualified Data.Text             as T-import qualified Data.Vector           as V-import qualified Data.Vector.Circular  as CV-import           Graphics.SvgTree      (Number (..))-import           Linear.Metric-import           Linear.V2-import           Linear.Vector-import           Reanimate-import           Reanimate.Animation-import           System.Directory-import           System.FilePath-import Debug.Trace--graphs :: [PlanarGraph]-graphs =-  [ pgFromFaces [[0..2]]-  , pgFromFaces [[1,2,3]]-  , pgFromFaces [[0..3]]-  , pgFromFaces [[0..3],[4,3,2,1]]-  , let pg = pgFromFaces [[0..3]]-    in pgMutate pg $ \pg' -> do-          let he0 = Mut.halfEdgeFromId 0 pg'-              he4 = Mut.halfEdgeFromId 4 pg'-          _newEdge <- Mut.pgConnectVertices he0 he4-          return ()-  , pgFromFaces [[0,4,1],[0,1,2],[4,3,1],[4,5,3],[3,5,2],[2,5,0]]-  ]--main :: IO ()--- main = reanimate $ staticFrame (1/60) (fst test2)-main = do-  forM_ graphs savePlanarGraphSVG---- test1 = renderPlanarGraph (pgFromFaces [[0..2]])--- test2 = renderPlanarGraph (pgFromFaces [[0..3],[4,3,2,1]])--savePlanarGraphSVG :: PlanarGraph -> IO ()-savePlanarGraphSVG pg = do-    writeFile fileName svgOutput-    writeFile compactName compactOutput-  where-    svgOutput = renderSvg (Just $ Num 300) (Just $ Num 300) svg-    compactOutput = renderSvg (Just $ Num 300) (Just $ Num 300) compactSvg-    fileName = "planargraph-" ++ show (hash pg) <.> "svg"-    compactName = "planargraph-" ++ show (hash pg) <.> "compact" <.> "svg"-    defOpts = RenderOptions { disableHalfEdges = False }-    compactOpts = RenderOptions { disableHalfEdges = True }-    svg = renderPlanarGraph defOpts pg-    compactSvg = renderPlanarGraph compactOpts pg--data RenderOptions = RenderOptions-  { disableHalfEdges :: Bool }--renderPlanarGraph :: RenderOptions -> PlanarGraph -> SVG-renderPlanarGraph RenderOptions{..} pg = svg-  where-    vs = tutteEmbedding pg-    faces = pgFaces pg-    svg =-        withViewBox (screenBottom, screenBottom, screenHeight, screenHeight) $-        mkGroup-        [ mkBackground bgColor-        , mkGroup-          [ translate (x*scaleFactor) (y*scaleFactor) $-            mkGroup-            [ label-            , withFillOpacity 0 $ withStrokeColor "black" $ withStrokeWidth strokeWidth $-              -- mkRect (strokeWidth+svgWidth label*1.5) (strokeWidth+svgHeight label*1.5)-              translate 0 (-(svgHeight label+0.1)/2) $-              center $ mkLine (0,0) (svgWidth label*1.2,0)-            ]-          | face <- faces-          , let boundary = faceBoundary face pg-                poly = simpleFromPoints $ map ext-                        [ Point2 x y-                        | vId <- boundary-                        , let V2 x y = vs V.! vertexId vId-                        ]-                Point2 x y = centroid poly-                label = scale 0.5 $ center $ latex (T.pack $ show $ faceId face)-          ]-        , mkGroup-          [ mkGroup $-            [ withStrokeColor "black" $-              mkLine (tipX*scaleFactor, tipY*scaleFactor) (tailX*scaleFactor, tailY*scaleFactor)-            ] ++ if disableHalfEdges-              then []-              else -                [ translate (halfX*scaleFactor + angY) (halfY*scaleFactor - angX) $-                  labelTwin-                , translate (halfX*scaleFactor - angY) (halfY*scaleFactor + angX) $-                  labelEdge-                ]-          | edge <- pgEdges pg-          , let (tip, tail) = edgeHalfEdges edge-                V2 tipX tipY = vs V.! vertexId (halfEdgeVertex tip pg)-                V2 tailX tailY = vs V.! vertexId (halfEdgeVertex tail pg)-                (halfX,halfY) = (tipX + (tailX-tipX)/2, tipY + (tailY-tipY)/2)-                labelEdge = scale 0.4 $ center $ latex (T.pack $ show $ halfEdgeId tip)-                labelTwin = scale 0.4 $ center $ latex (T.pack $ show $ halfEdgeId tail)-                V2 angX angY = signorm (V2 tipX tipY - V2 tailX tailY) ^* 0.3-          ]-        , mkGroup-          [ translate (x*scaleFactor) (y*scaleFactor) $-            mkGroup-            [ withFillOpacity 1 $ withFillColor "white" $ withStrokeColor "black" $-              mkCircle 0.3-            , label ]-          | v <- map vertexId $ pgVertices pg-          , let V2 x y = vs V.! v-                label = scaleToWidth 0.2 $ center $ latex (T.pack $ show v)-          ]-        ]--strokeWidth = defaultStrokeWidth*0.5--bgColor :: String-bgColor = "white"--scaleFactor :: Double-scaleFactor = screenTop*0.8

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns         #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- |@@ -20,21 +21,26 @@   , snap    , pattern Bezier2, pattern Bezier3++  , colinear+  , lineApproximate+  , quadToCubic   ) where -import           Control.Lens hiding (Empty)-import qualified Data.Foldable as F+import           Control.Lens                 hiding (Empty)+import qualified Data.Foldable                as F+import           Data.Geometry.Line import           Data.Geometry.Point import           Data.Geometry.Properties import           Data.Geometry.Transformation import           Data.Geometry.Vector-import           Data.LSeq (LSeq)-import qualified Data.LSeq as LSeq-import           Data.Sequence (Seq(..))-import qualified Data.Sequence as Seq-import           Data.Traversable (fmapDefault,foldMapDefault)+import           Data.LSeq                    (LSeq)+import qualified Data.LSeq                    as LSeq+import           Data.Sequence                (Seq (..))+import qualified Data.Sequence                as Seq+import           Data.Traversable             (fmapDefault, foldMapDefault) import           GHC.TypeNats-import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck              as QC  -------------------------------------------------------------------------------- @@ -177,3 +183,41 @@ -- | Snap a point close to a Bezier curve to the curve. snap   :: (Arity d, Ord r, Fractional r) => BezierSpline n d r -> Point d r -> Point d r snap b = evaluate b . parameterOf b++-- If both control points are on the same side of the straight line from the start and end+-- points then the curve is guaranteed to be within 3/4 of the distance from the straight line+-- to the furthest control point.+-- Otherwise, if the control points are on either side of the straight line, the curve is+-- guaranteed to be within 4/9 of the maximum distance from the straight line to a control+-- point.+-- Also: 3/4 * sqrt(v) = sqrt (9/16 * v)+--       4/9 * sqrt(v) = sqrt (16/81 * v)+-- So: 3/4 * sqrt(v) < eps =>+--     sqrt(9/16 * v) < eps =>+--     9/16*v < eps*eps+-- | Return True if the curve is definitely completely covered by a line of thickness+--   twice the given tolerance. May return false negatives but not false positives.+colinear :: (Ord r, Fractional r) => r -> BezierSpline 3 2 r -> Bool+colinear eps (Bezier3 !a !b !c !d) = sqBound < eps*eps+  where ld = flip sqDistanceTo (lineThrough a d)+        sameSide = ccw a d b == ccw a d c+        maxDist = max (ld b) (ld c)+        sqBound+          | sameSide  = 9/16  * maxDist+          | otherwise = 16/81 * maxDist++-- | Approximate curve as line segments where no point on the curve is further away+--   from the nearest line segment than the given tolerance.+lineApproximate :: (Ord r, Fractional r) => r -> BezierSpline 3 2 r -> [Point 2 r]+lineApproximate eps bezier+  | colinear eps bezier =+    [ bezier^.controlPoints.to LSeq.head+    , bezier^.controlPoints.to LSeq.last ]+  | otherwise =+    let (b1, b2) = split 0.5 bezier+    in lineApproximate eps b1 ++ tail (lineApproximate eps b2)++-- | Convert a quadratic bezier to a cubic bezier.+quadToCubic :: (Fractional r) => BezierSpline 2 2 r -> BezierSpline 3 2 r+quadToCubic (Bezier2 a b c) =+  Bezier3 a ((1/3)*^(Point (toVec a ^+^ 2*^toVec b))) ((1/3)*^(Point (2*^ toVec b ^+^ toVec c))) c

@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Geometry.Polygon.Bezier+  ( PathJoin(..)+  , fromBeziers+  , approximate+  , approximateSome+  ) where++import           Control.Lens+import           Data.Ext+import           Data.Geometry.BezierSpline (BezierSpline, lineApproximate, pattern Bezier3)+import           Data.Geometry.Point+import           Data.Geometry.Polygon+import qualified Data.Vector.Circular       as CV++data PathJoin r+  = JoinLine+  | JoinCurve (Point 2 r) (Point 2 r)+  deriving (Show, Eq, Ord)++-- | Construct a polygon from a closed set of bezier curves. Each curve must be connected to+--   its neighbours.+fromBeziers :: (Eq r, Num r) => [BezierSpline 3 2 r] -> SimplePolygon (PathJoin r) r+fromBeziers curves+  | isCounterClockwise expanded = p+  | otherwise = p'+  where+    p = unsafeFromPoints+      [ a :+ JoinCurve b c+      | Bezier3 a b c _d <- curves ]+    p' = unsafeFromPoints+      [ d :+ JoinCurve c b+      | Bezier3 _a b c d <- reverse curves ]+    expanded = unsafeFromPoints $ concat+      [ map ext [a, b, c]+      | Bezier3 a b c _d <- curves ]++approximate :: forall t r. (Ord r, Fractional r) => r -> Polygon t (PathJoin r) r -> Polygon t () r+approximate eps p =+  case p of+    SimplePolygon{}  ->+      let vs = p^.outerBoundaryVector+      in unsafeFromCircularVector $ CV.concatMap f $ CV.zip vs (CV.rotateRight 1 vs)+    MultiPolygon v hs -> MultiPolygon (approximate eps v) (map (approximate eps) hs)+  where+    f :: (Point 2 r :+ PathJoin r, Point 2 r :+ PathJoin r) -> CV.CircularVector (Point 2 r :+ ())+    f (a :+ JoinLine, _) = CV.singleton (ext a)+    f (a :+ JoinCurve b c, d :+ _) =+      CV.unsafeFromList $ map ext $ init (lineApproximate eps (Bezier3 a b c d))++approximateSome :: (Ord r, Fractional r) => r -> SomePolygon (PathJoin r) r -> SomePolygon () r+approximateSome eps (Left p)  = Left $ approximate eps p+approximateSome eps (Right p) = Right $ approximate eps p