diff --git a/hgeometry.cabal b/hgeometry.cabal --- a/hgeometry.cabal +++ b/hgeometry.cabal @@ -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 diff --git a/planargraph.hs b/planargraph.hs deleted file mode 100644 --- a/planargraph.hs +++ /dev/null @@ -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 diff --git a/src/Data/Geometry/BezierSpline.hs b/src/Data/Geometry/BezierSpline.hs --- a/src/Data/Geometry/BezierSpline.hs +++ b/src/Data/Geometry/BezierSpline.hs @@ -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 diff --git a/src/Data/Geometry/Polygon/Bezier.hs b/src/Data/Geometry/Polygon/Bezier.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Polygon/Bezier.hs @@ -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