packages feed

hgeometry 0.4.0.0 → 0.5.0.0

raw patch · 82 files changed

+8913/−1183 lines, 82 filesdep +Framesdep +directorydep +hspecdep −validationdep ~basedep ~bifunctorsdep ~bytestringnew-component:exe:hgeometry-examples

Dependencies added: Frames, directory, hspec, optparse-applicative, semigroupoids, template-haskell, time

Dependencies removed: validation

Dependency ranges changed: base, bifunctors, bytestring, containers, data-clist, fixed-vector, hexpat, lens, linear, semigroups, singletons, text, vector, vinyl

Files

README.md view
@@ -22,13 +22,18 @@  Please note that aspect (2), implementing good algorithms, is much work in progress. HGeometry currently has only very basic types, and implements only-two algorithms: an (optimal) $O(n \log n)$ time algorithm for convex hull, and-an $O(n)$ expected time algorithm for smallest enclosing disk (both in $R^2$).+a few algorithms: -Current work is on implementing $O(n \log n + k)$ time red-blue line segment-intersection. This would also allow for efficient polygon intersection and map-overlay.+* two (optimal) $O(n \log n)$ time algorithms for convex hull in+  $\mathbb{R}^2$: the typical Graham scan, and a divide and conqueror algorithm,+* an $O(n)$ expected time algorithm for smallest enclosing disk in $\mathbb{R}^$2,+* the well-known Douglas Peucker polyline line simplification algorithm,+* an $O(n \log n)$ time algorithm for computing the Delaunay triangulation+(using divide and conqueror).+* an $O(n \log n)$ time algorithm for computing the Euclidean Minimum Spanning+Tree (EMST), based on computing the Delaunay Triangulation. + A Note on the Ext (:+) data type --------------------------------- @@ -59,6 +64,6 @@ Reading and Writing Ipe files ----------------------------- -Appart from geometric types, HGeometry provides some interface for reading and-writing Ipe (http://ipe7.sourceforge.net). However, this is all very work in+Apart from geometric types, HGeometry provides some interface for reading and+writing Ipe (http://ipe.otfried.org). However, this is all very work in progress. Hence, the API is experimental and may change at any time!
doctests.hs view
@@ -16,20 +16,41 @@            , "PatternSynonyms"           , "ViewPatterns"+          , "TupleSections"+          , "MultiParamTypeClasses"+          , "LambdaCase"            , "StandaloneDeriving"           , "GeneralizedNewtypeDeriving"+          , "DeriveFunctor"+          , "DeriveFoldable"+          , "DeriveTraversable"+          , "AutoDeriveTypeable"           , "FlexibleInstances"           , "FlexibleContexts"           ] -files = geomModules+files = mconcat [ geomModules+                , dataModules+                ] -geomModules = map ("src/Data/Geometry/" <>) [ "Point.hs"-                                            , "Vector.hs"-                                            , "Line.hs"-                                            , "LineSegment.hs"-                                            , "PolyLine.hs"-                                            , "Ball.hs"-                                            , "Box.hs"-                                            ]+prefixWith s = map (\s' -> "src/" <> s <> s')+++dataModules = prefixWith "Data/" [ "Range.hs"+                                 , "CircularList/Util.hs"+                                 , "Permutation.hs"+                                 , "CircularSeq.hs"+                                 , "PlanarGraph.hs"+                                 ]++geomModules = prefixWith "Data/Geometry/" [ "Point.hs"+                                          , "Vector.hs"+                                          , "Line.hs"+                                          , "Line/Internal.hs"                                                                        , "Interval.hs"+                                          , "LineSegment.hs"+                                          , "PolyLine.hs"+                                          , "Polygon.hs"+                                          , "Ball.hs"+                                          , "Box.hs"+                                          ]
+ examples/BAPC2012/Gunslinger.hs view
@@ -0,0 +1,146 @@+module BAPC2012.Gunslinger where++import           Algorithms.Geometry.ConvexHull.GrahamScan+import           Control.Lens+import qualified Data.CircularSeq as C+import qualified Data.Foldable as F+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Ext+import           Data.Fixed+import           Data.Geometry.Point+import           Data.Geometry.Polygon+import qualified Data.List     as L+import           Data.Maybe+import           Linear.Affine(distanceA)++{-++Credits: http://2012.bapc.eu/++Problem Statement+=================++The quickly shooting, maiden saving, gunslinging cowboy Luke finds himself in+the den of his archenemy: the Dalton gang. He is trying to escape but is in+constant danger of being shot. Fortunately his excellent marksmanship and quick+reflexes give him the upper hand in a firefight: the gang members are all too+scared to move, let alone draw their guns. That is, as long as Luke can see+them. If he cannot see one of the thugs, then that Dalton will immediately fire+upon Luke and kill the cowboy without fear of retaliation. Luke’s amazing+eyesight allows him to cover a field of view of 180 degrees all the time. While+doing so he can move around freely, even walking backward if necessary.  Luke’s+goal is to walk to the escape hatch in the den while turning in such a way that+he will not be shot. He does not want to shoot any of the Daltons because that+will surely result in a big fire fight. The Daltons all have varying heights,+but you may assume that all the people and the hatch are of infinitesimal size.++Input+-----++On the first line one positive number: the number of test cases, at most+100. After that per test case:++* one line with two space-separated integers xL and yL: Luke’s starting position.+* one line with two space-separated integers xE and yE : the position of the escape hatch.+* one line with an integer n (1 <= n <= 1 000): the number of Dalton gang members.+* n lines with two space-separated integers xi and yi: the position of the i-th Dalton.++All x and y are in the range −10000 <= x,y <= 10000. Luke, the escape hatch and+all Daltons all have distinct positions.++Output+-----++Per test case:++* one line with the length of the shortest path Luke can take to the escape+hatch without dying, rounded to three decimal places, or “IMPOSSIBLE” if no+such path exists.  The test cases are such that an absolute error of at most+10^−6 in the final answer does not influence the result of the rounding.+++Solution+========++Compute the convex hull of Luke, the hatch, and the daltons. If luke and the+hatch are on the convex hull, Luke can safely reach it. The length of the+shortest path is the lenght of walking along the convex hull (in one of the two+directions). If luke or the hatch is not on the Convex Hull, escaping is+impossible.++Running time: O(n log n)++-}++data Answer = Possible Double | Impossible deriving (Eq,Ord)++instance Show Answer where+  show Impossible   = "IMPOSSIBLE"+  show (Possible l) = showFixed False  . roundToMili $ l+    where+      roundToMili :: Real a => a -> Milli+      roundToMili = realToFrac+++data Kind = Luke | Hatch | Dalton deriving (Show,Eq)++++data Input = Input { _luke  :: Point 2 Int+                   , _hatch :: Point 2 Int+                   , _daltons :: [Point 2 Int]+                   } deriving (Show,Eq)++-- TODO: THis only works if there are no colinear points. I.e. if Luke or the+-- hatch lie on the hull, but in the interior of some edge, they are not+-- contained in the hull.+escape                :: Input -> Answer+escape (Input l h ds) = case convexHull . NonEmpty.fromList $+                               (l :+ Luke) : (h :+ Hatch) : map (:+ Dalton) ds of+    -- all positions are distinct, so the hull has at least two elements+    ConvexHull poly -> case C.findRotateTo (\p -> p^.extra == Luke) $+                              poly^.outerBoundary of+      Nothing -> Impossible+      Just h  -> (distanceToHatch $ C.leftElements h)+                 `min`+                 (distanceToHatch $ C.rightElements h)+++toHatch    :: [p :+ Kind] -> Maybe [p :+ Kind]+toHatch xs = let (ys,rest) = L.break (\p -> p^.extra == Hatch) xs+             in case rest of+               []    -> Nothing+               (h:_) -> Just $ ys ++ [h]+++distanceAlong     :: [Point 2 Int :+ k] -> Double+distanceAlong xs' = sum $ zipWith distanceA xs (tail xs)+  where+    xs = map (fmap fromIntegral . (^.core)) xs'+++-- Distance from luke, at the head of the list, to the hatch while walking+-- along the points in the list.+distanceToHatch :: Foldable f => f (Point 2 Int :+ Kind) -> Answer+distanceToHatch = maybe Impossible (Possible . distanceAlong) . toHatch . F.toList+++readPoint   :: String -> Point 2 Int+readPoint s = let [x,y] = map read . words $ s in point2 x y+++readInput                 :: [String] -> [Input]+readInput []              = []+readInput (ls:hs:ns:rest) = let n            = read ns+                                (daltons,ys) = L.splitAt n rest+                            in Input (readPoint ls)+                                     (readPoint hs)+                                     (map readPoint daltons)+                               : readInput ys+++gunslinger :: String -> String+gunslinger = unlines . map (show . escape) . readInput . tail . lines++main :: IO ()+main = interact gunslinger
+ examples/BAPC2014/Armybase.lhs view
@@ -0,0 +1,300 @@+---+title: Army Base with Ternary Search+author: Frank Staals+@EXPECTED_RESULTS@: CORRECT+---++Army Base with Ternary Search+=============================++$O(n^2 \log n)$ solution.++++> {-# LANGUAGE GeneralizedNewtypeDeriving #-}+> module BAPC2014.Armybase where++> import Control.Applicative+> import Control.Lens((^.))+> import Data.Monoid+> import Data.Ix+> import Data.Ext++> import Data.Geometry.Triangle+> import Data.Geometry.Point+> import Data.Geometry.Polygon+> import Algorithms.Geometry.ConvexHull.GrahamScan+> import qualified Data.Array   as A+> import qualified Data.Foldable as F+> import qualified Data.List     as L+> import qualified Data.List.NonEmpty as NonEmpty++Preliminaries+-------------+++> type PointSet = [Point 2 Int]+++A value of type Half should still be halved. I.e. 'Half 2x = x'++> newtype Half = Half Int+>                        deriving (Show,Eq,Ord)++> instance Num Half where+>   (Half a) + (Half b) = Half $ a + b+>   (Half a) - (Half b) = Half $ a - b+>   (Half a) * (Half b) = Half $ a * b+>   abs (Half a) = Half $ abs a+>   signum (Half a) = Half $ 2 * signum a+>   fromInteger a = Half $ 2 * fromInteger a++> showValue :: Half -> String+> showValue (Half i) = concat [ show $ i `div` 2+>                             , if odd i then ".5" else ""+>                             ]+>   where+>     odd x = x `mod` 2 /= 0+++> type Area = Half++++> triangArea :: Triangle p Int -> Half+> triangArea = Half . doubleArea+++++TODO: Discuss degenerate cases here+++Let $V(Q)$ denote the vertices of polygon $Q$, and let $\mathcal{CH}(P)$ denote+the convex hull of the set of points $P$.+++<div class="lemma">+There is an maximum area quadrangle $Q^*$, such that $V(Q^*) \subseteq+V(\mathcal{CH}(P))$.+</div>++<div class="proof">+TODO+</div>+++Main Algorithm+---------------++> maxBaseArea    :: PointSet -> Area+> maxBaseArea [] = 0+> maxBaseArea p  = case convexHull . NonEmpty.fromList $ map ext p of+>     ch@(ConvexHull h) -> case F.toList $ h ^. outerBoundary of+>                            [_,_]   -> 0+>                            [a,b,c] -> triangArea $ Triangle a b c+>                            _       -> maxAreaQuadrangle ch+++<div class="observation">+Left an Right chains are independent+</div>++Main idea: Pick two non-adjacent vertices $p$ and $q$ of the convex hull as the+diagonals of our quadrangle. This splits the problem into two independent+subproblems, in both of which we have to find the largest triangle that has $p$+and $q$ as vertices.++> maxAreaQuadrangle :: ConvexHull () Int -> Area+> maxAreaQuadrangle = maximum' . map (uncurry3 maxAreaQuadrangleWith) . allChains+>   where+>     uncurry3 f (a,b,c) = f a b c+>     maximum' = L.foldl1' max -- saves memory :)++the function `allChains` finds all alowed pairs $p$ and $q$, and the chains of+vertices (along the convex hull) connecting $p$ to $q$ and $q$ to $p$.++> type Chain = Array Int (Point 2 Int)++> allChains                 :: ConvexHull () Int+>                           -> [(Point 2 Int, Point 2 Int, (Chain,Chain))]+> allChains (ConvexHull ch) =+>     [ (chA ! i, chA ! j, chains chA i j) | i <- [1..n-2], j <- rest i ]+>   where+>     n   = F.length $ ch^.outerBoundary+>     chA = listArray (1,n) . map (^.core) . F.toList $ ch^.outerBoundary+>     rest i = [i+2.. if i == 1 then n - 1 else n ]++we make sure that we only select non-neighbouring pairs. Hence the i+2 in rest+i. Then also the last valid start-point p is the one with index n-2.++To make sure `allChains` runs in $O(n^2)$ time we build an Array representing+our convex hull vertices. All individiual chains are then views of this underlying array:++> chains          :: Array Int a -> Int -> Int -> (Array Int a, Array Int a)+> chains a pi qi = (ixSubMap (1,qi-pi-1) fu a, ixSubMap (1,r + pi - 1) fv a)+>   where+>     n    = rangeSize . bounds $ a+>     r    = n - qi+>     fu i = pi + i+>     fv i = if i <= r then qi + i+>                      else i - r++We then use `maxAreaQuadrangleWith` to find the largest quadrangle given its+diagonals $p$ and $q$ (and the chains connecting $p$ and $q$).++> maxAreaQuadrangleWith             :: Point 2 Int -> Point 2 Int -> (Chain,Chain) -> Area+> maxAreaQuadrangleWith p q (us,vs) = let pqu = findLargestTriang p q (Unimodal us)+>                                         pqv = findLargestTriang q p (Unimodal vs)+>                                     in (pqu `seq` triangArea pqu)+>                                      + (pqv `seq` triangArea pqv)+++To efficiently find the largest triangle we use that the area is a unimodal+function along the convex hull. We prove this in the following lemmas.++<div class="lemma">+Let $p$ and $q$ be points on the convex hull $\mathcal{CH}(P)$, and let+$\mathcal{C}$ denote the portion of $\partial$\mathcal{CH}(P)$ between $p$ and+$q$. The area $a(v)$ of the triangle $\Delta pqv$, with $v \in \mathcal{C}$+depends only on the (Euclidean) distance $d(v)$ between $v$ and the line+segment $\overline{pq}$. More specifically, we have $a(v) = cd(v)$, for some+constant $c$.+</div>++<div class="proof">+TODO+</div>++<div class="observation">+Let $p$ and $q$ be points on the convex hull $\mathcal{CH}(P)$, let+$\mathcal{C}$ denote the portion of $\partial$\mathcal{CH}(P)$ between $p$ and+$q$, and let $v(t)$, with $t \in [0,1]$ denote the position along+$\mathcal{C}$. The function $d(t)$ expressing the (Euclidean) distance between+$v(t)$ and line segment $\overline{pq}$ is unimodal.+</div>++<div class="lemma">+Let $p$ and $q$ be points on the convex hull $\mathcal{CH}(P)$, let+$\mathcal{C}$ denote the portion of $\partial$\mathcal{CH}(P)$ between $p$ and+$q$, and let $v(t)$, with $t \in [0,1]$ denote the position along+$\mathcal{C}$. The function $a(t)$ expressing the area of the triangle $\Delta pqv(t)$ is unimodal.+</div>++<div class="proof">+Directly from previous lemma and observation.+</div>++This means we can find the triangle $\Delta pqv_i$ in $O(\log n)$ time using a+ternary search.+++> newtype Unimodal s a = Unimodal { unU :: s a }+>                      deriving (Show,Eq,Ord,Read,Functor)+++> findLargestTriang        :: Point 2 Int -> Point 2 Int+>                          -> Unimodal (Array Int) (Point 2 Int) -> Triangle () Int+> findLargestTriang p q us = triang . ternarySearchArray area' $ us+>   where+>     triang v = Triangle (ext p) (ext q) (ext v)+>     area' = triangArea . triang+++Ternary Search+--------------++> ternarySearchArray            :: (Ix i, Integral i, Ord b)+>                               => (a -> b) -> Unimodal (Array i) a -> a+> ternarySearchArray f (Unimodal a)+>   | rangeSize (bounds a) == 0 = error "empty array"+>   | otherwise                 = let (l,u) = bounds a+>                                     i     = ternarySearch (\i -> f $ a ! i) (pred l) (succ u)+>                                 in a ! i++Given a function $f$, a lowerbound $\ell$, and a n upperbound $u$ find the+value $i \in (\ell,u)$ such that $f i$ is maximal.++> ternarySearch          :: (Integral r, Ord a) => (r -> a) -> r -> r -> r+> ternarySearch f l u++>   | u - l < 2  = error "ternarySearch: l and u too close"+>   | u - l == 2 = l + 1+>   | otherwise  = let t = (u - l) `div` 3+>                      n = l + t+>                      m = l + 2*t+>                  in if f n > f m then ternarySearch f l m+>                                  else ternarySearch f n u+++Input & Output+--------------++> readPointSet :: [String] -> PointSet+> readPointSet = map readPoint+>   where+>     readPoint s = let [x,y] = map read . words $ s in point2 x y++> readInput           :: [String] -> [PointSet]+> readInput []        = []+> readInput (ns:rest) = let n       = read ns+>                           (xs,ys) = L.splitAt n rest+>                       in readPointSet xs : readInput ys+++> armybase :: String -> String+> armybase = unlines . map (showValue . maxBaseArea) . readInput . tail . lines+++> main :: IO ()+> main = interact armybase+++> show' (p,q,(a,b)) = (p,q,elems a, elems b)++Array Stuff+-----------++> data Array i a = Array { bounds       :: (i,i)+>                        , accessTransf :: i -> i+>                        , arrayData    :: A.Array i a+>                        }++> instance Ix i => Functor (Array i) where+>   fmap f (Array b g a) = Array b g (fmap f a)++> instance (Show i, Show a, A.Ix i) => Show (Array i a) where+>   show a@(Array bs g _) = concat [ "Array "+>                                  , show bs+>                                  , " "+>                                  , show $ assocs a+>                                  ]+++> (!) :: Ix i => Array i a -> i -> a+> (Array _ g a) ! i = a A.! (g i)++> elems                   :: Ix i => Array i a -> [a]+> elems a = [ a ! i | i <- A.range $ bounds a ]++> listArray   :: Ix i => (i,i) -> [a] -> Array i a+> listArray b = Array b id . A.listArray b++> assocs :: A.Ix i => Array i a -> [(i,a)]+> assocs (Array _ g a) = (\(k,v) -> (g k, v)) <$> A.assocs a++> ixSubMap :: Ix i => (i,i) -> (i -> i) -> Array i a -> Array i a+> ixSubMap bs f (Array obs g a) = Array bs (g . f) a++++Testing stuff+-------------++-- > testPs :: PointSet+-- > testPs = [Point (0,0), Point (2,2), Point (4,1), Point (5,0), Point (3,-1)]++-- > test2 = [Point (0,0), Point (-2,-2), Point (3,-2), Point (0,1), Point (0,3)]+++-- > testPs3 = [Point (-16,0), Point (16,16), Point (16,-16), Point (-16,16), Point (-16,-16)]
+ examples/Demo/Delaunay.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Demo.Delaunay where++import           Algorithms.Geometry.EuclideanMST.EuclideanMST+import           Algorithms.Geometry.DelaunayTriangulation.DivideAndConqueror+import           Algorithms.Geometry.DelaunayTriangulation.Types+import           Control.Applicative+import           Control.Lens+import           Data.Data+import           Data.Ext+import           Data.Geometry+import           Data.Geometry.Ipe+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Traversable+import           Options.Applicative+++data Options = Options { _inPath    :: FilePath+                       , _outFile   :: FilePath+                       }+               deriving Data++options :: ParserInfo Options+options = info (helper <*> parser)+               (  progDesc "Compute the Delaunay Triangulation of the points in the input file."+               <> header   "Delaunay"+               )+  where+    parser = Options+          <$> strOption (help "Input file (in ipe7 xml format)"+                         <> short 'i'+                        )+          <*> strOption (help "Output File (in ipe7 xml format)"+                         <> short 'o'+                        )++mainWith                          :: Options -> IO ()+mainWith (Options inFile outFile) = do+    ePage <- readSinglePageFile inFile+    case ePage of+      Left err                         -> print err+      Right (page :: IpePage Rational) -> case page^..content.traverse._IpeUse of+        []         -> putStrLn "No points found"+        syms@(_:_) -> do+           let pts  = syms&traverse.core %~ (^.symbolPoint)+               pts' = NonEmpty.fromList pts+               dt   = delaunayTriangulation $ pts'+               emst = euclideanMST pts'+               out  = [asIpe drawTriangulation dt, asIpe drawTree' emst]+           -- print $ length $ edges' dt+           -- print $ toPlaneGraph (Proxy :: Proxy DT) dt+           writeIpeFile outFile . singlePageFromContent $ out+++data DT++--xs = [(1,(1,1)) , (2,(2,2)) ]
+ examples/Demo/DrawGPX.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+module Demo.DrawGPX where++import           Algorithms.Geometry.PolyLineSimplification.DouglasPeucker+import           Control.Applicative+import           Control.Lens+import           Data.Data+import           Data.Ext+import qualified Data.Foldable as F+import           Data.Geometry+import           Data.Geometry.PolyLine+import           Data.Geometry.Ipe+import           Data.Geometry.Vector+import           Data.List (isSuffixOf)+import           Data.Maybe+import qualified Data.Sequence as S+import qualified Data.Text as T+import           Data.Time.Calendar+import           Data.Time.Clock+import           Demo.GPXParser+import           Options.Applicative+import           System.Directory+import           Text.Printf (printf)+++--------------------------------------------------------------------------------++data Options = Options { _inPath  :: FilePath+                       , _outPath :: FilePath+                       }+               deriving Data++options :: ParserInfo Options+options = info (helper <*> parser)+               (  progDesc "Draws gpx trajectories in ipe"+               <> header   "DrawGPX"+               )+  where+    parser = Options+          <$> strOption (help "Input Directory"+                         <> short 'i'+                         <> metavar "INDIR"+                        )+          <*> strOption (help "Output File"+                         <> short 'o'+                         <> metavar "TARGET"+                        )++--------------------------------------------------------------------------------++mainWith                          :: Options -> IO ()+mainWith (Options inPath outPath) = do+    let inPath' = inPath ++ "/"+    files <- map (inPath' ++) . filter (isSuffixOf ".gpx")+         <$> getDirectoryContents inPath'+    tks   <- concatMap (_tracks . combineTracks) <$> mapM readGPXFile files+    let polies  = mapMaybe asPolyLine tks+        polies' = map (douglasPeucker 0.01 . scaleUniformlyBy 100) polies+        pg = singlePageFromContent $ map (asIpeObject' mempty) polies'+    -- print pg+    writeIpeFile outPath pg+++colors :: [T.Text]+colors = map (T.unwords . map (T.pack . printf "%.4f" . (/ 256.0))) colors'+  where+    colors' :: [[Double]]+    -- colors' = [ [84,48,5]+    --           , [140,81,10]+    --           , [191,129,45]+    --           , [223,194,125]+    --           , [246,232,195]+    --           , [245,245,245]+    --           , [199,234,229]+    --           , [128,205,193]+    --           , [53,151,143]+    --           , [1,102,94]+    --           , [0,60,48]+    --           , [0,0,0]+    --           ]+    colors' = [ [166,206,227]+              , [31,120,180]+              , [178,223,138]+              , [51,160,44]+              , [251,154,153]+              , [227,26,28]+              , [253,191,111]+              , [255,127,0]+              , [202,178,214]+              , [106,61,154]+              , [255,255,153]+              , [177,89,40]+              ]++-- readCoords    :: FilePath -> IO (PolyLine 2 () Double)+-- readCoords fp = fromPoints .+--                 map ((\[x,y] -> point2 x y :+ ()) . map read . words) . lines+--              <$> readFile fp++-- readCoords'    :: FilePath -> IO [PolyLine 2 () Double]+-- readCoords' fp = mapMaybe (fmap fromPoints . g . f)  .  group' . lines <$> readFile fp+--   where+--     f = map ((\[x,y] -> point2 x y :+ ()) . map read . words)+--     g xs@(_:_:_) = Just xs+--     g _          = Nothing++-- group' lst = case break (== "NL") lst of+--                ([],[]) -> []+--                ([],"NL":r) -> group' r+--                (pr,"NL":r) -> pr:group' r+--                (pr,[])     -> [pr]++++-- maps = mapM (\f -> readCoords $ "/Users/frank/tmp/bikerides/maps/" ++ f)+--        [ "nld_coords.txt"+--        , "bel_coords.txt"+--        , "dnk_coords.txt"+--        , "fra_coords.txt"+--        ]++-- --   do+-- --     nld <- readCoords+-- --     writePolyLineFile "/tmp/nld.ipe" $  map (flip stroke "black") [nld]+++++++asPolyLine :: Track -> Maybe (PolyLine 2 UTCTime Double)+asPolyLine = fmap fromPoints . f . map toPt . _trackPoints+  where+    f xs@(_:_:_) = Just xs+    f _          = Nothing++toPt :: TrackPoint -> Point 2 Double :+ Time+toPt (TP (pos :+ t)) = point2 (pos^.longitude) (pos^.latitude) :+ t++ssFactor = 1++worldWidth  = 1000+worldHeight = 1000+world = (worldWidth,worldHeight)++-- colors = [ "red" , "purple" , "blue" , "green" , "orange"  ]++strokeByMonth p = stroke p c+  where+    dt = p^.points.to F.toList.to head.extra+    (_,m,_) = toGregorian $ utctDay dt+    c = colors !! (m -1)++stroke p c = (p&points.traverse.extra .~ (),[("stroke",c)])+++groupsOf      :: Int -> [a] -> [[a]]+groupsOf _ [] = []+groupsOf k xs = let (ys,xss) = splitAt k xs in ys : groupsOf k xss++subsample   :: Int -> [a] -> [a]+subsample k = map head . groupsOf k++subsampleTrack   :: Int -> Track -> Track+subsampleTrack k = over trackPoints (subsample k)+++-- | Given the width and height of the map and a Position, compute a Mercato Projection of+-- the position. See+-- <http://en.wikipedia.org/wiki/Mercator_projection#Derivation_of_the_Mercator_projection+-- WikiPedia> for more info.+mercatoProject                    :: (Double,Double)+                                  -> Position+                                  -> Point 2 Double+mercatoProject (width,height) pos = point2 x y+  where+    x    =                (width / 360)    * pos^.longitude+    y    = (height / 2) - (width / (2*pi)) * (log . tan $ (pi / 4) + (latR / 2))+    latR = -1 * pos^.latitude * pi / 180
+ examples/Demo/GPXParser.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+module Demo.GPXParser where+++import qualified Data.ByteString.Lazy as B++import           Control.Applicative+import           Control.Monad+import           Data.Maybe+import           Data.Time.Clock+import           Data.Time.Format+import           Text.XML.Expat.Tree++import           Control.Lens++import           Data.Geometry.Point+import           Data.Ext++import           Debug.Trace++--------------------------------------------------------------------------------++type Time = UTCTime++newtype Position = Position {_unP :: Point 2 Double}  deriving (Show,Eq)+makeLenses ''Position++latitude :: Lens' Position Double+latitude = unP.xCoord++longitude :: Lens' Position Double+longitude = unP.yCoord+++newtype TrackPoint = TP {_unTP :: Position :+ Time} deriving (Show,Eq)+makeLenses ''TrackPoint++newtype Track = Track { _trackPoints :: [TrackPoint] } deriving (Show,Eq)+makeLenses ''Track++newtype Activity = Activity { _tracks :: [Track]} deriving (Show,Eq)+makeLenses ''Activity+++combineTracks (Activity ts) = Activity [Track $ concatMap _trackPoints ts]+++readGPXFile    :: FilePath -> IO Activity+readGPXFile fp = (r . fst . parse defaultParseOptions) <$> B.readFile fp+  where+    -- l m = error . show $ m+    r = fromJust . parseGPX++class ReadGPX t where+  parseGPX :: Node String String -> Maybe t++instance ReadGPX Activity where+  parseGPX x = case selectPath ["gpx"] x of+    [x@(Element _ _ chs)] -> Just . Activity . mapMaybe parseGPX . chsWith "trk" $ x+++    --                      concatMap (selectPath [""Track"]) $ chs+    -- _                 -> Nothing++++instance ReadGPX Track where+  parseGPX x@(Element "trk" _ _) = Just . Track . mapMaybe parseGPX . concatMap (chsWith "trkpt") . chsWith "trkseg" $ x+++++instance ReadGPX TrackPoint where+  parseGPX x@(Element "trkpt" ats _) = (\p t -> TP $ p :+ t) <$> pos <*> time+    where+      pos  = (\l l' -> Position $ point2 l l') <$> lat <*> lon+      time = fmap (readTime' . extract) . listToMaybe . chsWith "time" $ x++      lat = read <$> lookup "lat" ats+      lon = read <$> lookup "lon" ats+++extract = (\(Text s) -> s) . head . eChildren++readTime' :: String -> UTCTime+readTime' = readTime defaultTimeLocale "%0C%y-%m-%dT%TZ"++-- instance ReadGPX Position where+--   parseGPX x@(Element "Position" _ _) = (\l l' -> Position $ point2 l l') <$> lat <*> lon++--     where+--       f n = listToMaybe . map (read . extract) . (chsWith n) $ x+--       lat = f "LatitudeDegrees"+--       lon = f "LongitudeDegrees"++selectPath :: [String] -> Node String String -> [Node String String]+selectPath []  _ = []+selectPath [n] x | hasName n x = [x]+                 | otherwise   = []+selectPath (n:p) x | hasName n x = concatMap (selectPath p) $ eChildren x+                   | otherwise   = []++chsWith   :: String -> Node String String -> [Node String String]+chsWith n = filter (hasName n) . eChildren++hasName   :: String -> Node String String -> Bool+hasName _ (Text _) = False+hasName n (Element n' _ _) = n == n'
+ examples/Demo/MinDisk.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Demo.MinDisk where++import           Algorithms.Geometry.SmallestEnclosingBall.RandomizedIncrementalConstruction+import           Algorithms.Geometry.SmallestEnclosingBall.Types++import           Control.Applicative+import           Control.Lens+import           Data.Data+import           Data.Ext+import qualified Data.Foldable as F+import qualified Data.Traversable as Tr+import           Data.Geometry+import           Data.Geometry.Ball+import           Data.Geometry.Line+import           Data.Geometry.PolyLine+import           Data.Monoid++--import           Data.Geometry.Ipe++import           Data.Geometry.Ipe+import           Data.Geometry.Ipe.Types+import           Data.Maybe+import           Data.Seq2+import           Data.Vinyl+import           System.Environment(getArgs)+import           System.Random+import           Options.Applicative++--------------------------------------------------------------------------------++newtype Options = Options { inPath  :: FilePath }+                deriving Data++options :: ParserInfo Options+options = info (helper <*> parser)+               (  progDesc "Given an ipe file with a set of points, computes the smallest enclosing disk of the points."+               <> header   "MinDisk - Computes the smallest enclosing disk of a set of points"+               )+  where+    parser = Options+          <$> strOption (help "Input File (in ipe7 xml format)")++--------------------------------------------------------------------------------++diskResult :: Floating r => IpeOut (DiskResult p r) (IpeObject r)+diskResult = IpeOut f+  where+    f (DiskResult d pts) = asIpeGroup (asIpeObject d mempty : (F.toList . fmap g $ pts))+    g p = asIpeObject (p^.core) mempty+++mainWith              :: Options -> IO ()+mainWith (Options fp) = do+    ep <- readSinglePageFile fp+    gen <- getStdGen+    case ep of+      Left err                       -> print err+      Right (ipeP :: IpePage Double) ->+        case map ext $ ipeP^..content.Tr.traverse._IpeUse.core.symbolPoint of+          pts@(_:_:_) -> do+                           let res = smallestEnclosingDisk gen pts+                           printAsIpeSelection . asIpe diskResult $ res+          _           -> putStrLn "Not enough points!"+++      -- polies = ipeP^..content.Tr.traverse._IpePath.core._asPolyLine++      -- print pls+      -- mapM_ (print . (^.enclosingDisk) . minDisk' gen) polies+      -- mapM_ (printAsIpeSelection . asIpe diskResult . minDisk' gen) polies+++minDisk' :: RandomGen g => g -> PolyLine 2 () Double -> DiskResult () Double+minDisk' = minDisk++minDisk    :: (Ord r, Fractional r, RandomGen g) => g -> PolyLine 2 () r -> DiskResult () r+minDisk gen pl = smallestEnclosingDisk gen (F.toList $ pl^.points)
+ examples/Demo/WriteEnsemble.hs view
@@ -0,0 +1,96 @@+module Demo.WriteEnsemble where++import Control.Lens+import Data.Data+import Data.Ext+import Control.Applicative+import Data.Fixed+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Geometry.Ipe+import Data.Geometry+import Data.Geometry.PolyLine(fromPoints)+import System.Environment+import System.Directory+import Data.List(isSuffixOf)+import Data.Monoid+import Data.Time.Calendar+import Options.Applicative+++--------------------------------------------------------------------------------++data Options = Options { kind    :: String+                       , inPath  :: FilePath+                       , outPath :: FilePath+                       }+               deriving Data+++options :: ParserInfo Options+options = info (helper <*> parser)+               (  progDesc "Converts ensembles to ipe files"+               <> header   "ensemblewriter - writes a weather ensembles to a ipe files"+               )+  where+    parser = Options+          <$> strOption (help "Kind of input data in the input files" )+          <*> strOption (help "Input Directory")+          <*> strOption (help "Output Directory")++--------------------------------------------------------------------------------++-- read a bunch of text files, each defining a time-series (ensemble), produce+-- an ipe file where each time-series is represented by a polyline.++main :: IO ()+main = execParser options >>= mainWith++mainWith                               :: Options -> IO ()+mainWith (Options kind inPath outPath) = do+    inFiles <- filter (".dat" `isSuffixOf`) <$> getDirectoryContents inPath+    let f = case kind of+          "precip" -> asPrecipPt+          _        -> asTempPt+    polies <- mapM (fmap (asPts f) . readFile' . ((inPath ++ "/") ++)) inFiles+    let polies' = map (fromPoints . take 100) . trim $ polies+    writeIpeFile outPath . singlePageFromContent . map (flip asIpeObject mempty) $ polies'++readFile'    :: String -> IO T.Text+readFile' fp = putStrLn fp >> TIO.readFile fp++maxStartDay :: [[core :+ Day]] -> Day+maxStartDay = maximum . map ((^.extra) . head)++-- | Find the last starting day in the file, and trim all the lists s.t. they+-- all start at or after this day.+trim    :: [[Point 2 Milli :+ Day]] -> [[Point 2 Milli :+ Day]]+trim xs = let m      = maxStartDay xs+              startD = fromIntegral $ toModifiedJulianDay m+          in map ( map (\p -> p&core.xCoord %~ subtract startD)+                 . dropWhile (\x -> x^.extra < m)+                 ) xs+++-- force'   :: Show r => IO (PolyLine 2 () r) -> IO (PolyLine 2 () r)+-- force' mkP = mkP >>= \p -> (putStrLn $ show p) >> return p++read' :: Read a => T.Text -> a+read' = read . T.unpack++asPts   :: ([T.Text] -> b) -> T.Text -> [b]+asPts f = map (f . T.words) . filter (\l -> T.head l /= '#') . T.lines++-- | read a line of the form: yyyy mm dd value+asTempPt    :: [T.Text] -> Point 2 Milli :+ Day+asTempPt ts = let [y,m,d] = map read' $ Prelude.init ts+                  v       = read' $ last ts+                  day     = fromGregorian y (fromInteger m) (fromInteger d)+              in point2 (fromIntegral $ (toModifiedJulianDay day)) (10 * v) :+ day++-- | read a line of the form: yyyymmdd value+asPrecipPt       :: [T.Text] -> Point 2 Milli :+ Day+asPrecipPt [t,v] = let (y,t') = T.splitAt 4 t+                       (m,d)  = T.splitAt 2 t'+                       day    = fromGregorian (read' y) (read' m) (read' d)+                   in point2 (fromIntegral $ (toModifiedJulianDay day)) (10 * read' v) :+ day
+ examples/Main.hs view
@@ -0,0 +1,74 @@+module Main where++import Data.Monoid+import Control.Applicative+import Options.Applicative+import Data.Data++--------------------------------------------------------------------------------++import qualified Demo.DrawGPX as DrawGPX+import qualified Demo.WriteEnsemble as EnsembleWriter+import qualified Demo.MinDisk as MinDisk+import qualified Demo.Delaunay as Delaunay+++++--------------------------------------------------------------------------------++data Options = BAPC           BAPCOptions+             | DrawGPX        DrawGPX.Options+             | EnsembleWriter EnsembleWriter.Options+             | MinDisk        MinDisk.Options+             | Delaunay       Delaunay.Options+             deriving Data++parser :: Parser Options+parser = subparser (+       command' DrawGPX        DrawGPX.options+    <> command' EnsembleWriter EnsembleWriter.options+    <> command' MinDisk        MinDisk.options+    <> command' Delaunay       Delaunay.options+    )+++mainWith       :: Options -> IO ()+mainWith opts' = case opts' of+  BAPC _              -> putStrLn "not yet"+  DrawGPX opts        -> DrawGPX.mainWith opts+  EnsembleWriter opts -> EnsembleWriter.mainWith opts+  MinDisk opts        -> MinDisk.mainWith opts+  Delaunay opts       -> Delaunay.mainWith opts+++--------------------------------------------------------------------------------++options :: ParserInfo Options+options = info (helper <*> parser)+               (  progDesc "Example programs for HGeometry. Use -h to get a list of programs."+               <> header   "hgeometry-examples - Examples for HGeometry"+               )++--------------------------------------------------------------------------------++main :: IO ()+main = execParser options >>= mainWith+++command'          :: Data o => (a -> o) -> ParserInfo a -> Mod CommandFields o+command' constr p = command (show . toConstr $ constr undefined) (constr <$> p)+++noOpts :: InfoMod () -> ParserInfo ()+noOpts = info (pure ())++++++++data BAPCOptions = BAPCOptions { year :: Int+                               }+                   deriving Data
hgeometry.cabal view
@@ -2,30 +2,46 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                hgeometry-version:             0.4.0.0-synopsis:            Data types for geometric objects, geometric algorithms, and data  structures.+version:             0.5.0.0+synopsis:            Geometric Algorithms, Data structures, and Data types. description:   HGeometry provides some basic geometry types, and geometric algorithms and   data structures for them. The main two focusses are: (1) Strong type safety,   and (2) implementations of geometric algorithms and data structures with good   asymptotic running time guarantees. -homepage:            http://fstaals.net/software/hgeometry+homepage:            https://fstaals.net/software/hgeometry license:             BSD3 license-file:        LICENSE author:              Frank Staals-maintainer:          f.staals@uu.nl+maintainer:          frank@fstaals.net -- copyright: +tested-with:         GHC >= 7.8.4+ category:            Geometry build-type:          Simple+ extra-source-files:  README.md+                     resources/basic.isy+                     test/Data/Geometry/pointInPolygon.ipe+                     test/Data/Geometry/Polygon/Convex/convexTests.ipe+                     test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe+ cabal-version:       >=1.10 source-repository head   type:     git-  location: http://github.com/noinia/hgeometry+  location: https://github.com/noinia/hgeometry ++flag examples+  description: Build demonstration programs+  default:     False+  manual:      True+ library+  ghc-options: -Wall -fno-warn-unticked-promoted-constructors+   exposed-modules:  Data.Geometry                     Data.Geometry.Properties                     Data.Geometry.Vector@@ -33,11 +49,13 @@                     Data.Geometry.Transformation                     Data.Geometry.Vector.VectorFixed                     Data.Geometry.Interval+                    Data.Geometry.Boundary                      Data.Geometry.Point                     Data.Geometry.Line                     Data.Geometry.Line.Internal                     Data.Geometry.LineSegment+                    Data.Geometry.SubLine                     Data.Geometry.HalfLine                     Data.Geometry.PolyLine @@ -45,42 +63,70 @@                       -- Data.Geometry.Plane-+                    Data.Geometry.Slab                     Data.Geometry.Box+                    Data.Geometry.Box.Internal                     Data.Geometry.Ball                     Data.Geometry.Polygon+                    Data.Geometry.Polygon.Convex +                    Data.Geometry.Duality +                    Algorithms.Util+                     Algorithms.Geometry.ConvexHull.GrahamScan+                    Algorithms.Geometry.ConvexHull.Types+                    Algorithms.Geometry.ConvexHull.DivideAndConqueror++                    Algorithms.Geometry.SmallestEnclosingBall.Types                     Algorithms.Geometry.SmallestEnclosingBall.RandomizedIncrementalConstruction+                    Algorithms.Geometry.SmallestEnclosingBall.Naive -                    -- Data.TypeLevel.Common-                    -- Data.TypeLevel.Filter+                    Algorithms.Geometry.DelaunayTriangulation.Types+                    Algorithms.Geometry.DelaunayTriangulation.DivideAndConqueror+                    Algorithms.Geometry.DelaunayTriangulation.Naive -                    -- Data.Type.Nat-                    -- Data.Type.List+                    Algorithms.Geometry.PolyLineSimplification.DouglasPeucker -                    -- Data.Vinyl.Universe.Geometry-                    -- Data.Vinyl.Show-                    -- Data.Vinyl.Extra+                    Algorithms.Geometry.EuclideanMST.EuclideanMST ---                    Data.Geometry.Vector -                   Data.Geometry.Ipe-                   Data.Geometry.Ipe.Attributes-                   Data.Geometry.Ipe.Types-                   Data.Geometry.Ipe.Writer-                   Data.Geometry.Ipe.Reader-                   Data.Geometry.Ipe.PathParser+                    Algorithms.Graph.DFS+                    Algorithms.Graph.MST  -                   Data.Ext+                    Data.UnBounded+                    Data.Range -                   Data.Seq2-                   System.Random.Shuffle-                   Control.Monad.State.Persistent +                    Data.Geometry.Ipe+                    Data.Geometry.Ipe.Literal+                    Data.Geometry.Ipe.Attributes+                    Data.Geometry.Ipe.Types+                    Data.Geometry.Ipe.Writer+                    Data.Geometry.Ipe.Reader+                    Data.Geometry.Ipe.PathParser+                    Data.Geometry.Ipe.IpeOut+                    Data.Geometry.Ipe.FromIpe +++                    Data.Ext+                    Data.Seq2+                    Data.CircularSeq+                    Data.Sequence.Util+                    Data.BinaryTree+                    Data.CircularList.Util++                    Data.Permutation+                    Data.PlanarGraph+                    Data.PlaneGraph+++                    System.Random.Shuffle+                    Control.Monad.State.Persistent++   other-modules:                    Data.Geometry.Ipe.ParserPrimitives @@ -93,31 +139,38 @@                , vinyl            >= 0.5       &&     < 0.6                , linear           >= 1.10                , lens             >= 4.2-               , singletons       >= 1.0       &&     < 1.1-               , bifunctors       >= 4.0+               , singletons       >= 1.0       &&     < 2.0+               , bifunctors       >= 5+               , semigroupoids    >= 5+               , Frames           >= 0.1.0.0 -               , text             >= 0.11+               , text             >= 1.1.1.0                , bytestring       >= 0.10                 , semigroups       >= 0.15                , bifunctors       >= 4.1-               , validation       >= 0.4+               -- , validation       >= 0.4 -               , containers       >= 0.5                , parsec           >= 3-               -- , tranformers      >= 0.3+               -- , tranformers      > 0.3                 , vector           >= 0.10-               , fixed-vector     >= 0.6.4.0   &&     < 0.7+               , fixed-vector     >= 0.6.4.0                , data-clist       >= 0.0.7.2-               -- , HList            >= 0.3       &&     < 0.4 -               , hexpat           >= 0.20.7+               , hexpat           >= 0.20.9                , mtl                , random+               , template-haskell  +               , time+               , directory+               , optparse-applicative++   hs-source-dirs: src+                  -- examples/demo    default-language:    Haskell2010 @@ -131,17 +184,82 @@                     , RankNTypes                      , PatternSynonyms+                    , TupleSections+                    , LambdaCase                     , ViewPatterns                      , StandaloneDeriving                     , GeneralizedNewtypeDeriving+                    , DeriveFunctor+                    , DeriveFoldable+                    , DeriveTraversable++                    , AutoDeriveTypeable+                     , FlexibleInstances                     , FlexibleContexts+                    , MultiParamTypeClasses +executable hgeometry-examples+  if !flag(examples)+    buildable: False+  main-is: Main.hs +  if flag(examples)+    build-depends: base+                 , hgeometry+                 , lens+                 , containers+                 , vinyl+                 , Frames+                 , semigroups+                 , optparse-applicative+                 , text+                 , hexpat+                 , bytestring+                 , directory+                 , time+                 , random  +  hs-source-dirs: examples +  other-modules: Demo.DrawGPX+                 Demo.WriteEnsemble+                 Demo.MinDisk+                 Demo.Delaunay++                 Demo.GPXParser++  default-language: Haskell2010++  default-extensions: TypeFamilies+                    , GADTs+                    , KindSignatures+                    , DataKinds+                    , TypeOperators+                    , ConstraintKinds+                    , PolyKinds+                    , RankNTypes++                    , PatternSynonyms+                    , ViewPatterns++                    , StandaloneDeriving+                    , GeneralizedNewtypeDeriving+                    , DeriveFunctor+                    , DeriveFoldable+                    , DeriveTraversable++                    , DeriveDataTypeable+                    , AutoDeriveTypeable++                    , FlexibleInstances+                    , FlexibleContexts+                    , MultiParamTypeClasses+++ test-suite doctests   type:          exitcode-stdio-1.0   ghc-options:   -threaded@@ -150,9 +268,65 @@    default-language:    Haskell2010 -  -- Extensions are enabled in doctests.hs-  --  default-extensions:+test-suite hspec+  type:                 exitcode-stdio-1.0+  default-language:     Haskell2010+  hs-source-dirs:       test+  main-is:              Spec.hs +  other-modules: Data.RangeSpec+                 Data.Geometry.Ipe.ReaderSpec+                 Data.Geometry.PolygonSpec+                 Data.Geometry.PointSpec+                 Data.Geometry.Polygon.Convex.ConvexSpec++                 Algorithms.Geometry.SmallestEnclosingDisk.RISpec+                 Algorithms.Geometry.DelaunayTriangulation.DTSpec++                 Util+++  build-depends:        base+                      , hspec >= 2.1+                      , hgeometry+                      , Frames+                      , lens+                      , data-clist+                      , linear+                      , bytestring+                      , vinyl+                      , semigroups+                      , vector+                      , containers+                      , random++  default-extensions: TypeFamilies+                    , GADTs+                    , KindSignatures+                    , DataKinds+                    , TypeOperators+                    , ConstraintKinds+                    , PolyKinds+                    , RankNTypes++                    , PatternSynonyms+                    , ViewPatterns+                    , LambdaCase+++                    , StandaloneDeriving+                    , GeneralizedNewtypeDeriving+                    , DeriveFunctor+                    , DeriveFoldable+                    , DeriveTraversable++                    , AutoDeriveTypeable++                    , FlexibleInstances+                    , FlexibleContexts+                    , MultiParamTypeClasses+                    , OverloadedStrings+ test-suite bapc_examples   type:          exitcode-stdio-1.0   ghc-options:   -O2@@ -165,7 +339,10 @@                , lens                , data-clist                , linear+               , semigroups +  other-modules: BAPC2012.Gunslinger+                 BAPC2014.Armybase    default-language:    Haskell2010
+ resources/basic.isy view
@@ -0,0 +1,141 @@+<?xml version="1.0"?>+<!DOCTYPE ipestyle SYSTEM "ipe.dtd">+<ipestyle name="basic">+<color name="red" value="1 0 0"/>+<color name="green" value="0 1 0"/>+<color name="blue" value="0 0 1"/>+<color name="yellow" value="1 1 0"/>+<color name="orange" value="1 0.647 0"/>+<color name="gold" value="1 0.843 0"/>+<color name="purple" value="0.627 0.125 0.941"/>+<color name="gray" value="0.745 0.745 0.745"/>+<color name="brown" value="0.647 0.165 0.165"/>+<color name="navy" value="0 0 0.502"/>+<color name="pink" value="1 0.753 0.796"/>+<color name="seagreen" value="0.18 0.545 0.341"/>+<color name="turquoise" value="0.251 0.878 0.816"/>+<color name="violet" value="0.933 0.51 0.933"/>+<color name="darkblue" value="0 0 0.545"/>+<color name="darkcyan" value="0 0.545 0.545"/>+<color name="darkgray" value="0.663 0.663 0.663"/>+<color name="darkgreen" value="0 0.392 0"/>+<color name="darkmagenta" value="0.545 0 0.545"/>+<color name="darkorange" value="1 0.549 0"/>+<color name="darkred" value="0.545 0 0"/>+<color name="lightblue" value="0.678 0.847 0.902"/>+<color name="lightcyan" value="0.878 1 1"/>+<color name="lightgray" value="0.827 0.827 0.827"/>+<color name="lightgreen" value="0.565 0.933 0.565"/>+<color name="lightyellow" value="1 1 0.878"/>+<dashstyle name="dashed" value="[4] 0"/>+<dashstyle name="dotted" value="[1 3] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<pen name="heavier" value="0.8"/>+<pen name="fat" value="1.2"/>+<pen name="ultrafat" value="2"/>+<textsize name="large" value="\large"/>+<textsize name="Large" value="\Large"/>+<textsize name="LARGE" value="\LARGE"/>+<textsize name="huge" value="\huge"/>+<textsize name="Huge" value="\Huge"/>+<textsize name="small" value="\small"/>+<textsize name="footnote" value="\footnotesize"/>+<textsize name="tiny" value="\tiny"/>+<symbolsize name="small" value="2"/>+<symbolsize name="tiny" value="1.1"/>+<symbolsize name="large" value="5"/>+<arrowsize name="small" value="5"/>+<arrowsize name="tiny" value="3"/>+<arrowsize name="large" value="10"/>+<gridsize name="4 pts" value="4"/>+<gridsize name="8 pts (~3 mm)" value="8"/>+<gridsize name="16 pts (~6 mm)" value="16"/>+<gridsize name="32 pts (~12 mm)" value="32"/>+<gridsize name="10 pts (~3.5 mm)" value="10"/>+<gridsize name="20 pts (~7 mm)" value="20"/>+<gridsize name="14 pts (~5 mm)" value="14"/>+<gridsize name="28 pts (~10 mm)" value="28"/>+<gridsize name="56 pts (~20 mm)" value="56"/>+<anglesize name="90 deg" value="90"/>+<anglesize name="60 deg" value="60"/>+<anglesize name="45 deg" value="45"/>+<anglesize name="30 deg" value="30"/>+<anglesize name="22.5 deg" value="22.5"/>+<symbol name="mark/circle(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e+</path></symbol>+<symbol name="mark/disk(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+</path></symbol>+<symbol name="mark/fdisk(sfx)" transformations="translations">+<group><path fill="sym-fill">+0.5 0 0 0.5 0 0 e+</path><path fill="sym-stroke" fillrule="eofill">+0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e+</path></group></symbol>+<symbol name="mark/box(sx)" transformations="translations">+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h+-0.4 -0.4 m 0.4 -0.4 l 0.4 0.4 l -0.4 0.4 l h</path></symbol>+<symbol name="mark/square(sx)" transformations="translations">+<path fill="sym-stroke">+-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h</path></symbol>+<symbol name="mark/fsquare(sfx)" transformations="translations">+<group><path fill="sym-fill">+-0.5 -0.5 m 0.5 -0.5 l 0.5 0.5 l -0.5 0.5 l h</path>+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h+-0.4 -0.4 m 0.4 -0.4 l 0.4 0.4 l -0.4 0.4 l h</path></group></symbol>+<symbol name="mark/cross(sx)" transformations="translations">+<group><path fill="sym-stroke">+-0.43 -0.57 m 0.57 0.43 l 0.43 0.57 l -0.57 -0.43 l h</path>+<path fill="sym-stroke">+-0.43 0.57 m 0.57 -0.43 l 0.43 -0.57 l -0.57 0.43 l h</path>+</group></symbol>+<symbol name="arrow/arc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/farc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/ptarc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/fptarc(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/fnormal(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/pointed(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/fpointed(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>+<symbol name="arrow/linear(spx)">+<path pen="sym-pen" stroke="sym-stroke">+-1.0 0.333 m 0 0 l -1.0 -0.333 l</path></symbol>+<symbol name="arrow/fdouble(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="white">+0 0 m -1.0 0.333 l -1.0 -0.333 l h+-1 0 m -2.0 0.333 l -2.0 -0.333 l h+</path></symbol>+<symbol name="arrow/double(spx)">+<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">+0 0 m -1.0 0.333 l -1.0 -0.333 l h+-1 0 m -2.0 0.333 l -2.0 -0.333 l h+</path></symbol>+<tiling name="falling" angle="-60" width="1" step="4"/>+<tiling name="rising" angle="30" width="1" step="4"/>+<textstyle name="center" begin="\begin{center}"+end="\end{center}"/>+<textstyle name="itemize" begin="\begin{itemize}"+end="\end{itemize}"/>+<textstyle name="item" begin="\begin{itemize}\item{}"+end="\end{itemize}"/>+</ipestyle>+
+ src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs view
@@ -0,0 +1,30 @@+module Algorithms.Geometry.ConvexHull.DivideAndConqueror( convexHull+                                                        , module Types+                                                        ) where++import           Data.Semigroup.Foldable+import           Data.Semigroup+import           Algorithms.Geometry.ConvexHull.Types as Types+import           Control.Lens((^.))+import           Data.BinaryTree+import           Data.Ext+import           Data.Function(on)+import           Data.Geometry.Point+import           Data.Geometry.Polygon+import qualified Data.Geometry.Polygon.Convex as Convex+import qualified Data.List.NonEmpty as NonEmpty++-- | O(n log n) time ConvexHull using divide and conqueror.+convexHull :: (Ord r, Num r)+           => NonEmpty.NonEmpty (Point 2 r :+ p) -> ConvexHull p r+convexHull = unMerge+           . foldMap1 (Merge . ConvexHull . fromPoints . (:[]) . _unElem)+           . asBalancedBinLeafTree+           . NonEmpty.sortBy (compare `on` (^.core))++newtype Merge r p = Merge { unMerge :: ConvexHull p r }++instance (Num r, Ord r) => Semigroup (Merge r p) where+  (Merge lp) <> (Merge rp) = Merge . ConvexHull $ ch+    where+      (ch,_,_) = Convex.merge (lp^.extractHull) (rp^.extractHull)
src/Algorithms/Geometry/ConvexHull/GrahamScan.hs view
@@ -1,65 +1,54 @@-module Algorithms.Geometry.ConvexHull.GrahamScan( ConvexHull(..)-                                                , DegenerateCH-                                                , convexHull+module Algorithms.Geometry.ConvexHull.GrahamScan( convexHull                                                 , upperHull                                                 , lowerHull+                                                , module Types                                                 ) where +import           Algorithms.Geometry.ConvexHull.Types as Types import           Control.Lens((^.)) import           Data.Ext import           Data.Geometry.Point import           Data.Geometry.Polygon-import qualified Data.List as L+import qualified Data.List.NonEmpty as NonEmpty import           Data.Monoid----- | Two dimensional convex hulls-newtype ConvexHull p r = ConvexHull { _hull :: (SimplePolygon p r) }---                       deriving (Show,Eq)--type DegenerateCH p r = Maybe (Point 2 r :+ p)+import           Data.List.NonEmpty(NonEmpty(..))  --- | O(n log n) time ConvexHull using Graham-Scan-convexHull     :: (Ord r, Num r)-               => [Point 2 r :+ p] -> Either (DegenerateCH p r) (ConvexHull p r)-convexHull []  = Left Nothing-convexHull [p] = Left (Just p)-convexHull ps  = let ps' = L.sortBy incXdecY ps-                     uh  = tail . hull' $         ps'-                     lh  = tail . hull' $ reverse ps'-                 in Right . ConvexHull . fromPoints $ lh ++ uh+-- | O(n log n) time ConvexHull using Graham-Scan. The resulting polygon is+-- given in clockwise order.+convexHull            :: (Ord r, Num r)+                      => NonEmpty (Point 2 r :+ p) -> ConvexHull p r+convexHull (p :| []) = ConvexHull . fromPoints $ [p]+convexHull ps        = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps+                           uh  = NonEmpty.tail . hull' $         ps'+                           lh  = NonEmpty.tail . hull' $ reverse ps'+                       in ConvexHull . fromPoints . reverse $ lh ++ uh -upperHull  :: (Ord r, Num r)-           => [Point 2 r :+ p] -> Either (DegenerateCH p r) [Point 2 r :+ p]+upperHull  :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) upperHull = hull id  -lowerHull  :: (Ord r, Num r)-           => [Point 2 r :+ p] -> Either (DegenerateCH p r) [Point 2 r :+ p]+lowerHull :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) lowerHull = hull reverse   -- | Helper function so that that can compute both the upper or the lower hull, depending -- on the function f-hull       :: (Ord r, Num r)-           => ([Point 2 r :+ p] -> [Point 2 r :+ p])-           -> [Point 2 r :+ p]-           -> Either (DegenerateCH p r) [Point 2 r :+ p]-hull _ []  = Left Nothing-hull _ [p] = Left (Just p)-hull f ps  = Right . hull' . f . L.sortBy incXdecY $ ps--+hull               :: (Ord r, Num r)+                   => ([Point 2 r :+ p] -> [Point 2 r :+ p])+                   -> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)+hull f h@(_ :| []) = h+hull f pts         = hull' .  f+                   . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts -incXdecY  :: Ord a => Ext t (Point 2 a) -> Ext t1 (Point 2 a) -> Ordering+incXdecY  :: Ord r => (Point 2 r) :+ p -> (Point 2 r) :+ q -> Ordering incXdecY (Point2 px py :+ _) (Point2 qx qy :+ _) =   compare px qx <> compare qy py   -- | Precondition: The list of input points is sorted-hull'          :: (Ord r, Num r) => [Point 2 r :+ p] -> [Point 2 r :+ p]-hull' (a:b:ps) = hull'' [b,a] ps+hull'          :: (Ord r, Num r) => [Point 2 r :+ p] -> NonEmpty (Point 2 r :+ p)+hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps   where     hull'' h  []    = h     hull'' h (p:ps) = hull'' (cleanMiddle (p:h)) ps
+ src/Algorithms/Geometry/ConvexHull/Types.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TemplateHaskell #-}+module Algorithms.Geometry.ConvexHull.Types where++import           Control.Lens+import           Data.Ext+import           Data.Geometry.Point+import           Data.Geometry.Polygon++++-- | Two dimensional convex hulls+newtype ConvexHull p r = ConvexHull { _extractHull :: (SimplePolygon p r) }+                       deriving (Show,Eq)+makeLenses ''ConvexHull
+ src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConqueror.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Algorithms.Geometry.DelaunayTriangulation.DivideAndConqueror where++import           Algorithms.Geometry.ConvexHull.GrahamScan as GS+import           Algorithms.Geometry.DelaunayTriangulation.Types+import           Control.Applicative+import           Control.Lens+import           Control.Monad.Reader+import           Control.Monad.State+import           Data.BinaryTree+import qualified Data.CircularList as CL+import qualified Data.CircularSeq as CS+import qualified Data.CircularList.Util as CU+import           Data.Ext+import qualified Data.Foldable as F+import           Data.Function (on)+import           Data.Geometry+import           Data.Geometry.Ball (disk, insideBall)+import           Data.Geometry.Interval+import           Data.Geometry.Polygon+import qualified Data.Geometry.Polygon.Convex as Convex+import           Data.Geometry.Polygon.Convex (ConvexPolygon)+import qualified Data.IntMap.Strict as IM+import qualified Data.List as L+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as M+import           Data.Maybe (fromJust, fromMaybe)+import qualified Data.Vector as V++-------------------------------------------------------------------------------+-- * Divide & Conqueror Delaunay Triangulation+--+-- Implementation of the Divide & Conqueror algorithm as described in:+--+-- Two Algorithms for Constructing a Delaunay Triangulation+-- Lee and Schachter+-- International Journal of Computer and Information Sciences, Vol 9, No. 3, 1980+--+-- We store all adjacency lists in clockwise order+--+-- : If v on the convex hull, then its first entry in the adj. lists is its CCW+-- successor (i.e. its predecessor) on the convex hull+--+-- Rotating Right <-> rotate clockwise+++-- | Computes the delaunay triangulation of a set of points.+--+-- Running time: $O(n \log n)$+-- (note: We use an IntMap in the implementation. So maybe actually $O(n \log^2 n)$)+--+-- pre: the input is a *SET*, i.e. contains no duplicate points. (If the+-- input does contain duplicate points, the implementation throws them away)+delaunayTriangulation      :: (Ord r, Fractional r)+                           => NonEmpty.NonEmpty (Point 2 r :+ p) -> Triangulation p r+delaunayTriangulation pts' = Triangulation vtxMap ptsV adjV+  where+    pts    = nub' . NonEmpty.sortBy (compare `on` (^.core)) $ pts'+    ptsV   = V.fromList . F.toList $ pts+    vtxMap = M.fromList $ zip (map (^.core) . V.toList $ ptsV) [0..]++    tr     = _unElem <$> asBalancedBinLeafTree pts++    (adj,_) = delaunayTriangulation' tr (vtxMap,ptsV)+    adjV    = V.fromList . IM.elems $ adj++++-- : pre: - Input points are sorted lexicographically+delaunayTriangulation' :: (Ord r, Fractional r)+                       => BinLeafTree Size (Point 2 r :+ p)+                       -> Mapping p r+                       -> (Adj, ConvexPolygon (p :+ VertexID) r)+delaunayTriangulation' pts mapping'@(vtxMap,_)+  | size' pts == 1 = let (Leaf p) = pts+                         i        = lookup' vtxMap (p^.core)+                     in (IM.singleton i CL.empty, fromPoints [withID p i])+  | size' pts <= 3 = let pts'            = NonEmpty.fromList+                                         . map (\p -> withID p (lookup' vtxMap (p^.core)))+                                         . F.toList $ pts+                         (ConvexHull ch) = GS.convexHull pts'+                     in (fromHull mapping' ch, ch)+  | otherwise      = let (Node lt _ rt) = pts+                         (ld,lch)       = delaunayTriangulation' lt mapping'+                         (rd,rch)       = delaunayTriangulation' rt mapping'+                         (ch, bt, ut)   = Convex.merge lch rch+                     in (merge ld rd bt ut mapping' (firsts ch), ch)++--------------------------------------------------------------------------------+-- * Implementation++-- | Mapping that says for each vtx in the convex hull what the first entry in+-- the adj. list should be. The input polygon is given in Clockwise order+firsts :: SimplePolygon (p :+ VertexID) r -> IM.IntMap VertexID+firsts = IM.fromList . map (\s -> (s^.end.extra.extra, s^.start.extra.extra))+       . F.toList . outerBoundaryEdges+++-- | Given a polygon; construct the adjacency list representation+-- pre: at least two elements+fromHull              :: Ord r => Mapping p r -> SimplePolygon (p :+ q) r -> Adj+fromHull (vtxMap,_) p = let vs@(u:v:vs') = map (lookup' vtxMap . (^.core))+                                         . F.toList . CS.rightElements $ p^.outerBoundary+                            es           = zipWith3 f vs (tail vs ++ [u]) (vs' ++ [u,v])+                            f prv c nxt  = (c,CL.fromList . L.nub $ [prv, nxt])+                        in IM.fromList es+++-- | Merge the two delaunay triangulations.+--+-- running time: $O(n)$ (although we cheat a bit by using a IntMap)+merge                            :: (Ord r, Fractional r)+                                 => Adj+                                 -> Adj+                                 -> LineSegment 2 (p :+ VertexID) r -- ^ lower tangent+                                 -> LineSegment 2 (p :+ VertexID) r -- ^ upper tangent+                                 -> Mapping p r+                                 -> Firsts+                                 -> Adj+merge ld rd bt ut mapping'@(vtxMap,_) fsts =+    flip runReader (mapping', fsts) . flip execStateT adj $ moveUp (tl,tr) l r+  where+    l   = lookup' vtxMap (bt^.start.core)+    r   = lookup' vtxMap (bt^.end.core)+    tl  = lookup' vtxMap (ut^.start.core)+    tr  = lookup' vtxMap (ut^.end.core)+    adj = ld `IM.union` rd++type Merge p r = StateT Adj (Reader (Mapping p r, Firsts))++type Firsts = IM.IntMap VertexID++-- | Merges the two delaunay traingulations.+moveUp          :: (Ord r, Fractional r)+                => (VertexID,VertexID) -> VertexID -> VertexID -> Merge p r ()+moveUp ut l r+  | (l,r) == ut = insert l r+  | otherwise   = do+                     insert l r+                     -- Get the neighbours of r and l along the convex hull+                     r1 <- pred' . rotateTo l . lookup'' r <$> get+                     l1 <- succ' . rotateTo r . lookup'' l <$> get++                     (r1',a) <- rotateR l r r1+                     (l1',b) <- rotateL l r l1+                     c       <- qTest l r r1' l1'+                     let (l',r') = case (a,b,c) of+                                     (True,_,_)          -> (focus' l1', r)+                                     (False,True,_)      -> (l,          focus' r1')+                                     (False,False,True)  -> (l,          focus' r1')+                                     (False,False,False) -> (focus' l1', r)+                     moveUp ut l' r'+++-- | ''rotates'' around r and removes all neighbours of r that violate the+-- delaunay condition. Returns the first vertex (as a Neighbour of r) that+-- should remain in the Delaunay Triangulation, as well as a boolean A that+-- helps deciding if we merge up by rotating left or rotating right (See+-- description in the paper for more info)+rotateR        :: (Ord r, Fractional r)+               => VertexID -> VertexID -> Vertex -> Merge p r (Vertex, Bool)+rotateR l r r1 = focus' r1 `isLeftOf` (l, r) >>= \case+                   True  -> (,False) <$> rotateR' l r r1 (pred' r1)+                   False -> pure (r1,True)++-- | The code that does the actual rotating+rotateR'     :: (Ord r, Fractional r)+             => VertexID -> VertexID -> Vertex -> Vertex -> Merge p r Vertex+rotateR' l r = go+  where+    go r1 r2 = qTest l r r1 r2 >>= \case+                 True  -> pure r1+                 False -> do modify $ delete r (focus' r1)+                             go r2 (pred' r2)+++-- | Symmetric to rotateR+rotateL     :: (Ord r, Fractional r)+                     => VertexID -> VertexID -> Vertex -> Merge p r (Vertex, Bool)+rotateL l r l1 = focus' l1 `isRightOf` (r, l) >>= \case+                   True  -> (,False) <$> rotateL' l r l1 (succ' l1)+                   False -> pure (l1,True)++-- | The code that does the actual rotating. Symmetric to rotateR'+rotateL'     :: (Ord r, Fractional r)+             => VertexID -> VertexID -> Vertex -> Vertex -> Merge p r Vertex+rotateL' l r = go+  where+    go l1 l2 = qTest l r l1 l2 >>= \case+                 True  -> pure l1+                 False -> do modify $ delete l (focus' l1)+                             go l2 (succ' l2)++--------------------------------------------------------------------------------+-- * Primitives used by the Algorithm++-- | returns True if the forth point (vertex) does not lie in the disk defined+-- by the first three points.+qTest         :: (Ord r, Fractional r)+              => VertexID -> VertexID -> Vertex -> Vertex -> Merge p r Bool+qTest h i j k = withPtMap . snd . fst <$> ask+  where+    withPtMap ptMap = let h' = ptMap V.! h+                          i' = ptMap V.! i+                          j' = ptMap V.! (focus' j)+                          k' = ptMap V.! (focus' k)+                      in not . maybe True ((k'^.core) `insideBall`) $ disk' h' i' j'+    disk' p q r = disk (p^.core) (q^.core) (r^.core)++-- | Inserts an edge into the right position.+insert     :: (Num r, Ord r) => VertexID -> VertexID -> Merge p r ()+insert u v = do+               (mapping',fsts) <- ask+               modify $ insert' u v mapping'+               rotateToFirst u fsts+               rotateToFirst v fsts+++-- | make sure that the first vtx in the adj list of v is its predecessor on the CH+rotateToFirst        :: VertexID -> Firsts -> Merge p r ()+rotateToFirst v fsts = modify $ IM.adjust f v+  where+    mfst   = IM.lookup v fsts+    f  cl  = fromMaybe cl $ mfst >>= flip CL.rotateTo cl+++-- | Inserts an edge (and makes sure that the vertex is inserted in the+-- correct. pos in the adjacency lists)+insert'               :: (Num r, Ord r)+                      => VertexID -> VertexID -> Mapping p r -> Adj -> Adj+insert' u v (_,ptMap) = IM.adjustWithKey (insert'' v) u+                      . IM.adjustWithKey (insert'' u) v+  where+    -- inserts b into the adjacency list of a+    insert'' bi ai = CU.insertOrdBy (cwCmpAround (ptMap V.! ai) `on` (ptMap V.!)) bi+++-- | Deletes an edge+delete     :: VertexID -> VertexID -> Adj -> Adj+delete u v = IM.adjust (delete' v) u . IM.adjust (delete' u) v+  where+    delete' x = CL.filterL (/= x) -- should we rotate left or right if it is the focus?+++++-- | Lifted version of Convex.IsLeftOf+isLeftOf           :: (Ord r, Num r)+                   => VertexID -> (VertexID, VertexID) -> Merge p r Bool+p `isLeftOf` (l,r) = withPtMap . snd . fst <$> ask+  where+    withPtMap ptMap = (ptMap V.! p) `Convex.isLeftOf` (ptMap V.! l, ptMap V.! r)++-- | Lifted version of Convex.IsRightOf+isRightOf           :: (Ord r, Num r)+                    => VertexID -> (VertexID, VertexID) -> Merge p r Bool+p `isRightOf` (l,r) = withPtMap . snd . fst <$> ask+  where+    withPtMap ptMap = (ptMap V.! p) `Convex.isRightOf` (ptMap V.! l, ptMap V.! r)++--------------------------------------------------------------------------------+-- * Some Helper functions+++lookup'     :: Ord k => M.Map k a -> k -> a+lookup' m x = fromJust $ M.lookup x m++size'              :: BinLeafTree Size a -> Size+size' (Leaf _)     = 1+size' (Node _ s _) = s++-- | an 'unsafe' version of rotateTo that assumes the element to rotate to+-- occurs in the list.+rotateTo   :: Eq a => a -> CL.CList a -> CL.CList a+rotateTo x = fromJust . CL.rotateTo x++-- | Adjacency lists are stored in clockwise order, so pred means rotate right+pred' :: CL.CList a -> CL.CList a+pred' = CL.rotR++-- | Adjacency lists are stored in clockwise order, so pred and succ rotate left+succ' :: CL.CList a -> CL.CList a+succ' = CL.rotL++focus' :: CL.CList a -> a+focus' = fromJust . CL.focus++-- | Removes duplicates from a sorted list+nub' :: Eq a => NonEmpty.NonEmpty (a :+ b) -> NonEmpty.NonEmpty (a :+ b)+nub' = fmap NonEmpty.head . NonEmpty.groupBy1 ((==) `on` (^.core))+++withID     :: c :+ e -> e' -> c :+ (e :+ e')+withID p i = p&extra %~ (:+i)++lookup'' :: Int -> IM.IntMap a -> a+lookup'' k m = fromJust . IM.lookup k $ m
+ src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs view
@@ -0,0 +1,85 @@+module Algorithms.Geometry.DelaunayTriangulation.Naive where++import Algorithms.Geometry.DelaunayTriangulation.Types++import Control.Applicative+import Control.Monad(forM_)+import Control.Lens+import Data.Function(on)+import qualified Data.Foldable as F+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as M+import qualified Data.CircularList as C+import Data.Ext+import Data.Geometry+import Data.Geometry.Ball(disk, insideBall)+import qualified Data.List as L+++-- | Naive O(n^4) time implementation of the delaunay triangulation. Simply+-- tries each triple (p,q,r) and tests if it is delaunay, i.e. if there are no+-- other points in the circle defined by p, q, and r.+--+-- pre: the input is a *SET*, i.e. contains no duplicate points. (If the+-- input does contain duplicate points, the implementation throws them away)+delaunayTriangulation     :: (Ord r, Fractional r,       Show r, Show p)+                          => NonEmpty.NonEmpty (Point 2 r :+ p) -> Triangulation p r+delaunayTriangulation pts = Triangulation ptIds ptsV adjV+  where+    ptsV   = V.fromList . F.toList . NonEmpty.nubBy ((==) `on` (^.core)) $ pts+    ptIds  = M.fromList $ zip (map (^.core) . V.toList $ ptsV) [0..]+    adjV   = toAdjLists (ptIds,ptsV) . extractEdges $ fs+    n      = V.length ptsV - 1++    -- construct the list of faces/triangles in the delaunay triangulation+    fs = [ (p,q,r)+         | p <- [0..n], q <- [p..n], r <- [q..n], isDelaunay (ptIds,ptsV) p q r+         ]++-- | Given a list of edges, as vertexId pairs, construct a vector with the+-- adjacency lists, each in CW sorted order.+toAdjLists             :: (Num r, Ord r) => Mapping p r -> [(VertexID,VertexID)]+                       -> V.Vector (C.CList VertexID)+toAdjLists m@(_,ptsV) es = V.imap toCList $ V.create $ do+    v <- MV.replicate (V.length ptsV) []+    forM_ es $ \(i,j) -> do+      addAt v i j+      addAt v j i+    pure v+  where+    updateAt v i f = MV.read v i >>= \x -> MV.write v i (f x)+    addAt    v i j = updateAt v i (j:)++    -- convert to a CList, sorted in CCW order around point u+    toCList u = C.fromList . sortAround' m u++-- | Given a particular point u and a list of points vs, sort the points vs in+-- CW order around u.+-- running time: O(m log m), where m=|vs| is the number of vertices to sort.+sortAround'               :: (Num r, Ord r)+                          => Mapping p r -> VertexID -> [VertexID] -> [VertexID]+sortAround' (_,ptsV) u vs = reverse . map (^.extra) $ sortArround (f u) (map f vs)+  where+    f v = (ptsV V.! v)&extra .~ v++-- | Given a list of faces, construct a list of edges+extractEdges :: [(VertexID,VertexID,VertexID)] -> [(VertexID,VertexID)]+extractEdges = map head . L.group . L.sort+               . concatMap (\(p,q,r) -> [(p,q), (q,r), (p,r)])+               -- we encounter every edge twice. To get rid of the duplicates+               -- we sort, group, and take the head of the lists+++-- | Test if the given three points form a triangle in the delaunay triangulation.+-- running time: O(n)+isDelaunay                :: (Fractional r, Ord r)+                          => Mapping p r -> VertexID -> VertexID -> VertexID -> Bool+isDelaunay (_,ptsV) p q r = case disk (pt p) (pt q) (pt r) of+    Nothing -> False -- if the points are colinear, we interpret this as: all+                     -- pts in the plane are in the circle.+    Just d  -> not $ any (`insideBall` d)+      [pt i | i <- [0..(V.length ptsV - 1)], i /= p, i /= q, i /= r]+   where+     pt i = (ptsV V.! i)^.core
+ src/Algorithms/Geometry/DelaunayTriangulation/Types.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Algorithms.Geometry.DelaunayTriangulation.Types where++import           Control.Lens+import qualified Data.CircularList as C+import           Data.Ext+import           Data.Geometry+import           Data.Geometry.Ipe+import qualified Data.IntMap.Strict as IM+import qualified Data.Map as M+import qualified Data.Map.Strict as SM+import           Data.Monoid (mempty)+import qualified Data.Permutation as P+import           Data.PlaneGraph+import qualified Data.Vector as V++import           Debug.Trace++--------------------------------------------------------------------------------++-- We store all adjacency lists in clockwise order++-- : If v on the convex hull, then its first entry in the adj. lists is its CCW+-- successor (i.e. its predecessor) on the convex hull++-- | Rotating Right <-> rotate clockwise++type VertexID = Int++type Vertex    = C.CList VertexID++type Adj = IM.IntMap (C.CList VertexID)++-- | Neighbours are stored in clockwise order: i.e. rotating right moves to the+-- next clockwise neighbour.+data Triangulation p r = Triangulation { _vertexIds  :: M.Map (Point 2 r) VertexID+                                       , _positions  :: V.Vector (Point 2 r :+ p)+                                       , _neighbours :: V.Vector (C.CList VertexID)+                                       }+                         deriving (Show,Eq)+makeLenses ''Triangulation+++type Mapping p r = (M.Map (Point 2 r) VertexID, V.Vector (Point 2 r :+ p))+++++showDT :: (Show p, Show r)  => Triangulation p r -> IO ()+showDT = mapM_ print . triangulationEdges+++triangulationEdges   :: Triangulation p r -> [(Point 2 r :+ p, Point 2 r :+ p)]+triangulationEdges t = let pts = _positions t+                       in map (\(u,v) -> (pts V.! u, pts V.! v)) . tEdges $ t+++tEdges :: Triangulation p r -> [(VertexID,VertexID)]+tEdges = concatMap (\(i,ns) -> map (i,) . filter (> i) . C.toList $ ns)+       . zip [0..] . V.toList . _neighbours++drawTriangulation :: IpeOut (Triangulation p r) (IpeObject r)+drawTriangulation = IpeOut $ \tr ->+    let es = map (uncurry ClosedLineSegment) . triangulationEdges $ tr+    in asIpeGroup $ map (\e -> asIpeObjectWith ipeLineSegment e mempty) es+++--------------------------------------------------------------------------------++data ST a b c = ST { fst' :: !a, snd' :: !b , trd' :: !c}++type ArcID = Int++-- | ST' is a strict triple (m,a,x) containing:+--+-- - m: a Map, mapping edges, represented by a pair of vertexId's (u,v) with+--            u < v, to arcId's.+-- - a: the next available unused arcID+-- - x: the data value we are interested in computing+type ST' a = ST (SM.Map (VertexID,VertexID) ArcID) ArcID a++toPlaneGraph    :: forall proxy s p r.+                   proxy s -> Triangulation p r -> PlaneGraph s Primal_ p () () r+toPlaneGraph _ tr = (planarGraph . P.toCycleRep n $ perm)&vertexData .~ tr^.positions+  where+    neighs    = C.rightElements <$> tr^.neighbours+    n         = sum . fmap length $ neighs++    vtxIDs = [0..]+    perm = trd' . foldr toOrbit (ST mempty 0 mempty) $ zip vtxIDs (V.toList neighs)++    -- | Given a vertex with its adjacent vertices (u,vs) (in CCW order) convert this+    -- vertex with its adjacent vertices into an Orbit+    toOrbit                     :: (VertexID,[VertexID]) -> ST' [[Dart s]]+                                -> ST' [[Dart s]]+    toOrbit (u,vs) (ST m a dss) =+      let (ST m' a' ds') = foldr (toDart . (u,)) (ST m a mempty) vs+      in ST m' a' (ds':dss)+++    -- | Given an edge (u,v) and a triplet (m,a,ds) we construct a new dart+    -- representing this edge.+    toDart                   :: (VertexID,VertexID) -> ST' [Dart s] -> ST' [Dart s]+    toDart (u,v) (ST m a ds) = let dir = if u < v then Positive else Negative+                                   t'  = (min u v, max u v)+                               in case M.lookup t' m of+      Just a' -> ST m                  a     (Dart (Arc a') dir : ds)+      Nothing -> ST (SM.insert t' a m) (a+1) (Dart (Arc a)  dir : ds)
+ src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs view
@@ -0,0 +1,47 @@+module Algorithms.Geometry.EuclideanMST.EuclideanMST where++import           Algorithms.Geometry.DelaunayTriangulation.DivideAndConqueror+import           Algorithms.Geometry.DelaunayTriangulation.Types+import           Algorithms.Graph.MST+import           Control.Lens+import           Data.Ext+import           Data.Geometry+import           Data.Geometry.Ipe+import qualified Data.List.NonEmpty as NonEmpty+import           Data.PlaneGraph+import           Data.Proxy+import           Data.Tree+++--------------------------------------------------------------------------------++-- | Computes the Euclidean Minimum Spanning Tree. We compute the Delaunay+-- Triangulation (DT), and then extract the EMST. Hence, the same restrictions+-- apply as for the DT:+--+-- pre: the input is a *SET*, i.e. contains no duplicate points. (If the input+-- does contain duplicate points, the implementation throws them away)+--+-- running time: $O(n \log n)$+euclideanMST     :: (Ord r, Fractional r)+                 => NonEmpty.NonEmpty (Point 2 r :+ p) -> Tree (Point 2 r :+ p)+euclideanMST pts = (\v -> g^.vDataOf v) <$> t+  where+    -- since we care only about the relative order of the edges we can use the+    -- squared Euclidean distance rather than the Euclidean distance, thus+    -- avoiding the Floating constraint+    g = withEdgeDistances squaredEuclideanDist . toPlaneGraph (Proxy :: Proxy MSTW)+      . delaunayTriangulation $ pts+    t = mst g+++data MSTW+++drawTree' :: IpeOut (Tree (Point 2 r :+ p)) (IpeObject r)+drawTree' = IpeOut $+  asIpeGroup . map (asIpeObject' mempty . uncurry ClosedLineSegment) . treeEdges+++treeEdges              :: Tree a -> [(a,a)]+treeEdges (Node v chs) = map ((v,) . rootLabel) chs ++ concatMap treeEdges chs
+ src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs view
@@ -0,0 +1,57 @@+module Algorithms.Geometry.PolyLineSimplification.DouglasPeucker where++import Data.Semigroup+import Data.Ord(comparing)+import Control.Lens hiding (only)+import Data.Ext+import Data.Geometry.PolyLine+import Data.Geometry.Point+import Data.Geometry.Vector+import Data.Geometry.LineSegment+import qualified Data.Seq2 as S2+import qualified Data.Sequence as S+import qualified Data.Foldable as F++-- | Line simplification with the well-known Douglas Peucker alogrithm. Given a distance+-- value eps adn a polyline pl, constructs a simplification of pl (i.e. with+-- vertices from pl) s.t. all other vertices are within dist eps to the+-- original polyline.+--+-- Running time: O(n^2) worst case, O(n log n) expected.+douglasPeucker         :: (Ord r, Fractional r, Arity d)+                       => r -> PolyLine d p r -> PolyLine d p r+douglasPeucker eps pl+    | dst <= (eps*eps) = fromPoints [a,b]+    | otherwise        = douglasPeucker eps pref `merge` douglasPeucker eps subf+  where+    pts@(S2.Seq2 a _ b) = pl^.points+    (i,dst)             = maxDist pts (ClosedLineSegment a b)++    (pref,subf)         = split i pl++--------------------------------------------------------------------------------+-- * Internal functions++-- | Concatenate the two polylines, dropping their shared vertex+merge          :: PolyLine d p r -> PolyLine d p r -> PolyLine d p r+merge pref sub = PolyLine $ pref' >+< (sub^.points)+  where+    (pref' S2.:>> _) = S2.viewr $ pref^.points+    ~(a S2.:< as) >+< bs = S2.fromSeqUnsafe $ a S.<| as <> S2.toSeq bs++-- | Split the polyline at the given vertex. Both polylines contain this vertex+split                  :: Int -> PolyLine d p r+                       -> (PolyLine d p r, PolyLine d p r)+split i (PolyLine pts) = bimap f f (as,bs)+  where+    f = PolyLine . S2.fromSeqUnsafe+    as = S2.take (i+1) pts+    bs = S2.drop i     pts++-- | Given a sequence of points, find the index of the point that has the+-- Furthest distance to the LineSegment. The result is the index of the point+-- and this distance.+maxDist       :: (Ord r, Fractional r, Arity d)+              => S2.Seq2 (Point d r :+ p) -> LineSegment d p r -> (Int,r)+maxDist pts s = F.maximumBy (comparing snd) . S2.mapWithIndex (\i (p :+ _) ->+                                                     (i,sqDistanceToSeg p s)) $ pts
+ src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs view
@@ -0,0 +1,51 @@+module Algorithms.Geometry.SmallestEnclosingBall.Naive where++-- just for the types+import Control.Lens+import Data.Ext+import Algorithms.Geometry.SmallestEnclosingBall.Types+import Data.Geometry.Ball+import Data.Geometry.Point+import Data.List(minimumBy)+import Data.Function(on)+import Data.Maybe(fromMaybe)+import Algorithms.Util++--------------------------------------------------------------------------------++-- | Horrible O(n^4) implementation that simply tries all disks, checks if they+-- enclose all points, and takes the largest one. Basically, this is only useful+-- to check correctness of the other algorithm(s)+smallestEnclosingDisk          :: (Ord r, Fractional r)+                               => [Point 2 r :+ p]+                               -> DiskResult p r+smallestEnclosingDisk pts@(_:_:_) = smallestEnclosingDisk' pts $+                                      pairs pts ++ triplets pts+smallestEnclosingDisk _           = error "smallestEnclosingDisk: Too few points"++pairs     :: Fractional r => [Point 2 r :+ p] -> [DiskResult p r]+pairs pts = [DiskResult (fromDiameter (a^.core) (b^.core)) (Two a b)+            | SP a b <- uniquePairs pts]++triplets     :: (Ord r, Fractional r) => [Point 2 r :+ p] -> [DiskResult p r]+triplets pts = [DiskResult (disk' a b c) (Three a b c)+               | ST a b c <- uniqueTriplets pts]++disk'       :: (Ord r, Fractional r)+            => Point 2 r :+ p -> Point 2 r :+ p -> Point 2 r :+ p -> Disk () r+disk' a b c = fromMaybe degen $ disk (a^.core) (b^.core) (c^.core)+  where+    -- if the points are colinear, select the disk by the diametral pair+    degen = (smallestEnclosingDisk' [a,b,c] $ pairs [a,b,c])^.enclosingDisk+++-- | Given a list of canidate enclosing disks, report the smallest one.+smallestEnclosingDisk'     :: (Ord r, Num r)+                           => [Point 2 r :+ p] -> [DiskResult p r] -> DiskResult p r+smallestEnclosingDisk' pts = minimumBy (compare `on` (^.enclosingDisk.squaredRadius))+                           . filter (flip enclosesAll pts)+++-- | check if a disk encloses all points+enclosesAll   :: (Num r, Ord r) => DiskResult p r -> [Point 2 r :+ q] -> Bool+enclosesAll d = all (\(p :+ _) -> p `inClosedBall` (d^.enclosingDisk))
src/Algorithms/Geometry/SmallestEnclosingBall/RandomizedIncrementalConstruction.hs view
@@ -2,11 +2,13 @@ {-# LANGUAGE TemplateHaskell  #-} module Algorithms.Geometry.SmallestEnclosingBall.RandomizedIncrementalConstruction where +import           Algorithms.Geometry.SmallestEnclosingBall.Types+ import           Control.Lens import           Data.Ext import qualified Data.Foldable as F+import           Data.Geometry import           Data.Geometry.Ball-import           Data.Geometry.Point import qualified Data.List as L import           Data.List.NonEmpty import           Data.Maybe(fromMaybe)@@ -17,30 +19,17 @@   --- | List of two or three elements-data TwoOrThree a = Two !a !a | Three !a !a !a deriving (Show,Read,Eq,Ord,Functor)--instance F.Foldable TwoOrThree where-  foldMap f (Two   a b)   = f a <> f b-  foldMap f (Three a b c) = f a <> f b <> f c---- | The result of a smallest enclosing disk computation: The smallest ball---    and the points defining it-data DiskResult p r = DiskResult { _enclosingDisk  :: Circle () r-                                 , _definingPoints :: TwoOrThree (Point 2 r :+ p)-                                 }-makeLenses ''DiskResult- -- | O(n) expected time algorithm to compute the smallest enclosing disk of a -- set of points. we need at least two points. -- implemented using randomized incremental construction smallestEnclosingDisk           :: (Ord r, Fractional r, RandomGen g)                                 => g-                                -> Point 2 r :+ p -> Point 2 r :+ p -> [Point 2 r :+ p]+                                -> [Point 2 r :+ p]                                 -> DiskResult p r-smallestEnclosingDisk g p q pts = let (p':q':pts') = shuffle g (p:q:pts)-                                  in smallestEnclosingDisk' p' q' pts' +smallestEnclosingDisk g pts@(_:_:_) = let (p:q:pts') = shuffle g pts+                                      in smallestEnclosingDisk' p q pts'+smallestEnclosingDisk g _           = error "smallestEnclosingDisk: Too few points"  -- | Smallest enclosing disk. smallestEnclosingDisk'     :: (Ord r, Fractional r)@@ -78,8 +67,8 @@       | (r^.core) `inClosedBall` d = br       | otherwise                  = DiskResult (circle' r) (Three p q r) -    circle' r = fromMaybe degen $ circle (p^.core) (q^.core) (r^.core)-    degen = error "smallestEnclosingDisk: Unhandled degeneracy"+    circle' r = fromMaybe degen $ disk (p^.core) (q^.core) (r^.core)+    degen = error "smallestEnclosingDisk: Unhandled degeneracy, three points on a line"     -- TODO: handle degenerate case
+ src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveFunctor  #-}+{-# LANGUAGE TemplateHaskell  #-}+module Algorithms.Geometry.SmallestEnclosingBall.Types where++import           Data.Monoid+import qualified Data.Foldable as F+import           Data.Geometry+import           Data.Geometry.Ball+import           Control.Lens+import           Data.Ext++--------------------------------------------------------------------------------++-- | List of two or three elements+data TwoOrThree a = Two !a !a | Three !a !a !a deriving (Show,Read,Eq,Ord,Functor)++instance F.Foldable TwoOrThree where+  foldMap f (Two   a b)   = f a <> f b+  foldMap f (Three a b c) = f a <> f b <> f c+++fromList         :: [a] -> Either String (TwoOrThree a)+fromList [a,b]   = Right $ Two a b+fromList [a,b,c] = Right $ Three a b c+fromList _       = Left "Wrong number of elements"+++++-- | The result of a smallest enclosing disk computation: The smallest ball+--    and the points defining it+data DiskResult p r = DiskResult { _enclosingDisk  :: Disk () r+                                 , _definingPoints :: TwoOrThree (Point 2 r :+ p)+                                 }+makeLenses ''DiskResult
+ src/Algorithms/Graph/DFS.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Algorithms.Graph.DFS where++import           Control.Monad.ST (ST,runST)+import           Data.Maybe+import           Data.PlanarGraph+import           Data.Tree+import qualified Data.Vector as V+import qualified Data.Vector.Generic as GV+import qualified Data.Vector.Unboxed.Mutable as UMV+++-- | DFS on a planar graph.+--+-- Running time: $O(n)$+--+-- Note that since our planar graphs are always connected there is no need need+-- for dfs to take a list of start vertices.+dfs  :: forall s w v e f.+      PlanarGraph s w v e f -> VertexId s w -> Tree (VertexId s w)+dfs g = dfs' (adjacencyLists g)++-- | Adjacency list representation of a graph: for each vertex we simply list+-- all connected neighbours.+type AdjacencyLists s w = V.Vector [VertexId s w]++-- | Transform into adjacencylist representation+adjacencyLists   :: PlanarGraph s w v e f -> AdjacencyLists s w+adjacencyLists g = V.toList . flip neighboursOf g <$> vertices' g++-- | DFS, from a given vertex, on a graph in AdjacencyLists representation.+--+-- Running time: $O(n)$+dfs'          :: forall s w. AdjacencyLists s w -> VertexId s w -> Tree (VertexId s w)+dfs' g start = runST $ do+                 bv     <- UMV.replicate n False -- bit vector of marks+                 -- start will be unvisited, thus the fromJust is safe+                 fromJust <$> dfs'' bv start+  where+    n = GV.length g++    neighs              :: VertexId s w -> [VertexId s w]+    neighs (VertexId u) = g GV.! u++    visit   bv (VertexId i) = UMV.write bv i True+    visited bv (VertexId i) = UMV.read  bv i+    dfs''      :: UMV.MVector s' Bool -> VertexId s w+               -> ST s' (Maybe (Tree (VertexId s w)))+    dfs'' bv u = visited bv u >>= \case+                   True  -> pure Nothing+                   False -> do+                              visit bv u+                              Just . Node u . catMaybes <$> mapM (dfs'' bv) (neighs u)
+ src/Algorithms/Graph/MST.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Algorithms.Graph.MST( mst+                           , mstEdges+                           , makeTree+                           ) where++import           Algorithms.Graph.DFS (AdjacencyLists, dfs')+import           Control.Monad (forM_, when, filterM)+import           Control.Monad.ST (ST,runST)+import qualified Data.List as L+import           Data.PlanarGraph+import           Data.Tree+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Unboxed.Mutable as UMV++--------------------------------------------------------------------------------+++-- | Minimum spanning tree of the edges. The result is a rooted tree, in which+-- the nodes are the vertices in the planar graph together with the edge weight+-- of the edge to their parent. The root's weight is zero.+--+-- The algorithm used is Kruskal's.+--+-- running time: $O(n \log n)$+mst   :: Ord e => PlanarGraph s w v e f -> Tree (VertexId s w)+mst g = makeTree g $ mstEdges g+  -- TODO: Add edges/darts to the output somehow.++-- | Computes the set of edges in the Minimum spanning tree+--+-- running time: $O(n \log n)$+mstEdges   :: Ord e => PlanarGraph s w v e f -> [Dart s]+mstEdges g = runST $ do+          uf <- new (numVertices g)+          filterM (\e -> union uf (headOf e g) (tailOf e g)) edges''+  where+    edges'' = map fst . L.sortOn snd . V.toList $ edges g+++-- | Given an underlying planar graph, and a set of edges that form a tree,+-- create the actual tree.+--+-- pre: the planar graph has at least one vertex.+makeTree   :: forall s w v e f.+              PlanarGraph s w v e f -> [Dart s] -> Tree (VertexId s w)+makeTree g = flip dfs' start . mkAdjacencyLists+  where+    n = numVertices g+    start = V.head $ vertices' g++    append                  :: MV.MVector s' [a] -> VertexId s w -> a -> ST s' ()+    append v (VertexId i) x = MV.read v i >>= MV.write v i . (x:)++    mkAdjacencyLists         :: [Dart s] -> AdjacencyLists s w+    mkAdjacencyLists edges'' = V.create $ do+                                 vs <- MV.replicate n []+                                 forM_ edges'' $ \e -> do+                                   let u = headOf e g+                                       v = tailOf e g+                                   append vs u v+                                   append vs v u+                                 pure vs+--------------------------------------------------------------------------------++-- | Union find DS+newtype UF s a = UF { _unUF :: UMV.MVector s (Int,Int) }++new   :: Enum a => Int -> ST s (UF s a)+new n = do+          v <- UMV.new n+          forM_ [0..n-1] $ \i ->+            UMV.write v i (i,0)+          pure $ UF v++-- | Union the components containing x and y. Returns weather or not the two+-- components were already in the same component or not.+union               :: (Enum a, Eq a) => UF s a -> a -> a -> ST s Bool+union uf@(UF v) x y = do+                        (rx,rrx) <- find' uf x+                        (ry,rry) <- find' uf y+                        let b = rx /= ry+                            rx' = fromEnum rx+                            ry' = fromEnum ry+                        when b $ case rrx `compare` rry of+                            LT -> UMV.write v rx'  (ry',rrx)+                            GT -> UMV.write v ry' (rx',rry)+                            EQ -> do UMV.write v ry' (rx',rry)+                                     UMV.write v rx' (rx',rrx+1)+                        pure b+++-- | Get the representative of the component containing x+-- find    :: (Enum a, Eq a) => UF s a -> a -> ST s a+-- find uf = fmap fst . find' uf++-- | get the representative (and its rank) of the component containing x+find'             :: (Enum a, Eq a) => UF s a -> a -> ST s (a,Int)+find' uf@(UF v) x = do+                      (p,r) <- UMV.read v (fromEnum x) -- get my parent+                      if toEnum p == x then+                        pure (x,r) -- I am a root+                      else do+                        rt@(j,_) <- find' uf (toEnum p)  -- get the root of my parent+                        UMV.write v (fromEnum x) (fromEnum j,r)   -- path compression+                        pure rt+++--------------------------------------------------------------------------------++-- partial implementation of Prims+-- mst g = undefined++-- -- | runs MST with a given root+-- mstFrom     :: (Ord e, Monoid e)+--             => VertexId s w -> PlanarGraph s w v e f -> Tree (VertexId s w, e)+-- mstFrom r g = prims initialQ (Node (r,mempty) [])+--   where+--     update' k p q = Q.adjust (const p) k q++--     -- initial Q has the value of the root set to the zero element, and has no+--     -- parent. The others are all set to Top (and have no parent yet)+--     initialQ = update' r (ValT (mempty,Nothing))+--              . GV.foldr (\v q -> Q.insert v (Top,Nothing) q) Q.empty $ vertices g++--     prims qq t = case Q.minView qq of+--       Nothing -> t+--       Just (v Q.:-> (w,p), q) -> prims $++--------------------------------------------------------------------------------+-- Testing Stuff++-- testG = planarGraph' [ [ (Dart aA Negative, "a-")+--                        , (Dart aC Positive, "c+")+--                        , (Dart aB Positive, "b+")+--                        , (Dart aA Positive, "a+")+--                        ]+--                      , [ (Dart aE Negative, "e-")+--                        , (Dart aB Negative, "b-")+--                        , (Dart aD Negative, "d-")+--                        , (Dart aG Positive, "g+")+--                        ]+--                      , [ (Dart aE Positive, "e+")+--                        , (Dart aD Positive, "d+")+--                        , (Dart aC Negative, "c-")+--                        ]+--                      , [ (Dart aG Negative, "g-")+--                        ]+--                      ]+--   where+--     (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]
+ src/Algorithms/Util.hs view
@@ -0,0 +1,20 @@+module Algorithms.Util where++import qualified Data.List as L+++data SP a b = SP !a !b deriving (Eq,Ord,Show)++-- | Given a list xs, generate all unique (unordered) pairs.+uniquePairs    :: [a] -> [SP a a]+uniquePairs xs = [ SP x y | (x:ys) <- nonEmptyTails xs, y <- ys ]++nonEmptyTails :: [a] -> [[a]]+nonEmptyTails = L.init . L.tails+++data ST a b c = ST !a !b !c deriving (Eq,Ord,Show)++-- | All unieuqe unordered triplets.+uniqueTriplets    :: [a] -> [ST a a a]+uniqueTriplets xs = [ ST x y z | (x:ys) <- nonEmptyTails xs, SP y z <- uniquePairs ys]
src/Control/Monad/State/Persistent.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} module Control.Monad.State.Persistent( PersistentStateT                                      , PersistentState                                      , store
+ src/Data/BinaryTree.hs view
@@ -0,0 +1,63 @@+{-# Language DeriveFunctor #-}+{-# Language FunctionalDependencies #-}+module Data.BinaryTree where++import Control.Applicative+import Data.Foldable+import Data.List.NonEmpty(NonEmpty)+import Data.Semigroup+import Data.Traversable+import Data.Semigroup.Foldable++data BinLeafTree v a = Leaf a+                     | Node (BinLeafTree v a) v (BinLeafTree v a)+                     deriving (Show,Read,Eq,Ord,Functor)+++class Semigroup v => Measured v a | a -> v where+  measure :: a -> v++-- | smart constructor+node     :: Measured v a => BinLeafTree v a -> BinLeafTree v a -> BinLeafTree v a+node l r = Node l (measure l <> measure r) r+++instance Measured v a => Measured v (BinLeafTree v a) where+  measure (Leaf x)     = measure x+  measure (Node _ v _) = v+++instance Foldable (BinLeafTree v) where+  foldMap f (Leaf a)     = f a+  foldMap f (Node l _ r) = foldMap f l `mappend` foldMap f r++instance Foldable1 (BinLeafTree v)++instance Traversable (BinLeafTree v) where+  traverse f (Leaf a)     = Leaf <$> f a+  traverse f (Node l v r) = Node <$> traverse f l <*> pure v <*> traverse f r++instance Measured v a => Semigroup (BinLeafTree v a) where+  l <> r = node l r+++asBalancedBinLeafTree    :: NonEmpty a -> BinLeafTree Size (Elem a)+asBalancedBinLeafTree ys = asBLT (length ys') ys'+  where+    ys' = toList ys++    asBLT _ [x] = Leaf (Elem x)+    asBLT n xs  = let h       = n `div` 2+                      (ls,rs) = splitAt h xs+                  in node (asBLT h ls) (asBLT (n-h) rs)++newtype Size = Size Int deriving (Show,Read,Eq,Num,Integral,Enum,Real,Ord)++instance Semigroup Size where+  x <> y = x + y++newtype Elem a = Elem { _unElem :: a }+               deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable)++instance Measured Size (Elem a) where+  measure _ = 1
+ src/Data/CircularList/Util.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+module Data.CircularList.Util where++import           Control.Lens+import           Data.Tuple+import qualified Data.CircularList as C+import qualified Data.List as L+import qualified Data.Traversable as T++import Debug.Trace++-- $setup+-- >>> let ordList = C.fromList [5,6,10,20,30,1,2,3]++++-- | Given a circular list, whose elements are in increasing order, insert the+-- new element into the Circular list in its sorted order.+--+-- >>> insertOrd 1 C.empty+-- fromList [1]+-- >>> insertOrd 1 $ C.fromList [2]+-- fromList [2,1]+-- >>> insertOrd 2 $ C.fromList [1,3]+-- fromList [1,2,3]+-- >>> insertOrd 31 ordList+-- fromList [5,6,10,20,30,31,1,2,3]+-- >>> insertOrd 1 ordList+-- fromList [5,6,10,20,30,1,1,2,3]+-- >>> insertOrd 4 ordList+-- fromList [5,6,10,20,30,1,2,3,4]+-- >>> insertOrd 11 ordList+-- fromList [5,6,10,11,20,30,1,2,3]+insertOrd :: Ord a => a -> C.CList a -> C.CList a+insertOrd = insertOrdBy compare++-- | Insert an element into an increasingly ordered circular list, with+-- specified compare operator.+insertOrdBy       :: (a -> a -> Ordering) -> a -> C.CList a -> C.CList a+insertOrdBy cmp x = C.fromList . insertOrdBy' cmp x . C.rightElements++-- | List version of insertOrdBy; i.e. the list contains the elements in+-- cirulcar order. Again produces a list that has the items in circular order.+insertOrdBy'         :: (a -> a -> Ordering) -> a -> [a] -> [a]+insertOrdBy' cmp x xs = case (rest, x `cmp` head rest) of+    ([],  _)   -> L.insertBy cmp x pref+    (z:zs, GT) -> (z : L.insertBy cmp x zs) ++ pref+    (_:_,  EQ) -> (x : xs) -- == x : rest ++ pref+    (_:_,  LT) -> rest ++ L.insertBy cmp x pref+  where+    -- split the list at its maximum.+    (pref,rest) = splitIncr cmp xs++-- given a list of elements that is supposedly a a cyclic-shift of a list of+-- increasing items, find the splitting point. I.e. returns a pair of lists+-- (ys,zs) such that xs = zs ++ ys, and ys ++ zs is (supposedly) in sorted+-- order.+splitIncr              :: (a -> a -> Ordering) -> [a] -> ([a],[a])+splitIncr _   []       = ([],[])+splitIncr cmp xs@(x:_) = swap . bimap (map snd) (map snd)+                      . L.break (\(a,b) -> (a `cmp` b) == GT) $ zip (x:xs) xs++-- | Test if the circular list is a cyclic shift of the second list.+-- Running time: O(n), where n is the size of the smallest list+isShiftOf         :: Eq a => C.CList a -> C.CList a -> Bool+xs `isShiftOf` ys = let rest = tail . C.leftElements+                    in maybe False (\xs' -> rest xs' == rest ys) $+                         C.focus ys >>= flip C.rotateTo xs+++-- minimumBy     :: (a -> a -> Ordering) -> C.CList a -> a+-- minimumBy cmp = L.minimumBy cmp . C.rightElements++#if !MIN_VERSION_data_clist(0,1,0)++instance Foldable C.CList where+  foldMap = T.foldMapDefault++instance T.Traversable C.CList where+  traverse f = fmap C.fromList . T.traverse f . C.rightElements++#endif
+ src/Data/CircularSeq.hs view
@@ -0,0 +1,281 @@+module Data.CircularSeq( CSeq+                       , cseq+                       , singleton+                       , fromNonEmpty+                       , fromList++                       , focus+                       , index, adjust+                       , item++                       , rotateL+                       , rotateR+                       , rotateNL, rotateNR++                       , rightElements+                       , leftElements+                       , asSeq++                       , reverseDirection+                       , allRotations++                       , findRotateTo+                       , rotateTo+                       ) where++import           Control.Applicative+import           Control.Lens(lens, Lens')+import qualified Data.Foldable as F+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Maybe (listToMaybe)+import           Data.Semigroup+import           Data.Semigroup.Foldable+import           Data.Sequence ((|>),(<|),ViewL(..),ViewR(..),Seq)+import qualified Data.Sequence as S+import qualified Data.Traversable as T+import           Data.Tuple (swap)++--------------------------------------------------------------------------------++-- | Nonempty circular sequence+data CSeq a = CSeq !(Seq a) !a !(Seq a)+            deriving (Eq)+                     -- we keep the seq balanced, i.e. size left >= size right++instance Show a => Show (CSeq a) where+  showsPrec d s = showParen (d > app_prec) $+                    showString (("CSeq " <>) . show . F.toList . rightElements $ s)+    where app_prec = 10++-- traverses starting at the focus, going to the right.+instance T.Traversable CSeq where+  traverse f (CSeq l x r) = (\x' r' l' -> CSeq l' x' r')+                         <$> f x <*> traverse f r <*> traverse f l+-- instance Traversable1 CSeq where+--   traverse1 f (CSeq l x r) = liftF3 (\x' r' l' -> CSeq l' x' r')+--                                     (f x) (traverse f r) (traverse f l)++instance Foldable1 CSeq+++instance F.Foldable CSeq where+  foldMap = T.foldMapDefault+  length (CSeq l _ r) = 1 + S.length l + S.length r+++++instance Functor CSeq where+  fmap = T.fmapDefault+++singleton   :: a -> CSeq a+singleton x = CSeq S.empty x S.empty++-- | Gets the focus of the CSeq+-- running time: O(1)+focus              :: CSeq a -> a+focus (CSeq _ x _) = x++-- | Access the i^th item  (w.r.t the focus) in the CSeq (indices modulo n).+--+-- running time: $O(\log (i \mod n))$+--+-- >>> index (fromList [0..5]) 1+-- 1+-- >>> index (fromList [0..5]) 2+-- 2+-- >>> index (fromList [0..5]) 5+-- 5+-- >>> index (fromList [0..5]) 10+-- 4+-- >>> index (fromList [0..5]) 6+-- 0+-- >>> index (fromList [0..5]) (-1)+-- 5+-- >>> index (fromList [0..5]) (-6)+-- 0+index                   :: CSeq a -> Int -> a+index s@(CSeq l x r) i' = let i  = i' `mod` length s+                              rn = length r+                          in if i == 0 then x+                               else if i - 1 < rn then S.index r (i - 1)+                                                  else S.index l (i - rn - 1)++-- | Adjusts the i^th element w.r.t the focus in the CSeq+--+-- running time: $O(\log (i \mod n))$+--+-- >>> adjust (const 1000) 2 (fromList [0..5])+-- CSeq [0,1,1000,3,4,5]+adjust                     :: (a -> a) -> Int -> CSeq a -> CSeq a+adjust f i' s@(CSeq l x r) = let i  = i' `mod` length s+                                 rn = length r+                             in if i == 0 then CSeq l (f x) r+                                else if i - 1 < rn+                                     then CSeq l                           x (S.adjust f (i - 1) r)+                                     else CSeq (S.adjust f (i - rn - 1) l) x r+++-- | Access te ith item in the CSeq (w.r.t the focus) as a lens+item   :: Int -> Lens' (CSeq a) a+item i = lens (flip index i) (\s x -> adjust (const x) i s)+++resplit   :: Seq a -> (Seq a, Seq a)+resplit s = swap $ S.splitAt (length s `div` 2) s+++-- | smart constructor that automatically balances the seq+cseq                   :: Seq a -> a -> Seq a -> CSeq a+cseq l x r+    | ln > 1 + 2*rn    = withFocus x (r <> l)+    | ln < rn `div`  2 = withFocus x (r <> l)+    | otherwise        = CSeq l x r+  where+    rn = length r+    ln = length l++-- | Builds a balanced seq with the element as the focus.+withFocus     :: a -> Seq a -> CSeq a+withFocus x s = let (l,r) = resplit s in CSeq l x r++-- | rotates one to the right+--+-- running time: O(1) (amortized)+--+-- >>> rotateR $ fromList [3,4,5,1,2]+-- CSeq [4,5,1,2,3]+rotateR                :: CSeq a -> CSeq a+rotateR s@(CSeq l x r) = case S.viewl r of+                           EmptyL    -> case S.viewl l of+                             EmptyL    -> s+                             (y :< l') -> cseq (S.singleton x) y l'+                           (y :< r') -> cseq (l |> x) y r'++-- | rotates the focus to the left+--+-- running time: O(1) (amortized)+--+-- >>> rotateL $ fromList [3,4,5,1,2]+-- CSeq [2,3,4,5,1]+-- >>> mapM_ print . take 5 $ iterate rotateL $ fromList [1..5]+-- CSeq [1,2,3,4,5]+-- CSeq [5,1,2,3,4]+-- CSeq [4,5,1,2,3]+-- CSeq [3,4,5,1,2]+-- CSeq [2,3,4,5,1]+rotateL                :: CSeq a -> CSeq a+rotateL s@(CSeq l x r) = case S.viewr l of+                           EmptyR    -> case S.viewr r of+                             EmptyR     -> s+                             (r' :> y)  -> cseq r' y (S.singleton x)+                           (l' :> y) -> cseq l' y (x <| r)+++-- | Convert to a single Seq, starting with the focus.+asSeq :: CSeq a -> Seq a+asSeq = rightElements+++-- | All elements, starting with the focus, going to the right++-- >>> rightElements $ fromList [3,4,5,1,2]+-- fromList [3,4,5,1,2]+rightElements              :: CSeq a -> Seq a+rightElements (CSeq l x r) = x <| r <> l+++-- | All elements, starting with the focus, going to the left+--+-- >>> leftElements $ fromList [3,4,5,1,2]+-- fromList [3,2,1,5,4]+leftElements              :: CSeq a -> Seq a+leftElements (CSeq l x r) = x <| S.reverse l <> S.reverse r++-- | builds a CSeq+fromNonEmpty                    :: NonEmpty.NonEmpty a -> CSeq a+fromNonEmpty (x NonEmpty.:| xs) = withFocus x $ S.fromList xs++fromList        :: [a] -> CSeq a+fromList (x:xs) = withFocus x $ S.fromList xs+fromList []     = error "fromList: Empty list"++-- | Rotates i elements to the right.+--+-- pre: 0 <= i < n+--+-- running time: $O(\log i)$ amortized+--+-- >>> rotateNR 0 $ fromList [1..5]+-- CSeq [1,2,3,4,5]+-- >>> rotateNR 1 $ fromList [1..5]+-- CSeq [2,3,4,5,1]+-- >>> rotateNR 4 $ fromList [1..5]+-- CSeq [5,1,2,3,4]+rotateNR     :: Int -> CSeq a -> CSeq a+rotateNR i s = let (l, r')  = S.splitAt i $ rightElements s+                   (x :< r) = S.viewl r'+               in cseq l x r+++-- | Rotates i elements to the left.+--+-- pre: 0 <= i < n+--+-- running time: $O(\log i)$ amoritzed+--+-- >>> rotateNL 0 $ fromList [1..5]+-- CSeq [1,2,3,4,5]+-- >>> rotateNL 1 $ fromList [1..5]+-- CSeq [5,1,2,3,4]+-- >>> rotateNL 2 $ fromList [1..5]+-- CSeq [4,5,1,2,3]+-- >>> rotateNL 3 $ fromList [1..5]+-- CSeq [3,4,5,1,2]+-- >>> rotateNL 4 $ fromList [1..5]+-- CSeq [2,3,4,5,1]+rotateNL     :: Int -> CSeq a -> CSeq a+rotateNL i s = let (x :< xs) = S.viewl $ rightElements s+                   (l',r)    = S.splitAt (length s - i) $ xs |> x+                   (l :> y)  = S.viewr l'+               in cseq l y r+++-- | Reversres the direction of the CSeq+--+-- running time: $O(n)$+--+-- >>> reverseDirection $ fromList [1..5]+-- CSeq [1,5,4,3,2]+reverseDirection              :: CSeq a -> CSeq a+reverseDirection (CSeq l x r) = CSeq (S.reverse r) x (S.reverse l)+++-- | Finds an element in the CSeq+--+-- >>> findRotateTo (== 3) $ fromList [1..5]+-- Just (CSeq [3,4,5,1,2])+-- >>> findRotateTo (== 7) $ fromList [1..5]+-- Nothing+findRotateTo   :: (a -> Bool) -> CSeq a -> Maybe (CSeq a)+findRotateTo p = listToMaybe . filter (p . focus) . allRotations'+++rotateTo   :: Eq a => a -> CSeq a -> Maybe (CSeq a)+rotateTo x = findRotateTo (== x)+++-- | All rotations, the input CSeq is the focus.+--+-- >>> mapM_ print . allRotations $ fromList [1..5]+-- CSeq [1,2,3,4,5]+-- CSeq [2,3,4,5,1]+-- CSeq [3,4,5,1,2]+-- CSeq [4,5,1,2,3]+-- CSeq [5,1,2,3,4]+allRotations :: CSeq a -> CSeq (CSeq a)+allRotations = fromList . allRotations'++allRotations'   :: CSeq a -> [CSeq a]+allRotations' s = take (length s) . iterate rotateR $ s
src/Data/Ext.hs view
@@ -3,26 +3,45 @@ import Control.Applicative import Control.Lens import Data.Semigroup+import Data.Biapplicative+import Data.Bifunctor.Apply+import Data.Bifoldable+import Data.Bitraversable+import Data.Semigroup.Bifoldable+import Data.Semigroup.Bitraversable+import Data.Functor.Apply(liftF2)  -------------------------------------------------------------------------------- -data Ext extra core = core :+ extra deriving (Show,Read,Eq,Ord)+data core :+ extra = core :+ extra deriving (Show,Read,Eq,Ord,Bounded)+infixr 1 :+ -instance Functor (Ext e) where-  fmap f (c :+ e) = f c :+ e -instance Monoid e => Applicative (Ext e) where-  pure x = x :+ mempty-  -- | This implementation ignores any extra values f may have-  (f :+ _) <*> (c :+ce) = f c :+ ce+instance Bifunctor (:+) where+  bimap f g (c :+ e) = f c :+ g e -instance (Semigroup core, Semigroup extra) => Semigroup (Ext extra core) where-  (c :+ e) <> (c' :+ e') = c <> c' :+ e <> e'+instance Biapply (:+) where+  (f :+ g) <<.>> (c :+ e) = f c :+ g e +instance Biapplicative (:+) where+  bipure = (:+)+  (f :+ g) <<*>> (c :+ e) = f c :+ g e -type core :+ extra = Ext extra core-infixr 1 :++instance Bifoldable (:+) where+  bifoldMap f g (c :+ e) = f c `mappend` g e +instance Bitraversable (:+) where+  bitraverse f g (c :+ e) = (:+) <$> f c <*> g e++instance Bifoldable1 (:+)++instance Bitraversable1 (:+) where+  bitraverse1 f g (c :+ e) = liftF2 (:+) (f c) (g e)++instance (Semigroup core, Semigroup extra) => Semigroup (core :+ extra) where+  (c :+ e) <> (c' :+ e') = c <> c' :+ e <> e'++ _core :: (core :+ extra) -> core _core (c :+ _) = c @@ -35,6 +54,5 @@ extra :: Lens (core :+ extra) (core :+ extra') extra extra' extra = lens _extra (\(c :+ _) e -> (c :+ e)) --only   :: a -> a :+ ()-only x = x :+ ()+ext   :: a -> a :+ ()+ext x = x :+ ()
src/Data/Geometry.hs view
@@ -1,18 +1,29 @@-module Data.Geometry( module Prop-                    , module T-                    , module P-                    , module V-                    , module L+{-|+Module    : Data.Geometry+Description: Basic Geometry types+Copyright : (c) Frank Staals+License : See LICENCE file+-}+module Data.Geometry( module Data.Geometry.Properties+                    , module Data.Geometry.Transformation+                    , module Data.Geometry.Point+                    , module Data.Geometry.Vector+                    , module Data.Geometry.Line+                    , module Data.Geometry.LineSegment+                    , module Data.Geometry.PolyLine+                    , module Data.Geometry.Polygon                     , module Linear.Affine+                    , module Linear.Vector                     ) where  -import Data.Geometry.Properties as Prop-import Data.Geometry.Transformation as T--import Data.Geometry.Point as P-import Data.Geometry.Vector as V-import Data.Geometry.Line as L-+import Data.Geometry.Line+import Data.Geometry.LineSegment+import Data.Geometry.Point+import Data.Geometry.PolyLine hiding (fromPoints)+import Data.Geometry.Polygon hiding (fromPoints)+import Data.Geometry.Properties+import Data.Geometry.Transformation+import Data.Geometry.Vector import Linear.Affine hiding (Point, origin)-import Linear.Vector as V+import Linear.Vector
src/Data/Geometry/Ball.hs view
@@ -1,24 +1,29 @@ {-# LANGUAGE TemplateHaskell  #-}-{-# LANGUAGE DeriveFunctor  #-}-{-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE UndecidableInstances #-} module Data.Geometry.Ball where -import Data.Ext-import Control.Lens hiding (only)+import           Control.Lens+import           Data.Bifunctor+import           Data.Ext+import qualified Data.Foldable as F+import           Data.Geometry.Boundary+import           Data.Geometry.Line+import           Data.Geometry.LineSegment+import           Data.Geometry.Point+import           Data.Geometry.Properties+import           Data.Geometry.Vector import qualified Data.List as L-import Data.Geometry.Line-import Data.Geometry.LineSegment-import Data.Geometry.Point-import Data.Geometry.Properties-import Data.Geometry.Vector-import GHC.TypeLits-import Linear.Affine(qdA, (.-.), (.+^))-import Linear.Vector((^/),(*^),(^+^))+import qualified Data.Traversable as T+import           Data.Vinyl+import           Frames.CoRec+import           GHC.TypeLits+import           Linear.Affine(qdA, (.-.), (.+^))+import           Linear.Vector((^/),(*^),(^+^))  -------------------------------------------------------------------------------- -- * A d-dimensional ball +-- | A d-dimensional ball. data Ball d p r = Ball { _center        :: Point d r :+ p                        , _squaredRadius :: r                        }@@ -26,16 +31,22 @@  deriving instance (Show r, Show p, Arity d) => Show (Ball d p r) deriving instance (Eq r, Eq p, Arity d)     => Eq (Ball d p r)-deriving instance Arity d                   => Functor (Ball d p)  type instance NumType   (Ball d p r) = r type instance Dimension (Ball d p r) = d +instance Arity d => Functor (Ball d p) where+  fmap f (Ball c r) = Ball (first (fmap f) c) (f r)++instance Arity d => Bifunctor (Ball d) where+  bimap f g (Ball c r) = Ball (bimap (fmap g) f c) (g r)++ -- * Constructing Balls  -- | Given two points on the diameter of the ball, construct a ball. fromDiameter     :: (Arity d, Fractional r) => Point d r -> Point d r -> Ball d () r-fromDiameter p q = let c = p .+^ ((q .-. p) ^/ 2) in Ball (only c) (qdA c p)+fromDiameter p q = let c = p .+^ ((q .-. p) ^/ 2) in Ball (ext c) (qdA c p)  -- | Construct a ball given the center point and a point p on the boundary. fromCenterAndPoint     :: (Arity d, Num r) => Point d r :+ p -> Point d r :+ p -> Ball d p r@@ -43,18 +54,15 @@  -- | A d dimensional unit ball centered at the origin. unitBall :: (Arity d, Num r) => Ball d () r-unitBall = Ball (only origin) 1+unitBall = Ball (ext origin) 1  -- * Querying if a point lies in a ball --- | Result of a inBall query-data PointBallQueryResult = Inside | On | Outside deriving (Show,Read,Eq)- inBall                 :: (Arity d, Ord r, Num r)-                       => Point d r -> Ball d p r -> PointBallQueryResult+                       => Point d r -> Ball d p r -> PointLocationResult p `inBall` (Ball c sr) = case qdA p (c^.core) `compare` sr of                            LT -> Inside-                           EQ -> On+                           EQ -> OnBoundary                            GT -> Outside  -- | Test if a point lies strictly inside a ball@@ -85,26 +93,45 @@ -- False onBall       :: (Arity d, Ord r, Num r)              => Point d r -> Ball d p r -> Bool-p `onBall` b = p `inBall` b == On+p `onBall` b = p `inBall` b == OnBoundary   ----------------------------------------------------------------------------------- * Circles, aka 2-dimensional Balls+-- | Spheres, i.e. the boundary of a ball. -type Circle = Ball 2+type Sphere d p r = Boundary (Ball d p r) --- | Given three points, get the circle through the three points. If the three+pattern Sphere c r = Boundary (Ball c r)+++++--------------------------------------------------------------------------------+-- * Disks and Circles, aka 2-dimensional Balls and Spheres++type Disk p r = Ball 2 p r++pattern Disk c r = Ball c r+++type Circle p r = Sphere 2 p r++pattern Circle c r = Sphere c r++-- | Given three points, get the disk through the three points. If the three -- input points are colinear we return Nothing ----- >>> circle (point2 0 10) (point2 10 0) (point2 (-10) 0)--- Just (Ball {_center = Point {toVec = Vector {_unV = fromList [0.0,0.0]}} :+ (), _squaredRadius = 100.0})-circle       :: (Eq r, Fractional r)-             => Point 2 r -> Point 2 r -> Point 2 r -> Maybe (Circle () r)-circle p q r = case f p `intersect` f q of-                 LineLineIntersection c -> Just $ Ball (only c) (qdA c p)-                 _                      -> Nothing -- The two lines f p and f q are-                                                   -- parallel, that means the three-                                                   -- input points where colinear.+-- >>> disk (point2 0 10) (point2 10 0) (point2 (-10) 0)+-- Just (Ball {_center = Point2 [0.0,0.0] :+ (), _squaredRadius = 100.0})+disk       :: (Eq r, Fractional r)+           => Point 2 r -> Point 2 r -> Point 2 r -> Maybe (Disk () r)+disk p q r = match ((f p) `intersect` (f q)) $+       (H $ \NoIntersection -> Nothing)+    :& (H $ \c@(Point _)    -> Just $ Ball (ext c) (qdA c p))+    :& (H $ \_              -> Nothing)+    :& RNil+       -- If the intersection is not a point, The two lines f p and f q are+       -- parallel, that means the three input points where colinear.   where     -- Given a point p', get the line perpendicular, and through the midpoint     -- of the line segment p'r@@ -113,21 +140,24 @@            in perpendicularTo (Line midPoint v)  -instance (Ord r, Floating r) => (Line 2 r) `IsIntersectableWith` (Circle p r) where+newtype Touching p = Touching p deriving (Show,Eq,Ord,Functor,F.Foldable,T.Traversable) -  data Intersection (Line 2 r) (Circle p r) = NoLineCircleIntersection-                                            | LineTouchesCircle        (Point 2 r)-                                            | LineCircleIntersection   (Point 2 r) (Point 2 r)-                                              deriving (Show,Eq)+-- | No intersection, one touching point, or two points+type instance IntersectionOf (Line 2 r) (Circle p r) = [ NoIntersection+                                                       , Touching (Point 2 r)+                                                       , (Point 2 r, Point 2 r)+                                                       ] -  nonEmptyIntersection NoLineCircleIntersection = False-  nonEmptyIntersection _                        = True -  (Line p' v) `intersect` (Ball (c :+ _) r) = case discr `compare` 0 of-                                                LT -> NoLineCircleIntersection-                                                EQ -> LineTouchesCircle $ q' (lambda (+))+instance (Ord r, Floating r) => (Line 2 r) `IsIntersectableWith` (Circle p r) where++  nonEmptyIntersection = defaultNonEmptyIntersection++  (Line p' v) `intersect` (Circle (c :+ _) r) = case discr `compare` 0 of+                                                LT -> coRec $ NoIntersection+                                                EQ -> coRec . Touching $ q' (lambda (+))                                                 GT -> let [l1,l2] = L.sort [lambda (-), lambda (+)]-                                                      in LineCircleIntersection (q' l1) (q' l2)+                                                      in coRec $ (q' l1, q' l2)     where       (Vector2 vx vy)   = v       -- (px, py) is the vector/point after translating the circle s.t. it is centered at the@@ -152,23 +182,28 @@       lambda (|+-|)        = (-bb |+-| discr') / (2*aa)  -instance (Ord r, Floating r) => (LineSegment 2 p r) `IsIntersectableWith` (Circle q r) where+-- | A line segment may not intersect a circle, touch it, or intersect it+-- properly in one or two points.+type instance IntersectionOf (LineSegment 2 p r) (Circle q r) = [ NoIntersection+                                                                , Touching (Point 2 r)+                                                                , Point 2 r+                                                                , (Point 2 r, Point 2 r)+                                                                ] -  data Intersection (LineSegment 2 p r) (Circle q r) = NoLineSegmentCircleIntersection-                                                     | LineSegmentTouchesCircle    (Point 2 r)-                                                     | LineSegmentIntersectsCircle (Point 2 r)-                                                     | LineSegmentCrossesCircle    (Point 2 r) (Point 2 r)-                                                     deriving (Show,Eq) -  nonEmptyIntersection NoLineSegmentCircleIntersection = False-  nonEmptyIntersection _                               = True+instance (Ord r, Floating r) => (LineSegment 2 p r) `IsIntersectableWith` (Circle q r) where -  s `intersect` c = case supportingLine s `intersect` c of-    NoLineCircleIntersection    -> NoLineSegmentCircleIntersection-    LineTouchesCircle p         -> if p `onSegment` s then LineSegmentTouchesCircle p-                                                      else NoLineSegmentCircleIntersection-    LineCircleIntersection p q -> case (p `onSegment` s, q `onSegment` s) of-                                    (False,False) -> NoLineSegmentCircleIntersection-                                    (False,True)  -> LineSegmentIntersectsCircle q-                                    (True, False) -> LineSegmentIntersectsCircle p-                                    (True, True)  -> LineSegmentCrossesCircle p q+  nonEmptyIntersection = defaultNonEmptyIntersection++  s `intersect` c = match (supportingLine s `intersect` c) $+       (H $ \NoIntersection -> coRec NoIntersection)+    :& (H $ \(Touching p)   -> if p `onSegment` s then coRec $ Touching p+                                                 else  coRec   NoIntersection+       )+    :& (H $ \(p,q)          -> case (p `onSegment` s, q `onSegment` s) of+                                 (False,False) -> coRec NoIntersection+                                 (False,True)  -> coRec q+                                 (True, False) -> coRec p+                                 (True, True)  -> coRec (p,q)+       )+    :& RNil
+ src/Data/Geometry/Boundary.hs view
@@ -0,0 +1,22 @@+module Data.Geometry.Boundary where+++import Data.Geometry.Properties+import qualified Data.Foldable as F+import qualified Data.Traversable as T+import           Data.Geometry.Transformation++--------------------------------------------------------------------------------++-- | The boundary of a geometric object.+newtype Boundary g = Boundary g+                   deriving (Show,Eq,Ord,Read,IsTransformable)+++type instance NumType (Boundary g)   = NumType g+type instance Dimension (Boundary g) = Dimension g+++-- | Result of a query that asks if something is Inside a g, *on* the boundary+-- of the g, or outside.+data PointLocationResult = Inside | OnBoundary | Outside deriving (Show,Read,Eq)
src/Data/Geometry/Box.hs view
@@ -2,183 +2,55 @@ {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE DeriveFunctor  #-}-module Data.Geometry.Box(-                        -- * d-dimensional boxes-                          Box(..)--                        -- * Constructing bounding boxes-                        , IsBoxable(..)-                        , IsAlwaysTrueBoundingBox-                        , boundingBoxList--                        -- * Functions on d-dimensonal boxes-                        , minPoint, maxPoint-                        , extent, size, widthIn-                        , inBox--                        -- * Rectangles, aka 2-dimensional boxes-                        , Rectangle-                        , width , height+module Data.Geometry.Box( module Data.Geometry.Box.Internal+                        , topSide, leftSide, bottomSide, rightSide+                        , sides, sides'                         ) where -import           Control.Applicative-import qualified Data.Foldable as F-import           Data.Maybe(catMaybes, maybe)-import           Data.Semigroup -import           Control.Lens(Getter,to,(^.),view)-import           Data.Ext-import           Data.Geometry.Point-import qualified Data.Geometry.Interval as I-import           Data.Geometry.Properties-import           Data.Geometry.Transformation-import qualified Data.Geometry.Vector as V-import           Data.Geometry.Vector(Vector, Arity, Index',C(..))-import           Linear.Affine((.-.))--import qualified Data.Vector.Fixed                as FV+import           Control.Applicative+import qualified Data.Traversable as Tr+import           Data.Geometry.Box.Internal+import           Data.Geometry.LineSegment -import           GHC.TypeLits -------------------------------------------------------------------------------- -data Box d p r = Empty-               | Box { _minP :: Min (Point d r) :+ p-                     , _maxP :: Max (Point d r) :+ p-                     }--deriving instance (Show r, Show p, Arity d) => Show (Box d p r)-deriving instance (Eq r, Eq p, Arity d)     => Eq   (Box d p r)-deriving instance (Ord r, Ord p, Arity d)   => Ord  (Box d p r)--instance (Arity d, Ord r, Semigroup p) => Semigroup (Box d p r) where-  Empty       <> b             = b-  b           <> Empty         = b-  (Box mi ma) <> (Box mi' ma') = Box (mi <> mi') (ma <> ma')---instance (Arity d, Ord r, Semigroup p) => Monoid (Box d p r) where-  mempty = Empty-  b `mappend` b' = b <> b'---instance (Arity d, Ord r) => (Box d p r) `IsIntersectableWith` (Box d p r) where-  data Intersection (Box d p r) (Box d p r) = BoxBoxIntersection !(Box d () r)--  nonEmptyIntersection (BoxBoxIntersection Empty) = True-  nonEmptyIntersection _                          = False--  (Box a b) `intersect` (Box c d) = BoxBoxIntersection $ Box (mi :+ ()) (ma :+ ())-    where-      mi = (a^.core) `max` (c^.core)-      ma = (b^.core) `min` (d^.core)--deriving instance (Show r, Show p, Arity d) => Show (Intersection (Box d p r) (Box d p r))-deriving instance (Eq r, Eq p, Arity d)     => Eq   (Intersection (Box d p r) (Box d p r))-deriving instance (Ord r, Ord p, Arity d)   => Ord  (Intersection (Box d p r) (Box d p r))------- Note that this does not guarantee the box is still a proper box-instance PointFunctor (Box d p) where-  pmap f (Box mi ma) = Box (fmap f <$> mi) (fmap f <$> ma)--instance (Num r, AlwaysTruePFT d) => IsTransformable (Box d p r) where-  transformBy = transformPointFunctor---type instance Dimension (Box d p r) = d-type instance NumType   (Box d p r) = r--to'     :: (m -> Point d r) -> (Box d p r -> m :+ p) ->-           Getter (Box d p r) (Maybe (Point d r :+ p))-to' f g = to $ \x -> case x of-                  Empty -> Nothing-                  b     -> Just . fmap f . g $ b--minPoint :: Getter (Box d p r) (Maybe (Point d r :+ p))-minPoint = to' getMin _minP+topSide :: Num r => Rectangle p r -> LineSegment 2 p r+topSide = (\(l,r,_,_) -> ClosedLineSegment l r) . corners -maxPoint :: Getter (Box d p r) (Maybe (Point d r :+ p))-maxPoint = to' getMax _maxP+-- | Oriented from *left to right*+bottomSide :: Num r => Rectangle p r -> LineSegment 2 p r+bottomSide = (\(_,_,r,l) -> ClosedLineSegment l r) . corners --- | Check if a point lies a box ----- >>> origin `inBox` (boundingBoxList [point3 1 2 3, point3 10 20 30] :: Box 3 () Int)--- False--- >>> origin `inBox` (boundingBoxList [point3 (-1) (-2) (-3), point3 10 20 30] :: Box 3 () Int)--- True-inBox :: (Arity d, Ord r) => Point d r -> Box d p r -> Bool-p `inBox` b = maybe False f $ extent b-  where-    f = FV.and . FV.zipWith I.inInterval (toVec p)------ | Get a vector with the extent of the box in each dimension. Note that the--- resulting vector is 0 indexed whereas one would normally count dimensions--- starting at zero.------ >>> extent (boundingBoxList [point3 1 2 3, point3 10 20 30] :: Box 3 () Int)--- Just (Vector {_unV = fromList [Interval {_start = 1 :+ (), _end = 10 :+ ()},Interval {_start = 2 :+ (), _end = 20 :+ ()},Interval {_start = 3 :+ (), _end = 30 :+ ()}]})-extent                                 :: (Arity d)-                                       => Box d p r -> Maybe (Vector d (I.Interval p r))-extent Empty                           = Nothing-extent (Box (Min a :+ p) (Max b :+ q)) = Just $ FV.zipWith f (toVec a) (toVec b)-  where-    f x y = I.Interval (x :+ p) (y :+ q)---- | Get the size of the box (in all dimensions). Note that the resulting vector is 0 indexed--- whereas one would normally count dimensions starting at zero.------ >>> size (boundingBoxList [origin, point3 1 2 3] :: Box 3 () Int)--- Vector {_unV = fromList [1,2,3]}-size :: (Arity d, Num r) => Box d p r -> Vector d r-size = maybe (pure 0) (fmap I.width) . extent---- | Given a dimension, get the width of the box in that dimension. Dimensions are 1 indexed.------ >>> widthIn (C :: C 1) (boundingBoxList [origin, point3 1 2 3] :: Box 3 () Int)--- 1--- >>> widthIn (C :: C 3) (boundingBoxList [origin, point3 1 2 3] :: Box 3 () Int)--- 3-widthIn   :: forall proxy p i d r. (Arity d, Num r, Index' (i-1) d) => proxy i -> Box d p r -> r-widthIn _ = view (V.element (C :: C (i - 1))) . size--------------------------------------------type Rectangle = Box 2---- >>> width (boundingBoxList [origin, point2 1 2] :: Rectangle () Int)--- 1--- >>> width (boundingBoxList [origin] :: Rectangle () Int)--- 0-width :: Num r => Rectangle p r -> r-width = widthIn (C :: C 1)+leftSide  :: Num r => Rectangle p r -> LineSegment 2 p r+leftSide = (\(t,_,_,b) -> ClosedLineSegment b t) . corners --- >>> height (boundingBoxList [origin, point2 1 2] :: Rectangle () Int)--- 2--- >>> height (boundingBoxList [origin] :: Rectangle () Int)--- 0-height :: Num r => Rectangle p r -> r-height = widthIn (C :: C 2)+-- | The right side, oriented from *bottom* to top+rightSide :: Num r => Rectangle p r -> LineSegment 2 p r+rightSide = (\(_,t,b,_) -> ClosedLineSegment b t) . corners  -----------------------------------------------------------------------------------class IsBoxable g where-  boundingBox :: (Monoid p, Semigroup p, Ord (NumType g))-              => g -> Box (Dimension g) p (NumType g)--type IsAlwaysTrueBoundingBox g p = (Semigroup p, Arity (Dimension g))+-- | The sides of the rectangle, in order (Top, Right, Bottom, Left). The sides+-- themselves are also oriented in clockwise order. If, you want them in the+-- same order as the functions `topSide`, `bottomSide`, `leftSide`, and+-- `rightSide`, use `sides'` instead.+sides :: Num r => Rectangle p r -> ( LineSegment 2 p r+                                   , LineSegment 2 p r+                                   , LineSegment 2 p r+                                   , LineSegment 2 p r+                                   )+sides = (\(t,r,b,l) -> (t,flipSegment r,flipSegment b,l)) . sides'  -boundingBoxList :: (IsBoxable g, Monoid p, F.Foldable c, Ord (NumType g)-                   , IsAlwaysTrueBoundingBox g p-                   ) => c g -> Box (Dimension g) p (NumType g)-boundingBoxList = F.foldMap boundingBox--------------------------------------------instance IsBoxable (Point d r) where-  boundingBox p = Box (Min p :+ mempty) (Max p :+ mempty)+-- | The sides of the rectangle. The order of the segments is (Top, Right,+-- Bottom, Left).  Note that the segments themselves, are oriented as described+-- by the functions topSide, bottomSide, leftSide, rightSide (basically: from+-- left to right, and from bottom to top). If you want the segments oriented+-- along the boundary of the rectangle, use the `sides` function instead.+sides'   :: Num r => Rectangle p r -> ( LineSegment 2 p r+                                      , LineSegment 2 p r+                                      , LineSegment 2 p r+                                      , LineSegment 2 p r+                                      )+sides' r = (topSide r, rightSide r, bottomSide r, leftSide r)
+ src/Data/Geometry/Box/Internal.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE DeriveFunctor  #-}+module Data.Geometry.Box.Internal where++import           Control.Applicative+import           Control.Lens+import           Data.Bifunctor+import           Data.Ext+import qualified Data.Semigroup.Foldable as F+import qualified Data.Range as R+import           Data.Geometry.Point+import           Data.Geometry.Properties+import           Data.Geometry.Transformation+import qualified Data.Geometry.Vector as V+import qualified Data.List.NonEmpty as NE+import           Data.Geometry.Vector(Vector, Arity, Index',C(..))+import           Data.Semigroup++import qualified Data.Vector.Fixed                as FV++import           GHC.TypeLits++--------------------------------------------------------------------------------+-- * d-dimensional boxes++data Box d p r = Box { _minP :: Min (Point d r) :+ p+                     , _maxP :: Max (Point d r) :+ p+                     }+makeLenses ''Box++-- | Given the point with the lowest coordinates and the point with highest+-- coordinates, create a box.+fromCornerPoints          :: Point d r :+ p -> Point d r :+ p -> Box d p r+fromCornerPoints low high = Box (low&core %~ Min) (high&core %~ Max)+++deriving instance (Show r, Show p, Arity d) => Show (Box d p r)+deriving instance (Eq r, Eq p, Arity d)     => Eq   (Box d p r)+deriving instance (Ord r, Ord p, Arity d)   => Ord  (Box d p r)++instance (Arity d, Ord r, Semigroup p) => Semigroup (Box d p r) where+  (Box mi ma) <> (Box mi' ma') = Box (mi <> mi') (ma <> ma')++type instance IntersectionOf (Box d p r) (Box d q r) = '[ NoIntersection, Box d () r]++-- In principle this should also just work for Boxes in higher dimensions. It is just+-- that we need a better way to compute their corners+instance (Num r, Ord r) => (Rectangle p r) `IsIntersectableWith` (Rectangle p r) where++  nonEmptyIntersection = defaultNonEmptyIntersection++  box@(Box a b) `intersect` box'@(Box c d)+      |    box  `containsACornerOf` box'+        || box' `containsACornerOf` box = coRec $ Box (mi :+ ()) (ma :+ ())+      | otherwise                       = coRec NoIntersection+    where++      mi = (a^.core) `max` (c^.core)+      ma = (b^.core) `min` (d^.core)++      bx `containsACornerOf` bx' = let (a',b',c',d') = corners bx'+                                   in any (\(p :+ _) -> p `inBox` bx) [a',b',c',d']+++instance PointFunctor (Box d p) where+  pmap f (Box mi ma) = Box (first (fmap f) mi) (first (fmap f) ma)+++instance (Num r, AlwaysTruePFT d) => IsTransformable (Box d p r) where+  -- Note that this does not guarantee the box is still a proper box Only use+  -- this to do translations and scalings. Other transformations may produce+  -- unexpected results.+  transformBy = transformPointFunctor+++type instance Dimension (Box d p r) = d+type instance NumType   (Box d p r) = r++--------------------------------------------------------------------------------0+-- * Functions on d-dimensonal boxes++minPoint :: Box d p r -> Point d r :+ p+minPoint b = let (Min p :+ e) = b^.minP in p :+ e++maxPoint :: Box d p r -> Point d r :+ p+maxPoint b = let (Max p :+ e) = b^.maxP in p :+ e++-- | Check if a point lies a box+--+-- >>> origin `inBox` (boundingBoxList' [point3 1 2 3, point3 10 20 30] :: Box 3 () Int)+-- False+-- >>> origin `inBox` (boundingBoxList' [point3 (-1) (-2) (-3), point3 10 20 30] :: Box 3 () Int)+-- True+inBox :: (Arity d, Ord r) => Point d r -> Box d p r -> Bool+p `inBox` b = FV.and . FV.zipWith R.inRange (toVec p) . extent $ b++-- | Get a vector with the extent of the box in each dimension. Note that the+-- resulting vector is 0 indexed whereas one would normally count dimensions+-- starting at zero.+--+-- >>> extent (boundingBoxList' [point3 1 2 3, point3 10 20 30] :: Box 3 () Int)+-- Vector3 [Range {_lower = Closed 1, _upper = Closed 10},Range {_lower = Closed 2, _upper = Closed 20},Range {_lower = Closed 3, _upper = Closed 30}]+extent                                 :: (Arity d)+                                       => Box d p r -> Vector d (R.Range r)+extent (Box (Min a :+ _) (Max b :+ _)) = FV.zipWith R.ClosedRange (toVec a) (toVec b)++-- | Get the size of the box (in all dimensions). Note that the resulting vector is 0 indexed+-- whereas one would normally count dimensions starting at zero.+--+-- >>> size (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)+-- Vector3 [1,2,3]+size :: (Arity d, Num r) => Box d p r -> Vector d r+size = fmap R.width . extent++-- | Given a dimension, get the width of the box in that dimension. Dimensions are 1 indexed.+--+-- >>> widthIn (C :: C 1) (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)+-- 1+-- >>> widthIn (C :: C 3) (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)+-- 3+widthIn   :: forall proxy p i d r. (Arity d, Num r, Index' (i-1) d) => proxy i -> Box d p r -> r+widthIn _ = view (V.element (C :: C (i - 1))) . size+++-- | Same as 'widthIn' but with a runtime int instead of a static dimension.+--+-- >>> widthIn' 1 (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)+-- Just 1+-- >>> widthIn' 3 (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)+-- Just 3+-- >>> widthIn' 10 (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)+-- Nothing+widthIn'   :: (Arity d, KnownNat d, Num r) => Int -> Box d p r -> Maybe r+widthIn' i = preview (V.element' (i-1)) . size+++----------------------------------------+-- * Rectangles, aka 2-dimensional boxes++type Rectangle = Box 2++-- >>> width (boundingBoxList' [origin, point2 1 2] :: Rectangle () Int)+-- 1+-- >>> width (boundingBoxList' [origin] :: Rectangle () Int)+-- 0+width :: Num r => Rectangle p r -> r+width = widthIn (C :: C 1)++-- >>> height (boundingBoxList' [origin, point2 1 2] :: Rectangle () Int)+-- 2+-- >>> height (boundingBoxList' [origin] :: Rectangle () Int)+-- 0+height :: Num r => Rectangle p r -> r+height = widthIn (C :: C 2)+++-- | Get the corners of a rectangle, the order is:+-- (TopLeft, TopRight, BottomRight, BottomLeft).+-- The extra values in the Top points are taken from the Top point,+-- the extra values in the Bottom points are taken from the Bottom point+corners :: Num r => Rectangle p r -> ( Point 2 r :+ p+                                     , Point 2 r :+ p+                                     , Point 2 r :+ p+                                     , Point 2 r :+ p+                                     )+corners r     = let w = width r+                    p = (_maxP r)&core %~ getMax+                    q = (_minP r)&core %~ getMin+                in ( p&core.xCoord %~ (subtract w)+                   , p+                   , q&core.xCoord %~ (+ w)+                   , q+                   )++--------------------------------------------------------------------------------+-- * Constructing bounding boxes++class IsBoxable g where+  boundingBox :: (Monoid p, Semigroup p, Ord (NumType g))+              => g -> Box (Dimension g) p (NumType g)++type IsAlwaysTrueBoundingBox g p = (Semigroup p, Arity (Dimension g))++++boundingBoxList :: (IsBoxable g, Monoid p, F.Foldable1 c, Ord (NumType g)+                    , IsAlwaysTrueBoundingBox g p+                    ) => c g -> Box (Dimension g) p (NumType g)+boundingBoxList = F.foldMap1 boundingBox+++-- | Unsafe version of boundingBoxList, that does not check if the list is non-empty+boundingBoxList' :: (IsBoxable g, Monoid p, Ord (NumType g)+                    , IsAlwaysTrueBoundingBox g p+                    ) => [g] -> Box (Dimension g) p (NumType g)+boundingBoxList' = boundingBoxList . NE.fromList++----------------------------------------++instance IsBoxable (Point d r) where+  boundingBox p = Box (Min p :+ mempty) (Max p :+ mempty)
+ src/Data/Geometry/Duality.hs view
@@ -0,0 +1,21 @@+module Data.Geometry.Duality where++import Control.Applicative+import Data.Geometry.Line+import Data.Geometry.Point+import Data.Maybe(fromJust)+--------------------------------------------------------------------------------+-- * Standard Point-Line duality in R^2++-- | Maps a line point (px,py) to a line (y=px*x - py)+dualLine              :: Num r => Point 2 r -> Line 2 r+dualLine (Point2 x y) = fromLinearFunction x (-y)++-- | Returns Nothing if the input line is vertical+-- Maps a line l: y = ax + b to a point (a,-b)+dualPoint   :: (Fractional r, Eq r) => Line 2 r -> Maybe (Point 2 r)+dualPoint l = (\(a,b) -> point2 a (-b)) <$> toLinearFunction l++-- | Pre: the input line is not vertical+dualPoint' :: (Fractional r, Eq r) => Line 2 r -> Point 2 r+dualPoint' = fromJust . dualPoint
src/Data/Geometry/HalfLine.hs view
@@ -1,22 +1,27 @@ {-# LANGUAGE TemplateHaskell  #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor  #-} {-# LANGUAGE UndecidableInstances #-} module Data.Geometry.HalfLine where  import           Control.Applicative import           Control.Lens import           Data.Ext+import qualified Data.Foldable as F import           Data.Geometry.Interval+import           Data.Geometry.Line+import           Data.Geometry.LineSegment import           Data.Geometry.Point import           Data.Geometry.Properties+import           Data.Geometry.SubLine import           Data.Geometry.Transformation import           Data.Geometry.Vector-import           Data.Geometry.Line-import           Data.Geometry.LineSegment-import           Linear.Vector((*^))+import           Data.Range+import qualified Data.Traversable as T+import           Data.UnBounded+import           Frames.CoRec import           Linear.Affine(Affine(..),distanceA)+import           Linear.Vector((*^)) + -------------------------------------------------------------------------------- -- * d-dimensional Half-Lines @@ -29,6 +34,8 @@ deriving instance (Show r, Arity d) => Show    (HalfLine d r) deriving instance (Eq r, Arity d)   => Eq      (HalfLine d r) deriving instance Arity d           => Functor (HalfLine d)+deriving instance Arity d           => F.Foldable    (HalfLine d)+deriving instance Arity d           => T.Traversable (HalfLine d)  type instance Dimension (HalfLine d r) = d type instance NumType   (HalfLine d r) = r@@ -47,75 +54,117 @@   transformBy t = toHalfLine . transformPointFunctor t . toLineSegment'     where       toLineSegment' :: (Num r, Arity d) => HalfLine d r -> LineSegment d () r-      toLineSegment' (HalfLine p v) = LineSegment (p :+ ()) ((p .+^ v) :+ ())+      toLineSegment' (HalfLine p v) = ClosedLineSegment (p :+ ()) ((p .+^ v) :+ ()) -instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (Line 2 r) where-  data Intersection (HalfLine 2 r) (Line 2 r) = NoHalfLineLineIntersection-                                              | HalfLineLineIntersection !(Point 2 r)-                                              | HalfLineLineOverlap      !(HalfLine 2 r)-                                              deriving (Show,Eq)+-------------------------------------------------------------------------------- -  nonEmptyIntersection NoHalfLineLineIntersection = False-  nonEmptyIntersection _                          = True+halfLineToSubLine                :: (Arity d, Num r)+                                 => HalfLine d r -> SubLine d () (UnBounded r)+halfLineToSubLine (HalfLine p v) = let l = fmap Val $ Line p v+                                   in SubLine l (Interval (Closed $ ext (Val 0))+                                                          (Open   $ ext MaxInfinity)) -  hl `intersect` l = case supportingLine hl `intersect` l of-    SameLine _             -> HalfLineLineOverlap hl-    LineLineIntersection p -> if p `onHalfLine` hl then HalfLineLineIntersection p-                                                   else NoHalfLineLineIntersection-    ParallelLines          -> NoHalfLineLineIntersection +fromSubLine               :: (Num r, Arity d) => SubLine d p (UnBounded r) -> Maybe (HalfLine d r)+fromSubLine (SubLine l' i) = case (i^.start.core, i^.end.core) of+                               (Val x, MaxInfinity) -> f x+                               (MinInfinity, Val x) -> f x+                               _                    -> Nothing+  where+    f x = (\l@(Line _ v) -> HalfLine (pointAt x l) v)+       <$> T.mapM unBoundedToMaybe l' -instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (HalfLine 2 r) where-  data Intersection (HalfLine 2 r) (HalfLine 2 r) = NoHalfLineHalfLineIntersection-                                                  | HLHLIntersectInPoint    !(Point 2 r)-                                                  | HLHLIntersectInSegment  !(LineSegment 2 () r)-                                                  | HLHLIntersectInHalfLine !(HalfLine 2 r)-                                                  deriving (Show,Eq) -  nonEmptyIntersection NoHalfLineHalfLineIntersection = False-  nonEmptyIntersection _                              = True -  hl' `intersect` hl = case supportingLine hl' `intersect` supportingLine hl of-    ParallelLines          -> NoHalfLineHalfLineIntersection-    LineLineIntersection p -> if p `onHalfLine` hl' && p `onHalfLine` hl then HLHLIntersectInPoint p-                                                                         else NoHalfLineHalfLineIntersection-    SameLine _             -> let p   = _startPoint hl'-                                  q   = _startPoint hl-                                  seg = LineSegment (p :+ ()) (q :+ ())-                              in case (p `onHalfLine` hl, q `onHalfLine` hl') of-                                   (False,False) -> NoHalfLineHalfLineIntersection-                                   (False,True)  -> HLHLIntersectInHalfLine hl-                                   (True, False) -> HLHLIntersectInHalfLine hl'-                                   (True, True)  -> if hl == hl' then HLHLIntersectInHalfLine hl-                                                                 else HLHLIntersectInSegment seg +type instance IntersectionOf (HalfLine 2 r) (Line 2 r) = [ NoIntersection+                                                         , Point 2 r+                                                         , HalfLine 2 r+                                                         ] +type instance IntersectionOf (HalfLine 2 r) (HalfLine 2 r) = [ NoIntersection+                                                             , Point 2 r+                                                             , LineSegment 2 () r+                                                             , HalfLine 2 r+                                                             ] -instance (Ord r, Fractional r) => (LineSegment 2 p r) `IsIntersectableWith` (HalfLine 2 r) where-  data Intersection (LineSegment 2 p r) (HalfLine 2 r) = NoSegmentHalfLineIntersection-                                                       | SegmentHalfLineIntersection !(Point 2 r)-                                                       | SegmentOnHalfLine           !(LineSegment 2 () r)+type instance IntersectionOf (HalfLine 2 r) (LineSegment 2 p r) = [ NoIntersection+                                                                  , Point 2 r+                                                                  , LineSegment 2 () r+                                                                  ] -  nonEmptyIntersection NoSegmentHalfLineIntersection = False-  nonEmptyIntersection _                             = True -  s `intersect` hl = case supportingLine s `intersect` supportingLine hl of-    ParallelLines          -> NoSegmentHalfLineIntersection-    LineLineIntersection p -> if p `onSegment` s && p `onHalfLine` hl then SegmentHalfLineIntersection p-                                                                      else NoSegmentHalfLineIntersection-    SameLine _             -> let p = s  ^.start.core-                                  q = s  ^.end.core-                                  r = hl ^.start.core-                                  seg a b = LineSegment (a :+ ()) (b :+ ())-                              in case (p `onHalfLine` hl, q `onHalfLine` hl) of-                                   (False, False)   -> NoSegmentHalfLineIntersection-                                   (False, True)    -> SegmentOnHalfLine $ seg r q-                                   (True,  False)   -> SegmentOnHalfLine $ seg p r-                                   (True,  True)    -> SegmentOnHalfLine $ seg p q+-- instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (Line 2 r) where+  -- hl `intersect` l = match (halfLineToSubLine hl, l)  +-- instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (Line 2 r) where+--   data Intersection (HalfLine 2 r) (Line 2 r) = NoHalfLineLineIntersection+--                                               | HalfLineLineIntersection !(Point 2 r)+--                                               | HalfLineLineOverlap      !(HalfLine 2 r)+--                                               deriving (Show,Eq) +--   nonEmptyIntersection NoHalfLineLineIntersection = False+--   nonEmptyIntersection _                          = True +--   hl `intersect` l = case supportingLine hl `intersect` l of+--     SameLine _             -> HalfLineLineOverlap hl+--     LineLineIntersection p -> if p `onHalfLine` hl then HalfLineLineIntersection p+--                                                    else NoHalfLineLineIntersection+--     ParallelLines          -> NoHalfLineLineIntersection+++-- instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (HalfLine 2 r) where+--   data Intersection (HalfLine 2 r) (HalfLine 2 r) = NoHalfLineHalfLineIntersection+--                                                   | HLHLIntersectInPoint    !(Point 2 r)+--                                                   | HLHLIntersectInSegment  !(LineSegment 2 () r)+--                                                   | HLHLIntersectInHalfLine !(HalfLine 2 r)+--                                                   deriving (Show,Eq)++--   nonEmptyIntersection NoHalfLineHalfLineIntersection = False+--   nonEmptyIntersection _                              = True++--   hl' `intersect` hl = case supportingLine hl' `intersect` supportingLine hl of+--     ParallelLines          -> NoHalfLineHalfLineIntersection+--     LineLineIntersection p -> if p `onHalfLine` hl' && p `onHalfLine` hl then HLHLIntersectInPoint p+--                                                                          else NoHalfLineHalfLineIntersection+--     SameLine _             -> let p   = _startPoint hl'+--                                   q   = _startPoint hl+--                                   seg = LineSegment (p :+ ()) (q :+ ())+--                               in case (p `onHalfLine` hl, q `onHalfLine` hl') of+--                                    (False,False) -> NoHalfLineHalfLineIntersection+--                                    (False,True)  -> HLHLIntersectInHalfLine hl+--                                    (True, False) -> HLHLIntersectInHalfLine hl'+--                                    (True, True)  -> if hl == hl' then HLHLIntersectInHalfLine hl+--                                                                  else HLHLIntersectInSegment seg++++-- instance (Ord r, Fractional r) => (LineSegment 2 p r) `IsIntersectableWith` (HalfLine 2 r) where+--   data Intersection (LineSegment 2 p r) (HalfLine 2 r) = NoSegmentHalfLineIntersection+--                                                        | SegmentHalfLineIntersection !(Point 2 r)+--                                                        | SegmentOnHalfLine           !(LineSegment 2 () r)++--   nonEmptyIntersection NoSegmentHalfLineIntersection = False+--   nonEmptyIntersection _                             = True++--   s `intersect` hl = case supportingLine s `intersect` supportingLine hl of+--     ParallelLines          -> NoSegmentHalfLineIntersection+--     LineLineIntersection p -> if p `onSegment` s && p `onHalfLine` hl then SegmentHalfLineIntersection p+--                                                                       else NoSegmentHalfLineIntersection+--     SameLine _             -> let p = s  ^.start.core+--                                   q = s  ^.end.core+--                                   r = hl ^.start.core+--                                   seg a b = LineSegment (a :+ ()) (b :+ ())+--                               in case (p `onHalfLine` hl, q `onHalfLine` hl) of+--                                    (False, False)   -> NoSegmentHalfLineIntersection+--                                    (False, True)    -> SegmentOnHalfLine $ seg r q+--                                    (True,  False)   -> SegmentOnHalfLine $ seg p r+--                                    (True,  True)    -> SegmentOnHalfLine $ seg p q++++ -- | Test if a point lies on a half-line onHalfLine :: (Ord r, Fractional r, Arity d) => Point d r -> HalfLine d r -> Bool p `onHalfLine` (HalfLine q v) = maybe False (>= 0) $ scalarMultiple (p .-. q) v@@ -125,7 +174,8 @@   -- | Transform a LineSegment into a half-line, by forgetting the second endpoint.-toHalfLine                     :: (Num r, Arity d) => LineSegment d p r -> HalfLine d r-toHalfLine (LineSegment p' q') = let p = p' ^.core-                                     q = q' ^.core-                                 in HalfLine p (q .-. p)+-- Note that this also forgets about if the starting point was open or closed.+toHalfLine   :: (Num r, Arity d) => LineSegment d p r -> HalfLine d r+toHalfLine s = let p = s^.start.core+                   q = s^.end.core+               in HalfLine p (q .-. p)
src/Data/Geometry/Interval.hs view
@@ -1,50 +1,78 @@ {-# LANGUAGE TemplateHaskell  #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor  #-}-module Data.Geometry.Interval(-                             -- * 1 dimensional Intervals-                               Interval(..)-                             , Intersection(..)+{-# LANGUAGE DeriveFunctor #-}+module Data.Geometry.Interval-- (+                             -- -- * 1 dimensional Intervals+                             --   Interval(..)+                             -- , Intersection(..) -                             -- * querying the start and end of intervals-                             , HasStart(..), HasEnd(..)-                             -- * Working with intervals-                             , width-                             , inInterval-                             ) where+                             -- -- * querying the start and end of intervals+                             -- , HasStart(..), HasEnd(..)+                             -- -- * Working with intervals+                             -- , width+                             -- , inInterval+                             -- )+       where -import           Control.Lens+import           Control.Applicative+import           Control.Lens(makeLenses, (^.),(%~),(&), Lens')+import           Data.Bitraversable import           Data.Ext+import qualified Data.Foldable as F import           Data.Geometry.Properties+import           Data.Range+import           Data.Semigroup+import qualified Data.Traversable as T+import           Data.Vinyl+import           Frames.CoRec+import           Data.Bifunctor  -------------------------------------------------------------------------------- -data EndPointType = Open | Closed deriving (Show, Eq, Ord)+-- | An Interval is essentially a 'Data.Range' but with possible payload+newtype Interval a r = GInterval { _unInterval :: Range (r :+ a) }+                     deriving (Eq)+makeLenses ''Interval -newtype EndPoint (t :: EndPointType) a = EndPoint a deriving (Show,Read,Eq,Ord)+instance (Show a, Show r) => Show (Interval a r) where+  show ~(Interval l u) = concat [ "Interval (", show l, ") (", show u,")"] +instance Functor (Interval a) where+  fmap = T.fmapDefault -data Range l u a = Range { _lower :: EndPoint l a-                         , _upper :: EndPoint u a-                         } deriving (Show,Read,Eq,Ord)+instance F.Foldable (Interval a) where+  foldMap = T.foldMapDefault +instance T.Traversable (Interval a) where+  traverse f (GInterval r) = GInterval <$> T.traverse f' r+    where+      f' = bitraverse f pure --- newtype GLineSegment s t d p r = GLineSegment (GInterval s t p (Point d r))+instance Bifunctor Interval where+  bimap f g (GInterval r) = GInterval $ fmap (bimap g f) r --- newtype GInterval s t a r = GInterval (Range s t (r :+ a)) --- data CurveSegment c s t r = SubLine { _support :: c , _range :: Range s t r } +-- | Test if a value lies in an interval. Note that the difference between+--  inInterval and inRange is that the extra value is *not* used in the+--  comparison with inInterval, whereas it is in inRange.+inInterval       :: Ord r => r -> Interval a r -> Bool+x `inInterval` r = x `inRange` (fmap (^.core) $ r^.unInterval )  ---------------------------------------------------------------------------------+pattern OpenInterval       :: (r :+ a) -> (r :+ a) -> Interval a r+pattern OpenInterval   l u = GInterval (OpenRange   l u) -data Interval a r = Interval { _start :: r :+ a-                             , _end   :: r :+ a-                             }-                  deriving (Show,Read,Eq,Functor)+pattern ClosedInterval     :: (r :+ a) -> (r :+ a) -> Interval a r+pattern ClosedInterval l u = GInterval (ClosedRange l u)  +pattern Interval     :: EndPoint (r :+ a) -> EndPoint (r :+ a) -> Interval a r+pattern Interval l u = GInterval (Range l u)+++--------------------------------------------------------------------------------+ class HasStart t where   type StartCore t   type StartExtra t@@ -53,7 +81,7 @@ instance HasStart (Interval a r) where   type StartCore (Interval a r) = r   type StartExtra (Interval a r) = a-  start = lens _start (\(Interval _ e) s -> Interval s e)+  start = unInterval.lower.unEndPoint  class HasEnd t where   type EndCore t@@ -63,61 +91,30 @@ instance HasEnd (Interval a r) where   type EndCore (Interval a r) = r   type EndExtra (Interval a r) = a-  end = lens _end (\(Interval s _) e -> Interval s e)----- | When comparing intervals, compare them lexicographically on--- (start^.core,end^.core,start^.extra,end^.extra)-instance (Ord a, Ord r) => Ord (Interval a r) where-  (Interval (s :+ a) (t :+ b)) `compare` (Interval (p :+ c) (q :+ d)) =-    (s,t,a,b) `compare` (p,q,c,d)+  end = unInterval.upper.unEndPoint  type instance Dimension (Interval a r) = 1 type instance NumType   (Interval a r) = r  -instance Ord r => IsIntersectableWith (Interval a r) (Interval a r) where--  data Intersection (Interval a r) (Interval a r) = IntervalIntersection (Interval a r)-                                                  | NoOverlap-                                                  deriving (Show,Read,Eq,Ord)--  nonEmptyIntersection NoOverlap = False-  nonEmptyIntersection _         = True--  (Interval a b) `intersect` (Interval c d)-      | s^.core <= t^.core = IntervalIntersection $ Interval s t-      | otherwise          = NoOverlap-    where--      s = a `maxOnCore` c-      t = b `minOnCore` d-+type instance IntersectionOf (Interval a r) (Interval a r) = [NoIntersection, Interval a r] -instance Ord r => IsUnionableWith (Interval a r) (Interval a r) where+instance Ord r => (Interval a r) `IsIntersectableWith` (Interval a r) where -  data Union (Interval a r) (Interval a r) = DisjointIntervals (Interval a r) (Interval a r)-                                           | OneInterval       (Interval a r)-                                           deriving (Show,Read,Eq,Ord)+  nonEmptyIntersection = defaultNonEmptyIntersection -  i@(Interval a b) `union` j@(Interval c d)-      | i `intersects` j = OneInterval $ Interval s t-      | otherwise        = DisjointIntervals i j+  (GInterval r) `intersect` (GInterval s) = match (r' `intersect` s') $+         (H $ \NoIntersection -> coRec NoIntersection)+      :& (H $ \(Range l u)    -> coRec . GInterval $ Range (l&unEndPoint %~ g)+                                                           (u&unEndPoint %~ g) )+      :& RNil     where-      s = a `minOnCore` c-      t = b `maxOnCore` d---maxOnCore :: Ord c => c :+ e -> c :+ e -> c :+ e-l@(lc :+ _) `maxOnCore` r@(rc :+ _) = if lc >= rc then l else r+      f x = Arg (x^.core) x+      r' = fmap f r+      s' = fmap f s -minOnCore :: Ord c => c :+ e -> c :+ e -> c :+ e-l@(lc :+ _) `minOnCore` r@(rc :+ _) = if lc <= rc then l else r+      g (Arg _ x) = x  --- | Get the width of the interval-width   :: Num r => Interval a r -> r-width i = i^.end.core - i^.start.core--inInterval       :: Ord r => r -> Interval a r -> Bool-x `inInterval` i = i^.start.core <= x && x <= i^.end.core+shiftLeft'   :: Num r => r -> Interval a r -> Interval a r+shiftLeft' x = fmap (subtract x)
src/Data/Geometry/Ipe.hs view
@@ -1,8 +1,14 @@-module Data.Geometry.Ipe( module I+module Data.Geometry.Ipe( module Data.Geometry.Ipe.Types+                        , module Data.Geometry.Ipe.Writer+                        , module Data.Geometry.Ipe.Reader+                        , module Data.Geometry.Ipe.IpeOut+                        , module Data.Geometry.Ipe.FromIpe+                        , module Data.Geometry.Ipe.Attributes                         ) where -import qualified Data.Geometry.Ipe.Types as I-import qualified Data.Geometry.Ipe.Writer as I-import qualified Data.Geometry.Ipe.Reader as I-import qualified Data.Geometry.Ipe.Relations as I-import qualified Data.Geometry.Ipe.Attributes as I+import Data.Geometry.Ipe.Types+import Data.Geometry.Ipe.Writer+import Data.Geometry.Ipe.Reader+import Data.Geometry.Ipe.IpeOut+import Data.Geometry.Ipe.FromIpe+import Data.Geometry.Ipe.Attributes
src/Data/Geometry/Ipe/Attributes.hs view
@@ -1,13 +1,145 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Geometry.Ipe.Attributes where -import           Control.Lens-import           Data.Text(Text)-import           Data.Geometry.Transformation(Matrix)+import           Control.Applicative hiding (Const)+import           Control.Lens hiding (rmap, Const)+import qualified Data.Foldable as F+import qualified Data.Geometry.Transformation as Transf+import           Data.Semigroup import           Data.Singletons import           Data.Singletons.TH+import           Data.Text(Text)+import qualified Data.Traversable as T+import           Data.Vinyl+import           Data.Vinyl.Functor+import           Data.Vinyl.TypeLevel+import           GHC.Exts +-------------------------------------------------------------------------------- ++data AttributeUniverse = -- common+                         Layer | Matrix | Pin | Transformations+                       -- symbol+                       | Stroke | Fill | Pen | Size+                       -- Path+                       | Dash | LineCap | LineJoin+                       | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient+                       -- Group+                       | Clip+                       -- Extra+--                       | X Text+                       deriving (Show,Read,Eq)+++genSingletons [ ''AttributeUniverse ]+++type CommonAttributes = [ Layer, Matrix, Pin, Transformations ]+++type TextLabelAttributes = CommonAttributes+type MiniPageAttributes  = CommonAttributes++type ImageAttributes     = CommonAttributes+++type SymbolAttributes = CommonAttributes +++                          [Stroke, Fill, Pen, Size]++type PathAttributes = CommonAttributes +++                      [ Stroke, Fill, Dash, Pen, LineCap, LineJoin+                      , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient+                      ]++type GroupAttributes = CommonAttributes ++ '[ 'Clip]+++-- | Attr implements the mapping from labels to types as specified by the+-- (symbol representing) the type family 'f'+newtype Attr (f :: TyFun u * -> *) -- Symbol repr. the Type family mapping+                                   -- Labels in universe u to concrete types+             (label :: u) = GAttr { _getAttr :: Maybe (Apply f label) }+                          deriving (Show,Read,Eq,Ord)++makeLenses ''Attr++pattern Attr x = GAttr (Just x)+pattern NoAttr = GAttr Nothing++-- | Give pref. to the *RIGHT*+instance Monoid (Attr f l) where+  mempty                 = NoAttr+  _ `mappend` b@(Attr x) = b+  a `mappend` _          = a+++newtype Attributes (f :: TyFun u * -> *) (ats :: [u]) =+  Attrs { _unAttrs :: Rec (Attr f) ats }++makeLenses ''Attributes+++-- type All' c i = RecAll (Attr (IpeObjectSymbolF i)) (IpeObjectAttrF i) c++-- deriving instance All' Show atsShow (Attributes f ats)++deriving instance (RecAll (Attr f) ats Show) => Show (Attributes f ats)++instance (RecAll (Attr f) ats Eq)   => Eq   (Attributes f ats) where+  (Attrs a) == (Attrs b) = and . recordToList+                         . zipRecsWith (\x (Compose (Dict y)) -> Const $ x == y) a+                         . (reifyConstraint (Proxy :: Proxy Eq)) $ b++instance RecApplicative ats => Monoid (Attributes f ats) where+  mempty        = Attrs $ rpure mempty+  a `mappend` b = a <> b++instance Semigroup (Attributes f ats) where+  (Attrs as) <> (Attrs bs) = Attrs $ zipRecsWith mappend as bs++++zipRecsWith                       :: (forall a. f a -> g a -> h a)+                                  -> Rec f as -> Rec g as -> Rec h as+zipRecsWith f RNil      _         = RNil+zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss++attrLens   :: (at ∈ ats) => proxy at -> Lens' (Attributes f ats) (Maybe (Apply f at))+attrLens p = unAttrs.rlens p.getAttr++lookupAttr   :: (at ∈ ats) => proxy at -> Attributes f ats -> Maybe (Apply f at)+lookupAttr p = view (attrLens p)++setAttr               :: forall proxy at ats f. (at ∈ ats)+                      => proxy at -> Apply f at -> Attributes f ats -> Attributes f ats+setAttr p a (Attrs r) = Attrs $ rput (Attr a :: Attr f at) r+++-- | gets and removes the attribute from Attributes+takeAttr       :: forall proxy at ats f. (at ∈ ats)+               => proxy at -> Attributes f ats -> ( Maybe (Apply f at)+                                                  , Attributes f ats )+takeAttr p ats = (lookupAttr p ats, ats&attrLens p .~ Nothing)+++-- | unsets/Removes an attribute+unSetAttr   :: forall proxy at ats f. (at ∈ ats)+            => proxy at -> Attributes f ats -> Attributes f ats+unSetAttr p = snd . takeAttr p+++attr     :: (at ∈ ats, RecApplicative ats)+         => proxy at -> Apply f at -> Attributes f ats+attr p x = setAttr p x mempty++++ -------------------------------------------------------------------------------- -- | Common Attributes @@ -15,22 +147,9 @@ -- pairs. The key is some name. Which attributes an object can have depends on -- the type of the object. However, all ipe objects support the following -- 'common attributes':-data CommonAttributeUniverse = Layer | Matrix | Pin | Transformations-                             deriving (Show,Read,Eq) ---- | The CommonAttrElf family lists names of the the common attributes--- (i.e. the keys in the key value pairs), and specifies the types that the--- values should have.  For example, it specifies that 'Matrix' is a (common)--- attribute, and that the values of this attribute are of type 'Matrix 3 3 r'.-type family CommonAttrElf (f :: CommonAttributeUniverse) (r :: *) where-  CommonAttrElf 'Layer          r = Text-  CommonAttrElf 'Matrix         r = Matrix 3 3 r-  CommonAttrElf Pin             r = PinType-  CommonAttrElf Transformations r = TransformationTypes---- | A wrapper type around common attributes.-newtype CommonAttribute r s = CommonAttribute (CommonAttrElf s r)+-- data CommonAttributeUniverse = Layer | Matrix | Pin | Transformations+--                              deriving (Show,Read,Eq)  -- | Possible values for Pin data PinType = No | Yes | Horizontal | Vertical@@ -39,6 +158,18 @@ -- | Possible values for Transformation data TransformationTypes = Affine | Rigid | Translations deriving (Show,Read,Eq) +-- type family CommonAttrElf (r :: *) (f :: CommonAttributeUniverse)where+--   CommonAttrElf r 'Layer          = Text+--   CommonAttrElf r 'Matrix         = Matrix 3 3 r+--   CommonAttrElf r Pin             = PinType+--   CommonAttrElf r Transformations = TransformationTypes++-- genDefunSymbols [''CommonAttrElf]+++-- type CommonAttributes r =+--   Attributes (CommonAttrElfSym1 r) [ 'Layer, 'Matrix, Pin, Transformations ]+ -------------------------------------------------------------------------------- -- Text Attributes @@ -46,67 +177,56 @@ -- MiniPages. The same structure as for the `CommonAttributes' applies here.  -- | TODO-newtype TextLabelAttribute s r = TextLabelAttribute (CommonAttribute s r)-newtype MiniPageAttribute s r = MiniPageAttribute (CommonAttribute s r) - -------------------------------------------------------------------------------- -- | Symbol Attributes  -- | The optional Attributes for a symbol-data SymbolAttributeUniverse = SymbolStroke | SymbolFill | SymbolPen | Size-                             deriving (Show,Eq)---- | And the corresponding types-type family SymbolAttrElf (s :: SymbolAttributeUniverse) (r :: *) :: * where-  SymbolAttrElf SymbolStroke r = IpeColor-  SymbolAttrElf SymbolPen    r = IpePen r-  SymbolAttrElf SymbolFill   r = IpeColor-  SymbolAttrElf Size         r = IpeSize r----- | Wrapper around the possible SymbolAttributes-newtype SymbolAttribute r s = SymbolAttribute (SymbolAttrElf s r)+-- data SymbolAttributeUniverse = SymbolStroke | SymbolFill | SymbolPen | Size+--                              deriving (Show,Eq)   -- | Many types either consist of a symbolc value, or a value of type v data IpeValue v = Named Text | Valued v deriving (Show,Eq,Ord) +instance IsString (IpeValue v) where+  fromString = Named . fromString+ type Colour = Text -- TODO: Make this a Colour.Colour  newtype IpeSize r = IpeSize  (IpeValue r)      deriving (Show,Eq,Ord) newtype IpePen  r = IpePen   (IpeValue r)      deriving (Show,Eq,Ord) newtype IpeColor  = IpeColor (IpeValue Colour) deriving (Show,Eq,Ord) ++-- -- | And the corresponding types+-- type family SymbolAttrElf (r :: *) (s :: SymbolAttributeUniverse) :: * where+--   SymbolAttrElf r SymbolStroke = IpeColor+--   SymbolAttrElf r SymbolPen    = IpePen r+--   SymbolAttrElf r SymbolFill   = IpeColor+--   SymbolAttrElf r Size         = IpeSize r++-- genDefunSymbols [''SymbolAttrElf]+++-- type SymbolAttributes r = [SymbolStroke, SymbolFill, SymbolPen, Size]++-- type SymbolAttributes r =+--   Attributes (SymbolAttrElfSym1 r) [SymbolStroke, SymbolFill, SymbolPen, Size]+ ------------------------------------------------------------------------------- -- | Path Attributes  -- | Possible attributes for a path-data PathAttributeUniverse = Stroke | Fill | Dash | Pen | LineCap | LineJoin-                           | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient-                           deriving (Show,Eq)+-- data PathAttributeUniverse = Stroke | Fill | Dash | Pen | LineCap | LineJoin+--                            | FillRule | Arrow | RArrow | Opacity | Tiling | Gradient+--                            deriving (Show,Eq) --- | and their types-type family PathAttrElf (s :: PathAttributeUniverse) (r :: *) :: * where-  PathAttrElf Stroke   r = IpeColor-  PathAttrElf Fill     r = IpeColor-  PathAttrElf Dash     r = IpeDash r-  PathAttrElf Pen      r = IpePen r-  PathAttrElf LineCap  r = Int-  PathAttrElf LineJoin r = Int-  PathAttrElf FillRule r = FillType-  PathAttrElf Arrow    r = IpeArrow r-  PathAttrElf RArrow   r = IpeArrow r-  PathAttrElf Opacity  r = IpeOpacity-  PathAttrElf Tiling   r = IpeTiling-  PathAttrElf Gradient r = IpeGradient --- | Wrapper type around possible PathAttributes-newtype PathAttribute r s = PathAttribute (PathAttrElf s r)- -- | Possible values for Dash data IpeDash r = DashNamed Text                | DashPattern [r] r+               deriving (Show,Eq)  -- | Allowed Fill types data FillType = Wind | EOFill deriving (Show,Read,Eq)@@ -122,22 +242,112 @@                            } deriving (Show,Eq) makeLenses ''IpeArrow ++-- -- | and their types+-- type family PathAttrElf (r :: *) (s :: PathAttributeUniverse) :: * where+--   PathAttrElf r Stroke   = IpeColor+--   PathAttrElf r Fill     = IpeColor+--   PathAttrElf r Dash     = IpeDash r+--   PathAttrElf r Pen      = IpePen r+--   PathAttrElf r LineCap  = Int+--   PathAttrElf r LineJoin = Int+--   PathAttrElf r FillRule = FillType+--   PathAttrElf r Arrow    = IpeArrow r+--   PathAttrElf r RArrow   = IpeArrow r+--   PathAttrElf r Opacity  = IpeOpacity+--   PathAttrElf r Tiling   = IpeTiling+--   PathAttrElf r Gradient = IpeGradient++-- genDefunSymbols [''PathAttrElf]++-- type PathAttributes r = [ Stroke, Fill, Dash, Pen, LineCap, LineJoin+--                         , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient+--                         ]++-- type PathAttributes r =+--   Attributes (PathAttrElfSym1 r) [ Stroke, Fill, Dash, Pen, LineCap, LineJoin+--                                  , FillRule, Arrow, RArrow, Opacity, Tiling, Gradient+--                                  ]+ -------------------------------------------------------------------------------- -- | Group Attributes   -- | The only group attribute is a Clip-data GroupAttributeUniverse = Clip deriving (Show,Read,Eq,Ord)+-- data GroupAttributeUniverse = Clip deriving (Show,Read,Eq,Ord)  -- A clipping path is a Path. Which is defined in Data.Geometry.Ipe.Types. To -- avoid circular imports, we define GroupAttrElf and GroupAttribute there.   --------------------------------------------------------------------------------+-- * Attribute names in Ipe --- | Generate singletons for all the Universes-genSingletons [ ''CommonAttributeUniverse-              , ''SymbolAttributeUniverse-              , ''PathAttributeUniverse-              , ''GroupAttributeUniverse-              ]++-- | For the types representing attribute values we can get the name/key to use+-- when serializing to ipe.+class IpeAttrName (a :: AttributeUniverse) where+  attrName :: Proxy a -> Text++-- CommonAttributeUnivers+instance IpeAttrName Layer           where attrName _ = "layer"+instance IpeAttrName Matrix          where attrName _ = "matrix"+instance IpeAttrName Pin             where attrName _ = "pin"+instance IpeAttrName Transformations where attrName _ = "transformations"++-- IpeSymbolAttributeUniversre+instance IpeAttrName Stroke       where attrName _ = "stroke"+instance IpeAttrName Fill         where attrName _ = "fill"+instance IpeAttrName Pen          where attrName _ = "pen"+instance IpeAttrName Size         where attrName _ = "size"++-- PathAttributeUniverse+instance IpeAttrName Dash       where attrName _ = "dash"+instance IpeAttrName LineCap    where attrName _ = "cap"+instance IpeAttrName LineJoin   where attrName _ = "join"+instance IpeAttrName FillRule   where attrName _ = "fillrule"+instance IpeAttrName Arrow      where attrName _ = "arrow"+instance IpeAttrName RArrow     where attrName _ = "rarrow"+instance IpeAttrName Opacity    where attrName _ = "opacity"+instance IpeAttrName Tiling     where attrName _ = "tiling"+instance IpeAttrName Gradient   where attrName _ = "gradient"++-- GroupAttributeUniverse+instance IpeAttrName Clip     where attrName _ = "clip"+++-- | Wrap up a value with a capability given by its type+data GDict (c :: k -> Constraint) (a :: k) where+  GDict :: c a => Proxy a -> GDict c a++-- -- | Sometimes we may know something for /all/ fields of a record, but when+-- -- you expect to be able to /each/ of the fields, you are then out of luck.+-- -- Surely given @∀x:u.φ(x)@ we should be able to recover @x:u ⊢ φ(x)@! Sadly,+-- -- the constraint solver is not quite smart enough to realize this and we must+-- -- make it patently obvious by reifying the constraint pointwise with proof.+-- gReifyConstraint+--   :: RecAll f rs c+--   => proxy c+--   -> Rec f rs+--   -> Rec (GDict c :. f) rs+-- gReifyConstraint prx RNil      = RNil+-- gReifyConstraint prx (x :& xs) = Compose (mkDict x) :& reifyConstraint prx xs+--   where+--     mkDict   :: f l -> (GDict c l)+--     mkDict _ = GDict (Proxy :: Proxy l)++-- | Function that states that all elements in xs satisfy a given constraint c+type family AllSatisfy (c :: k -> Constraint) (xs :: [k]) :: Constraint where+  AllSatisfy c '[] = ()+  AllSatisfy c (x ': xs) = (c x, AllSatisfy c xs)+++-- | Writing Attribute names+writeAttrNames           :: AllSatisfy IpeAttrName rs => Rec f rs -> Rec (Const Text) rs+writeAttrNames RNil      = RNil+writeAttrNames (x :& xs) = Const (write'' x) :& writeAttrNames xs+  where+    write''   :: forall f s. IpeAttrName s => f s -> Text+    write'' _ = attrName (Proxy :: Proxy s)++--
+ src/Data/Geometry/Ipe/FromIpe.hs view
@@ -0,0 +1,50 @@+module Data.Geometry.Ipe.FromIpe where++import Control.Applicative+import qualified Data.Traversable as Tr+import Data.Ext+import Data.Geometry.Ipe.Types+import Data.Geometry.Line+import Data.Geometry.LineSegment+import qualified Data.Geometry.PolyLine as PolyLine+import Data.Geometry.Polygon+import Control.Lens+import qualified Data.Seq2 as S2+++-- | 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+_asPolyLine :: Prism' (Path r) (PolyLine.PolyLine 2 () r)+_asPolyLine = prism' poly2path path2poly+  where+    poly2path = Path . S2.l1Singleton  . PolyLineSegment+    path2poly = preview (pathSegments.Tr.traverse._PolyLineSegment)+    -- TODO: Check that the path actually is a polyline, rather+    -- than ignoring everything that does not fit++-- | Convert to a simple polygon: simply takes the first closed path+_asSimplePolygon :: Prism' (Path r) (SimplePolygon () r)+_asSimplePolygon = prism' poly2path path2poly+  where+    poly2path = Path . S2.l1Singleton . PolygonPath+    path2poly = preview (pathSegments.Tr.traverse._PolygonPath)+    -- TODO: Check that the path actually is a simple polygon, rather+    -- than ignoring everything that does not fit++-- | 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.+_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
+ src/Data/Geometry/Ipe/IpeOut.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Geometry.Ipe.IpeOut where++import           Control.Applicative+import           Control.Lens+import           Data.Bifunctor+import           Data.Ext+import qualified Data.Foldable as F+import           Data.Geometry.Ball+import           Data.Geometry.Boundary+import           Data.Geometry.Ipe.Attributes+import           Data.Geometry.Ipe.Types+import           Data.Geometry.LineSegment+import           Data.Geometry.Point+import           Data.Geometry.Box+import           Data.Geometry.Polygon+import           Data.Geometry.PolyLine+import           Data.Geometry.Properties+import           Data.Geometry.Transformation+import qualified Data.List.NonEmpty as NE+import           Data.Semigroup+import           Data.Proxy+import qualified Data.Seq2 as S2+import           Data.Text(Text)+import qualified Data.Traversable as Tr+import           Data.Vinyl++--------------------------------------------------------------------------------++-- | An IpeOut is essentially a funciton to convert a geometry object of type+-- 'g' into an ipe object of type 'i'.+newtype IpeOut g i = IpeOut { asIpe :: g -> i } deriving (Functor)++-- | Given an geometry object, and a record with its attributes, construct an ipe+-- Object representing it using the default conversion.+asIpeObject :: (HasDefaultIpeOut g, DefaultIpeOut g ~ i, NumType g ~ r)+            => g -> IpeAttributes i r -> IpeObject r+asIpeObject = asIpeObjectWith defaultIpeOut++-- | asIpeObject with its arguments flipped. Convenient if you don't want to+-- map asIpeObject over a list or so.+asIpeObject' :: (HasDefaultIpeOut g, DefaultIpeOut g ~ i, NumType g ~ r)+             => IpeAttributes i r -> g -> IpeObject r+asIpeObject' = flip asIpeObject+++-- -- | Given a IpeOut that specifies how to convert a geometry object into an+-- ipe geometry object, the geometry object, and a record with its attributes,+-- construct an ipe Object representing it.+asIpeObjectWith          :: (ToObject i, NumType g ~ r)+                      => IpeOut g (IpeObject' i r) -> g -> IpeAttributes i r -> IpeObject r+asIpeObjectWith io g ats = asIpe (ipeObject io ats) g+++-- | Create an ipe group without group attributes+asIpeGroup :: [IpeObject r] -> IpeObject r+asIpeGroup = flip asIpeGroup' mempty++-- | Creates a group out of ipe+asIpeGroup'        :: [IpeObject r] -> IpeAttributes Group r -> IpeObject r+asIpeGroup' gs ats = IpeGroup $ Group gs :+ ats++--------------------------------------------------------------------------------++-- | Helper to construct an IpeOut g IpeObject , if we already know how to+-- construct a specific Ipe type.+ipeObject        :: (ToObject i, NumType g ~ r)+                   => IpeOut g (IpeObject' i r) -> IpeAttributes i r -> IpeOut g (IpeObject r)+ipeObject io ats = IpeOut $ \g -> let (i :+ ats') = asIpe io g+                                    in ipeObject' i (ats' <> ats)++-- | Construct an ipe object from the core of an Ext+coreOut    :: IpeOut g i -> IpeOut (g :+ a) i+coreOut io = IpeOut $ asIpe io . (^.core)++--------------------------------------------------------------------------------+-- * Default Conversions++-- | Class that specifies a default conversion from a geometry type g into an+-- ipe object.+class ToObject (DefaultIpeOut g) => HasDefaultIpeOut g where+  type DefaultIpeOut g :: * -> *++  defaultIpeOut :: IpeOut g (IpeObject' (DefaultIpeOut g) (NumType g))++  -- defaultIpeObject :: RecApplicative (AttributesOf (DefaultIpeOut g))+  --                  => IpeOut g (IpeObject (NumType g))+  -- defaultIpeObject = IpeOut $ flip asIpeObject mempty++instance HasDefaultIpeOut (Point 2 r) where+  type DefaultIpeOut (Point 2 r) = IpeSymbol+  defaultIpeOut = ipeDiskMark++instance HasDefaultIpeOut (LineSegment 2 p r) where+  type DefaultIpeOut (LineSegment 2 p r) = Path+  defaultIpeOut = ipeLineSegment++instance Floating r => HasDefaultIpeOut (Disk p r) where+  type DefaultIpeOut (Disk p r) = Path+  defaultIpeOut = ipeDisk++instance HasDefaultIpeOut (PolyLine 2 p r) where+  type DefaultIpeOut (PolyLine 2 p r) = Path+  defaultIpeOut = noAttrs ipePolyLine++instance HasDefaultIpeOut (SimplePolygon p r) where+  type DefaultIpeOut (SimplePolygon p r) = Path+  defaultIpeOut = flip addAttributes ipeSimplePolygon $+                    mempty <> attr SFill (IpeColor "red")++--------------------------------------------------------------------------------+-- * Point Converters++ipeMark   :: Text -> IpeOut (Point 2 r) (IpeObject' IpeSymbol r)+ipeMark n = noAttrs . IpeOut $ flip Symbol n++ipeDiskMark :: IpeOut (Point 2 r) (IpeObject' IpeSymbol r)+ipeDiskMark = ipeMark "mark/disk(sx)"++--------------------------------------------------------------------------------++noAttrs :: Monoid extra => IpeOut g core -> IpeOut g (core :+ extra)+noAttrs = addAttributes mempty++addAttributes :: extra -> IpeOut g core -> IpeOut g (core :+ extra)+addAttributes ats io = IpeOut $ \g -> asIpe io g :+ ats+++-- | Default size of the cliping rectangle used to clip lines. This is+-- Rectangle is large enough to cover the normal page size in ipe.+defaultClipRectangle :: (Num r, Ord r) => Rectangle () r+defaultClipRectangle = boundingBox (point2 (-200) (-200)) <>+                       boundingBox (point2 1000 1000)++-- -- | An ipe out to draw a line, by clipping it to stay within a rectangle of+-- -- default size.+-- line :: IpeOut (Line 2 r) (IpeObject' Path r)+-- line = line' defaultClipRectangle++-- -- | An ipe out to draw a line, by clipping it to stay within the rectangle+-- line'   :: Rectangle p r -> IpeOut (Line 2 r) (IpeObject' Path r)+-- line' r = IpeOut $ \l -> error "not implemented yet"+++ipeLineSegment :: IpeOut (LineSegment 2 p r) (IpeObject' Path r)+ipeLineSegment = noAttrs $ fromPathSegment ipeLineSegment'++ipeLineSegment' :: IpeOut (LineSegment 2 p r) (PathSegment r)+ipeLineSegment' = IpeOut $ PolyLineSegment . fromLineSegment . first (const ())+++ipePolyLine :: IpeOut (PolyLine 2 p r) (Path r)+ipePolyLine = fromPathSegment ipePolyLine'++ipePolyLine' :: IpeOut (PolyLine 2 a r) (PathSegment r)+ipePolyLine' = IpeOut $ PolyLineSegment . first (const ())++ipeDisk :: Floating r => IpeOut (Disk p r) (IpeObject' Path r)+ipeDisk = noAttrs . IpeOut $ asIpe ipeCircle . Boundary++ipeCircle :: Floating r => IpeOut (Circle p r) (Path r)+ipeCircle = fromPathSegment ipeCircle'++ipeCircle' :: Floating r => IpeOut (Circle p r) (PathSegment r)+ipeCircle' = IpeOut circle''+  where+    circle'' (Circle (c :+ _) r) = EllipseSegment m+      where+        m = translation (toVec c) |.| uniformScaling (sqrt r) ^. transformationMatrix+        -- m is the matrix s.t. if we apply m to the unit circle centered at the origin, we+        -- get the input circle.+++-- | Helper to construct a IpeOut g Path, for when we already have an IpeOut g PathSegment+fromPathSegment    :: IpeOut g (PathSegment r) -> IpeOut g (Path r)+fromPathSegment io = IpeOut $ Path . S2.l1Singleton . asIpe io++ipeSimplePolygon :: IpeOut (SimplePolygon p r) (Path r)+ipeSimplePolygon = fromPathSegment . IpeOut $ PolygonPath . dropExt+  where+    dropExt                    :: SimplePolygon p r -> SimplePolygon () r+    dropExt (SimplePolygon vs) = SimplePolygon $ fmap (&extra .~ ()) vs++++++-- ls = (ClosedLineSegment (ext origin) (ext (point2 1 1)))+++-- testzz :: IpeObject Integer+-- testzz = asIpeObjectWith ipeLineSegment ls $ mempty <> attr SStroke (IpeColor "red")+++++-- test' :: Attributes (PathAttrElfSym1 Integer) (AttributesOf (Path Integer) (PathAttrElfSym1 Integer))+-- -- test' :: RecApplicative (AttributesOf (Path Integer) (IpeObjectSymbolF (Path Integer)))+-- --       => IpeAttributes (Path Integer)+-- test' = mempty+++++-- -- test' :: IpeObject Integer ('IpePath '[])+-- test' = asIpeObject' ls emptyPathAttributes+++++-- emptyPathAttributes :: Rec (PathAttribute r) '[]+-- emptyPathAttributes = RNil
+ src/Data/Geometry/Ipe/Literal.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Geometry.Ipe.Literal where+++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as C+import Text.XML.Expat.Tree++literally :: String -> Q Exp+literally = return . LitE . StringL++lit :: QuasiQuoter+lit = QuasiQuoter { quoteExp = literally+                  , quotePat = undefined+                  , quoteType = undefined+                  , quoteDec  = undefined+                  }++litFile :: QuasiQuoter+litFile = quoteFile lit+++xmlLiteral :: String -> Node T.Text T.Text+xmlLiteral = either (error "xmlLiteral. error parsing xml: " . show) id+           .  parse' defaultParseOptions . C.pack
src/Data/Geometry/Ipe/ParserPrimitives.hs view
@@ -6,17 +6,13 @@                                          , (<*><>) , (<*><)                                          , (<***>) , (<***) , (***>)                                          , pMaybe , pCount , pSepBy-                                         , Parser(..) , ParseError+                                         , Parser, ParseError                                          , pNotFollowedBy                                          ) where ---- import Data.Functor.Identity- import           Control.Applicative hiding (many,(<|>))- import           Text.Parsec(try)-import           Text.Parsec(ParsecT(..),Parsec, Stream(..))+import           Text.Parsec(ParsecT, Stream) import           Text.Parsec.Text import           Text.ParserCombinators.Parsec hiding (Parser,try) @@ -74,11 +70,12 @@   -- | infix variant of notfollowed by+pNotFollowedBy :: Parser a -> Parser b -> Parser a p `pNotFollowedBy` q = do { x <- p ; notFollowedBy' q ; return x }     where       -- | copy of the original notFollowedBy but replaced the error message       -- to get rid of the Show dependency-      notFollowedBy' p     = try (do{ c <- try p; unexpected "not followed by" }+      notFollowedBy' z     = try (do{ _ <- try z; unexpected "not followed by" }                                     <|> return ()                                  ) @@ -98,7 +95,9 @@   return $ f x  -p <*>< q = (\a _ -> a) <$> p <*><> q+(<*><)   :: (Stream s m t, Reversable s)+          => ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b+p <*>< q = const <$> p <*><> q   rev :: (Reversable s, Stream s m t) => ParsecT s u m ()
src/Data/Geometry/Ipe/PathParser.hs view
@@ -4,19 +4,21 @@  import           Numeric +import           Data.Ext(ext) import           Control.Applicative import           Control.Monad  import           Data.Bifunctor import           Data.Monoid(mconcat) import           Data.Semigroup-import           Data.Validation(AccValidation(..))+-- import           Data.Validation(AccValidation(..))  import           Data.Char(isSpace) import           Data.Ratio  import           Text.Parsec.Error(messageString, errorMessages) import           Data.Geometry.Point+import           Data.Geometry.Box import           Data.Geometry.Vector import           Data.Geometry.Transformation import           Data.Geometry.Ipe.ParserPrimitives@@ -50,9 +52,15 @@ ----------------------------------------------------------------------- -- | Running the parsers +readCoordinate :: Coordinate r => Text -> Either Text r+readCoordinate = runParser pCoordinate+ readPoint :: Coordinate r => Text -> Either Text (Point 2 r)-readPoint = bimap errorText fst . runP pPoint+readPoint = runParser pPoint +runParser   :: Parser a -> Text -> Either Text a+runParser p = bimap errorText fst . runP p+ -- Collect errors data Either' l r = Left' l | Right' r deriving (Show,Eq) instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where@@ -100,8 +108,12 @@   readMatrix :: Coordinate r => Text -> Either Text (Matrix 3 3 r)-readMatrix = bimap errorText fst . runP pMatrix+readMatrix = runParser pMatrix ++readRectangle :: Coordinate r => Text -> Either Text (Rectangle () r)+readRectangle = runParser pRectangle+ ----------------------------------------------------------------------- -- | The parsers themselves @@ -131,6 +143,11 @@               where                 pDecimal = pMaybe (pChar '.' *> pInteger) +pRectangle :: Coordinate r => Parser (Rectangle () r)+pRectangle = (\p q -> fromCornerPoints (ext p) (ext q)) <$> pPoint+                                                        <*  pWhiteSpace+                                                        <*> pPoint+ pMatrix :: Coordinate r => Parser (Matrix 3 3 r) pMatrix = (\a b -> mkMatrix (a:b)) <$> pCoordinate                                    <*> pCount 5 (pWhiteSpace *> pCoordinate)@@ -148,3 +165,4 @@                          -- But ipe uses the following order:                          -- 024                          -- 135+mkMatrix _             = error "mkMatrix: need exactly 6 arguments"
src/Data/Geometry/Ipe/Reader.hs view
@@ -1,65 +1,431 @@+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-module Data.Geometry.Ipe.Reader where+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-}+module Data.Geometry.Ipe.Reader( -- * Reading ipe Files+                                 readRawIpeFile+                               , readIpeFile+                               , readSinglePageFile+                               , ConversionError +                               -- * Reading XML directly+                               , fromIpeXML+                               , readXML++                               -- * Read classes+                               , IpeReadText(..)+                               , IpeRead(..)+                               , IpeReadAttr(..)+++                               -- * Some low level implementation functions+                               , ipeReadTextWith+                               , ipeReadObject+                               , ipeReadAttrs+                               , ipeReadRec+                               ) where++import           Data.Proxy import           Data.Either(rights)-import           Control.Applicative-import           Control.Lens+import           Control.Applicative hiding (Const)+import           Control.Lens hiding (Const, rmap)  import           Data.Ext import qualified Data.Foldable as F+import qualified Data.Traversable as Tr+import           Data.Maybe(fromMaybe, isJust, mapMaybe)+import qualified Data.List as L import           Data.Vinyl+import           Data.Vinyl.Functor+import           Data.Vinyl.TypeLevel -import           Data.Validation+import qualified Data.List.NonEmpty as NE+-- import           Data.Validation+import qualified Data.Seq2     as S2  import           Data.Geometry.Point-import           Data.Geometry.Line-import           Data.Geometry.LineSegment+import           Data.Geometry.Box+import qualified Data.Geometry.Polygon as Polygon import           Data.Geometry.PolyLine+import qualified Data.Geometry.Transformation as Trans import           Data.Geometry.Ipe.Types import           Data.Geometry.Ipe.Attributes+import qualified Data.Geometry.Ipe.Attributes as IA+import           Data.Geometry.Ipe.PathParser+import           Data.Geometry.Ipe.ParserPrimitives(pInteger)  import qualified Data.ByteString as B import           Data.Monoid+import           Data.Singletons import           Data.Text(Text) -import           Data.Geometry.Ipe.PathParser  import           Text.XML.Expat.Tree  import qualified Data.Text as T+-- import qualified Data.Map as M --- fromIpeFile :: (Coordinate r, IpeRead t) => FilePath -> IO [PolyLine 2 () r]--- fromIpeFile+-------------------------------------------------------------------------------- +type ConversionError = Text -fromIpeXML   :: (Coordinate r, IpeRead t) => B.ByteString -> Either ConversionError (t r)-fromIpeXML b = (bimap (T.pack . show) id $ parse' defaultParseOptions b) >>= ipeRead -class IpeReadText t where-  ipeReadText :: Coordinate r => Text -> Either ConversionError (t r)+-- | Given a file path, tries to read an ipe file+readRawIpeFile :: Coordinate r => FilePath -> IO (Either ConversionError (IpeFile r))+readRawIpeFile = fmap fromIpeXML . B.readFile -type ConversionError = Text --- TODO: We also want to do something with the attributes+-- | Given a file path, tries to read an ipe file. This function applies all+-- matrices to objects.+readIpeFile :: Coordinate r => FilePath -> IO (Either ConversionError (IpeFile r))+readIpeFile = fmap (bimap id applyMatrices) . readRawIpeFile ++-- | Since most Ipe file contain only one page, we provide a shortcut for that+-- as well. This function applies all matrices.+readSinglePageFile :: Coordinate r => FilePath -> IO (Either ConversionError (IpePage r))+readSinglePageFile = fmap f . readIpeFile+  where+    f (Left e)  = Left e+    f (Right i) = maybe (Left "No Ipe pages found") Right . firstOf (pages.traverse) $ i++-- | Given a Bytestring, try to parse the bytestring into anything that is+-- IpeReadable, i.e. any of the Ipe elements.+fromIpeXML   :: (Coordinate r, IpeRead (t r))+             => B.ByteString -> Either ConversionError (t r)+fromIpeXML b = readXML b >>= ipeRead++-- | 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++--------------------------------------------------------------------------------++-- | Reading an ipe elemtn from a Text value+class IpeReadText t where+  ipeReadText :: Text -> Either ConversionError t++-- | Reading an ipe lement from Xml class IpeRead t where-  ipeRead :: Coordinate r => Node Text Text -> Either ConversionError (t r)+  ipeRead  :: Node Text Text -> Either ConversionError t --- instance IpeRead IpeSymbol where---   ipeRead (Element "use" ats _) = case extract ["pos","name"] ats of+--------------------------------------------------------------------------------+--  ReadText instances --- given a list of keys, and a list of attributes. Extracts the values matching--- the keys. The result is a pair (vs,others), where others are the remaining--- attributes, and vs are the values corresponding to the keys. Sorted on--- increasing order of their keys.-extract :: [Text] -> [(Text,Text)] -> ([Text],[(Text,Text)])-extract = undefined+instance IpeReadText Text where+  ipeReadText = Right -instance IpeReadText (PolyLine 2 ()) where+instance IpeReadText Int where+  ipeReadText = fmap fromInteger . runParser pInteger++instance Coordinate r => IpeReadText (Point 2 r) where+  ipeReadText = readPoint++instance Coordinate r => IpeReadText (Trans.Matrix 3 3 r) where+  ipeReadText = readMatrix++instance IpeReadText LayerName where+  ipeReadText = Right . LayerName++instance IpeReadText PinType where+  ipeReadText "yes" = Right Yes+  ipeReadText "h"   = Right Horizontal+  ipeReadText "v"   = Right Vertical+  ipeReadText ""    = Right No+  ipeReadText _     = Left "invalid PinType"++instance IpeReadText TransformationTypes where+  ipeReadText "affine"       = Right Affine+  ipeReadText "rigid"        = Right Rigid+  ipeReadText "translations" = Right Translations+  ipeReadText _              = Left "invalid TransformationType"++instance IpeReadText FillType where+  ipeReadText "wind"   = Right Wind+  ipeReadText "eofill" = Right EOFill+  ipeReadText _        = Left "invalid FillType"++instance Coordinate r => IpeReadText (IpeArrow r) where+  ipeReadText t = case T.split (== '/') t of+                    [n,s] -> IpeArrow <$> pure n <*> ipeReadText s+                    _     -> Left "ipeArrow: name contains not exactly 1 / "++instance Coordinate r => IpeReadText (IpeDash r) where+  ipeReadText t = Right . DashNamed $ t+                  -- TODO: Implement proper parsing here+++ipeReadTextWith     :: (Text -> Either t v) -> Text -> Either ConversionError (IpeValue v)+ipeReadTextWith f t = case f t of+                        Right v -> Right (Valued v)+                        Left _  -> Right (Named t)+++instance Coordinate r => IpeReadText (Rectangle () r) where+  ipeReadText = readRectangle++instance IpeReadText IpeColor where+  ipeReadText = fmap IpeColor . ipeReadTextWith Right++instance Coordinate r => IpeReadText (IpePen r) where+  ipeReadText = fmap IpePen . ipeReadTextWith readCoordinate++instance Coordinate r => IpeReadText (IpeSize r) where+  ipeReadText = fmap IpeSize . ipeReadTextWith readCoordinate+++instance Coordinate r => IpeReadText [Operation r] where+  ipeReadText = readPathOperations++instance Coordinate r => IpeReadText (NE.NonEmpty (PathSegment r)) where+  ipeReadText t = ipeReadText t >>= fromOpsN+    where+      fromOpsN xs = case fromOps xs of+                      Left l       -> Left l+                      Right []     -> Left "No path segments produced"+                      Right (p:ps) -> Right $ p NE.:| ps++      fromOps []            = Right []+      fromOps (MoveTo p:xs) = fromOps' p xs+      fromOps _             = Left "Path should start with a move to"++      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 pts+                                      pl   = fromPoints pts+                                  in case xs of+                                       (ClosePath : xs') -> PolygonPath poly   <<| xs'+                                       _                 -> PolyLineSegment pl <<| xs+      fromOps' _ _ = Left "fromOpts': rest not implemented yet."++      span' pr = L.span (not . isn't pr)++      x <<| xs = (x:) <$> fromOps xs++instance Coordinate r => IpeReadText (Path r) where+  ipeReadText = fmap (Path . S2.viewL1FromNonEmpty) . ipeReadText++--------------------------------------------------------------------------------+-- Reading attributes++-- | Basically IpeReadText for attributes. This class is not really meant to be+-- implemented directly. Just define an IpeReadText instance for the type+-- (Apply f at), then the generic instance below takes care of looking up the+-- name of the attribute, and calling the right ipeReadText value. This class+-- is just so that reifyConstraint in `ipeReadRec` can select the right+-- typeclass when building the rec.+class IpeReadAttr t where+  ipeReadAttr  :: Text -> Node Text Text -> Either ConversionError t++instance IpeReadText (Apply f at) => IpeReadAttr (Attr f at) where+  ipeReadAttr n (Element _ ats _) = GAttr <$> Tr.mapM ipeReadText (lookup n ats)+  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))+                                      -> 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++-- | Reading the Attributes into a Rec (Attr f), all based on the types of f+-- (the type family mapping labels to types), and a list of labels (ats).+ipeReadRec       :: forall f ats.+                 ( RecApplicative ats+                 , RecAll (Attr f) ats IpeReadAttr+                 , AllSatisfy IpeAttrName ats+                 )+                 => Proxy f -> Proxy ats+                 -> Node Text Text+                 -> Either ConversionError (Rec (Attr  f) ats)+ipeReadRec _ _ x = zipTraverseWith f (writeAttrNames r) r'+  where+    r  = rpure (GAttr Nothing)+    r' = reifyConstraint (Proxy :: Proxy IpeReadAttr) r+++    f                              :: forall at.+                                      Const Text at+                                   -> (Dict IpeReadAttr :. Attr f) at+                                   -> Either ConversionError (Attr f at)+    f (Const n) (Compose (Dict _)) = ipeReadAttr n x+++-- | Reader for records. Given a proxy of some ipe type i, and a proxy of an+-- coordinate type r, read the IpeAttributes for i from the xml node.+ipeReadAttrs     :: forall proxy proxy' i r f ats.+                 ( f ~ AttrMapSym1 r, ats ~ AttributesOf i+                 , RecApplicative ats+                 , RecAll (Attr f) ats IpeReadAttr+                 , AllSatisfy IpeAttrName ats+                 )+                 => proxy i -> proxy' r+                 -> Node Text Text+                 -> Either ConversionError (IpeAttributes i r)+ipeReadAttrs _ _ = fmap Attrs . ipeReadRec (Proxy :: Proxy f) (Proxy :: Proxy ats)+++testSym :: B.ByteString+testSym = "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+++++-- readAttrsFromXML :: B.ByteString -> Either++readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double)+readSymAttrs = readXML testSym+               >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)++++++-- | If we can ipeRead an ipe element, and we can ipeReadAttrs its attributes+-- we can properly read an ipe object using ipeReadObject+ipeReadObject           :: ( IpeRead (i r)+                           , f ~ AttrMapSym1 r, ats ~ AttributesOf i+                           ,  RecApplicative ats+                           , RecAll (Attr f) ats IpeReadAttr+                           , AllSatisfy IpeAttrName ats+                           )+                        => Proxy i -> proxy r -> Node Text Text+                        -> Either ConversionError (i r :+ IpeAttributes i r)+ipeReadObject prI prR xml = (:+) <$> ipeRead xml <*> ipeReadAttrs prI prR xml+++--------------------------------------------------------------------------------+-- | Ipe read instances++instance Coordinate r => IpeRead (IpeSymbol r) where+  ipeRead (Element "use" ats _) = case lookup "pos" ats of+      Nothing -> Left "symbol without position"+      Just ps -> flip Symbol name <$> ipeReadText ps+    where+      name = fromMaybe "mark/disk(sx)" $ lookup "name" ats+  ipeRead _ = Left "symbol element expected, text found"++-- | Given a list of Nodes, try to parse all of them as a big text. If we+-- encounter anything else then text, the parsing fails.+allText :: [Node Text Text] -> Either ConversionError Text+allText = fmap T.unlines . mapM unT+  where+    unT (Text t) = Right t+    unT _        = Left "allText: Expected Text, found an Element"++instance Coordinate r => IpeRead (Path r) where+  ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText+  ipeRead _                      = Left "path: expected element, found text"+++lookup'   :: Text -> [(Text,a)] -> Either ConversionError a+lookup' k = maybe (Left $ "lookup' " <> k <> " not found") Right . lookup k++instance Coordinate r => IpeRead (TextLabel r) where+  ipeRead (Element "text" ats chs)+    | lookup "type" ats == Just "label" = Label+                                       <$> allText chs+                                       <*> (lookup' "pos" ats >>= ipeReadText)+    | otherwise                         = Left "Not a Text label"+  ipeRead _                             = Left "textlabel: Expected element, found text"++++instance Coordinate r => IpeRead (MiniPage r) where+  ipeRead (Element "text" ats chs)+    | lookup "type" ats == Just "minipage" = MiniPage+                                          <$> allText chs+                                          <*> (lookup' "pos"   ats >>= ipeReadText)+                                          <*> (lookup' "width" ats >>= readCoordinate)+    | otherwise                            = Left "Not a MiniPage"+  ipeRead _                                = Left "MiniPage: Expected element, found text"+++instance Coordinate r => IpeRead (Image r) where+  ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText)+  ipeRead _                       = Left "Image: Element expected, text found"++instance Coordinate r => IpeRead (IpeObject r) where+  ipeRead x = firstRight [ IpeUse       <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x+                         , IpePath      <$> ipeReadObject (Proxy :: Proxy Path)      r x+                         , IpeGroup     <$> ipeReadObject (Proxy :: Proxy Group)     r x+                         , IpeTextLabel <$> ipeReadObject (Proxy :: Proxy TextLabel) r x+                         , IpeMiniPage  <$> ipeReadObject (Proxy :: Proxy MiniPage)  r x+                         , IpeImage     <$> ipeReadObject (Proxy :: Proxy Image)     r x+                         ]+    where+      r = Proxy :: Proxy r++firstRight :: [Either ConversionError a] -> Either ConversionError a+firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right)+++instance Coordinate r => IpeRead (Group r) where+  ipeRead (Element "group" _ chs) = Group <$> mapM ipeRead chs+  ipeRead _                       = Left "ipeRead Group: expected Element, found Text"+++instance IpeRead LayerName where+  ipeRead (Element "layer" ats _) = LayerName <$> lookup' "name" ats+  ipeRead _                       = Left "layer: Expected element, found text"++instance IpeRead View where+  ipeRead (Element "view" ats _) = (\lrs a -> View (map LayerName $ T.words lrs) a)+                                <$> lookup' "layers" ats+                                <*> (lookup' "active" ats >>= ipeReadText)+  ipeRead _                      = Left "View Expected element, found text"+++-- TODO: this instance throws away all of our error collecting (and is pretty+-- slow/stupid since it tries parsing all children with all parsers)+instance Coordinate r => IpeRead (IpePage r) where+  ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs)+  ipeRead _                      = Left "page: Element expected, text found"+      -- withDef   :: b -> Either a b -> Either c b+      -- withDef d = either (const $ Right d) Right++      -- readLayers  = withDef ["alpha"] . readAll+      -- readViews   = withDef []        . readAll+      -- readObjects = withDef []        . readAll++-- | try reading everything as an a. Throw away whatever fails.+readAll   :: IpeRead a => [Node Text Text] -> [a]+readAll   = rights . map ipeRead+++instance Coordinate r => IpeRead (IpeFile r) where+  ipeRead (Element "ipe" _ chs) = case readAll chs of+                                    []  -> Left "Ipe: no pages found"+                                    pgs -> Right $ IpeFile Nothing [] (NE.fromList pgs)+  ipeRead _                     = Left "Ipe: Element expected, text found"++++testz :: Either ConversionError (IpeObject Double)+testz = (bimap (T.pack . show) id $ parse' defaultParseOptions testSym)+               >>= ipeRead -- Object (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)+++++++++++++++  -- ipeReadAttrs (Element _ ats _) =++instance Coordinate r => IpeReadText (PolyLine 2 () r) where   ipeReadText t = readPathOperations t >>= fromOps     where-      fromOps (MoveTo p:LineTo q:ops) = (\ps -> fromPoints $ [p,q] ++ ps)+      fromOps (MoveTo p:LineTo q:ops) = (\ps -> fromPoints' $ [p,q] ++ ps)                                      <$> validateAll "Expected LineTo p" _LineTo ops       fromOps _                       = Left "Expected MoveTo p:LineTo q:... " @@ -76,25 +442,24 @@     toEither = either' Left Right  -- This is a bit of a hack-instance IpeRead (PolyLine 2 ()) where+instance Coordinate r => IpeRead (PolyLine 2 () r) where   ipeRead (Element "path" ats ts) = ipeReadText . T.unlines . map unText $ ts                                     -- apparently hexpat already splits the text into lines   ipeRead _                       = Left "iperead: no polyline." +unText          :: Node t t1 -> t1 unText (Text t) = t-+unText _        = error "unText: element found, text expected" -instance IpeRead PathSegment where+instance Coordinate r => IpeRead (PathSegment r) where   ipeRead = fmap PolyLineSegment . ipeRead  testP :: B.ByteString testP = "<path stroke=\"black\">\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n</path>" -testO :: Text-testO = "\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n" -testPoly :: Either Text (PolyLine 2 () Double)-testPoly = fromIpeXML testP+-- testPoly :: Either Text (Path Double)+-- testPoly = fromIpeXML testP  -- ipeRead' :: [Element Text Text] -- ipeRead' = map ipeRead@@ -117,3 +482,5 @@ polylinesFromIpeFile = fmap readPolies . B.readFile   where     readPolies = either (const []) readPolyLines . parse' defaultParseOptions++--------------------------------------------------------------------------------
src/Data/Geometry/Ipe/Types.hs view
@@ -1,41 +1,44 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} module Data.Geometry.Ipe.Types where  import           Control.Applicative import           Control.Lens+import           Data.Monoid import           Data.Proxy import           Data.Vinyl -import           Linear.Affine((.-.), qdA)- import           Data.Ext-import           Data.Geometry.Ball-import           Data.Geometry.Point-import           Data.Geometry.Properties-import           Data.Geometry.Transformation(Matrix) import           Data.Geometry.Box(Rectangle)-import           Data.Geometry.Line+import           Data.Geometry.Point import           Data.Geometry.PolyLine+import           Data.Geometry.Polygon(SimplePolygon)+import           Data.Geometry.Properties+import           Data.Geometry.Transformation -import           Data.Geometry.Ipe.Attributes+import           Data.Maybe(mapMaybe)+import           Data.Singletons.TH(genDefunSymbols)++import           Data.Geometry.Ipe.Literal+import qualified Data.Geometry.Ipe.Attributes as AT+import           Data.Geometry.Ipe.Attributes hiding (Matrix) import           Data.Text(Text)-import           Data.TypeLevel.Filter+import           Text.XML.Expat.Tree(Node)  import           GHC.Exts -import           GHC.TypeLits -import qualified Data.Sequence as S+import qualified Data.List.NonEmpty as NE import qualified Data.Seq2     as S2  --------------------------------------------------------------------------------  +newtype LayerName = LayerName {_layerName :: Text } deriving (Show,Read,Eq,Ord,IsString)+ -------------------------------------------------------------------------------- -- | Image Objects @@ -45,6 +48,12 @@                      } deriving (Show,Eq,Ord) makeLenses ''Image +type instance NumType   (Image r) = r+type instance Dimension (Image r) = 2++instance Num r => IsTransformable (Image r) where+  transformBy t = over rect (transformBy t)+ -------------------------------------------------------------------------------- -- | Text Objects @@ -54,6 +63,18 @@ data MiniPage r = MiniPage Text (Point 2 r) r                  deriving (Show,Eq,Ord) +type instance NumType   (TextLabel r) = r+type instance Dimension (TextLabel r) = 2++type instance NumType   (MiniPage r) = r+type instance Dimension (MiniPage r) = 2++instance Num r => IsTransformable (TextLabel r) where+  transformBy t (Label txt p) = Label txt (transformBy t p)++instance Num r => IsTransformable (MiniPage r) where+  transformBy t (MiniPage txt p w) = MiniPage txt (transformBy t p) w+ width                  :: MiniPage t -> t width (MiniPage _ _ w) = w @@ -67,37 +88,53 @@                  deriving (Show,Eq,Ord) makeLenses ''IpeSymbol -type instance NumType (IpeSymbol r) = r+type instance NumType   (IpeSymbol r) = r+type instance Dimension (IpeSymbol r) = 2 +instance Num r => IsTransformable (IpeSymbol r) where+  transformBy t = over symbolPoint (transformBy t) ++ -- | Example of an IpeSymbol. I.e. A symbol that expresses that the size is 'large'-sizeSymbol :: SymbolAttribute Int Size-sizeSymbol = SymbolAttribute . IpeSize $ Named "large"+-- sizeSymbol :: Attributes (AttrMapSym1 r) (SymbolAttributes r)+-- sizeSymbol = attr SSize (IpeSize $ Named "large")  -------------------------------------------------------------------------------- -- | Paths  -- | Paths consist of Path Segments. PathSegments come in the following forms: data PathSegment r = PolyLineSegment        (PolyLine 2 () r)+                   | PolygonPath            (SimplePolygon () r)                      -- TODO-                   | PolygonPath                    | CubicBezierSegment     -- (CubicBezier 2 r)                    | QuadraticBezierSegment -- (QuadraticBezier 2 r)                    | EllipseSegment (Matrix 3 3 r)                    | ArcSegment                    | SplineSegment          -- (Spline 2 r)                    | ClosedSplineSegment    -- (ClosedSpline 2 r)-                   deriving (Show,Eq,Ord)+                   deriving (Show,Eq) makePrisms ''PathSegment +type instance NumType   (PathSegment r) = r+type instance Dimension (PathSegment r) = 2++instance Num r => IsTransformable (PathSegment r) where+  transformBy t (PolyLineSegment p) = PolyLineSegment $ transformBy t p+  transformBy t (PolygonPath p)     = PolygonPath $ transformBy t p+  transformBy _ _                   = error "transformBy: not implemented yet"++ -- | A path is a non-empty sequence of PathSegments. newtype Path r = Path { _pathSegments :: S2.ViewL1 (PathSegment r) }-                 deriving (Show,Eq,Ord)+                 deriving (Show,Eq) makeLenses ''Path --type instance NumType (Path r) = r+type instance NumType   (Path r) = r+type instance Dimension (Path r) = 2 +instance Num r => IsTransformable (Path r) where+  transformBy t (Path s) = Path $ fmap (transformBy t) s  -- | type that represents a path in ipe. data Operation r = MoveTo (Point 2 r)@@ -112,236 +149,264 @@                  deriving (Eq, Show) makePrisms ''Operation - ----------------------------------------------------------------------------------- | Group Attributes+-- * Attribute Mapping --- | Now that we know what a Path is we can define the Attributes of a Group.-type family GroupAttrElf (s :: GroupAttributeUniverse) (r :: *) :: * where-  GroupAttrElf Clip r = Path r -- strictly we event want this to be a closed path I guess -newtype GroupAttribute r s = GroupAttribute (GroupAttrElf s r)+-- | The mapping between the labels of the the attributes and the types of the+-- attributes with these labels. For example, the 'Matrix' label/attribute should+-- have a value of type 'Matrix 3 3 r'.+type family AttrMap (r :: *) (l :: AttributeUniverse) :: * where+  AttrMap r 'Layer          = LayerName+  AttrMap r AT.Matrix       = Matrix 3 3 r+  AttrMap r Pin             = PinType+  AttrMap r Transformations = TransformationTypes ------------------------------------------------------------------------------------ | Groups+  AttrMap r Stroke = IpeColor+  AttrMap r Pen    = IpePen r+  AttrMap r Fill   = IpeColor+  AttrMap r Size   = IpeSize r --- | To define groups, we need some poly kinded, type-level only, 2-tuples.-data (a :: ka) :.: (b :: kb)+  AttrMap r Dash     = IpeDash r+  AttrMap r LineCap  = Int+  AttrMap r LineJoin = Int+  AttrMap r FillRule = FillType+  AttrMap r Arrow    = IpeArrow r+  AttrMap r RArrow   = IpeArrow r+  AttrMap r Opacity  = IpeOpacity+  AttrMap r Tiling   = IpeTiling+  AttrMap r Gradient = IpeGradient --- | An IpeGroup can store IpeObjects. We distinguish the following different--- ipeObjects. The parameter t will cary additional information about the--- particular object. In particular, we will use it to keep track of the--- attributes each item has.------ Note: We will use this type on the type-level only! In particular, we will--- use it as a Label in a Vinyl Rec.-data IpeObjectType t = IpeGroup     t-                     | IpeImage     t-                     | IpeTextLabel t-                     | IpeMiniPage  t-                     | IpeUse       t-                     | IpePath      t-                     deriving (Show,Read,Eq)+  AttrMap r Clip = Path r -- strictly we event want this to be a closed path I guess --- | A group is essentially a hetrogenious list of IpeObjects. We represent a--- group by means of a Vinyl Rec.-type Group gt r = Rec (IpeObject r) gt+genDefunSymbols [''AttrMap] -type instance NumType (Group gt r) = r --- | This type family links each 'IpeObjectType' to the type (in Haskell) that--- we use to represent such an IpeObject. In principle we represent each object--- by means of an Ext (:+), in which the 'core' is one of the previously seen types--- (i.e. an Image, TextLabel, IpeSymbol, Path, etc), and the extra is a Vinyl record--- storing the attributes.------ The different ipe types use a different Universe to draw the labels form, to--- make sure that i.e. a Path only has attributes applicable to a Path.------ We also see the parameter of the IpeObjectType here: in all but the group case it is--- a type level list that tells which attributes the object has. In case of a group it is a--- poly-kinded pair (i.e. a `gt :.: gs`)  where the gt is a type level list that captures--- *ALL* type information of the objects stored in this group, and the *gs* is a type level--- list that specifies which attributes this group itself has.-type IpeObjectElF r (f :: IpeObjectType k) = IpeObjectValueElF r f :+ IpeObjectAttrElF r f+--------------------------------------------------------------------------------+-- | Groups and Objects -type family IpeObjectValueElF r (f :: IpeObjectType k) :: * where-  IpeObjectValueElF r (IpeGroup (gt :.: gs)) = Group gt r-  IpeObjectValueElF r (IpeImage is)          = Image r-  IpeObjectValueElF r (IpeTextLabel ts)      = TextLabel r-  IpeObjectValueElF r (IpeMiniPage mps)      = MiniPage r-  IpeObjectValueElF r (IpeUse  ss)           = IpeSymbol r-  IpeObjectValueElF r (IpePath ps)           = Path r+--------------------------------------------------------------------------------+-- | Group Attributes +-- -- | Now that we know what a Path is we can define the Attributes of a Group.+-- type family GroupAttrElf (r :: *) (s :: GroupAttributeUniverse) :: * where+--   GroupAttrElf r Clip = Path r -- strictly we event want this to be a closed path I guess -type family RevIpeObjectValueElF (t :: *) :: (k -> IpeObjectType k) where-  RevIpeObjectValueElF (Group gt r)   = IpeGroup-  RevIpeObjectValueElF (Image r)      = IpeImage-  RevIpeObjectValueElF (TextLabel r)  = IpeTextLabel-  RevIpeObjectValueElF (MiniPage r)   = IpeMiniPage-  RevIpeObjectValueElF (IpeSymbol r ) = IpeUse-  RevIpeObjectValueElF (Path r)       = IpePath+-- genDefunSymbols [''GroupAttrElf] +-- type GroupAttributes r = Attributes (GroupAttrElfSym1 r) '[ 'Clip]  +-- | A group is essentially a list of IpeObjects.+newtype Group r = Group { _groupItems :: [IpeObject r] }+                  deriving (Show,Eq) -type family IpeObjectAttrElF r (f :: IpeObjectType k) :: * where-  IpeObjectAttrElF r (IpeGroup (gt :.: gs)) = Rec (GroupAttribute     r) gs-  IpeObjectAttrElF r (IpeImage is)          = Rec (CommonAttribute    r) is-  IpeObjectAttrElF r (IpeTextLabel ts)      = Rec (TextLabelAttribute r) ts-  IpeObjectAttrElF r (IpeMiniPage mps)      = Rec (MiniPageAttribute  r) mps-  IpeObjectAttrElF r (IpeUse  ss)           = Rec (SymbolAttribute    r) ss-  IpeObjectAttrElF r (IpePath ps)           = Rec (PathAttribute      r) ps+type instance NumType   (Group r) = r+type instance Dimension (Group r) = 2 +instance Num r => IsTransformable (Group r) where+  transformBy t (Group s) = Group $ fmap (transformBy t) s  -type family IpeObjectAttrFunctorElF (f :: IpeObjectType k) :: (* -> u -> *) where-  IpeObjectAttrFunctorElF (IpeGroup (gt :.: gs)) = GroupAttribute-  IpeObjectAttrFunctorElF (IpeImage is)          = CommonAttribute-  IpeObjectAttrFunctorElF (IpeTextLabel ts)      = TextLabelAttribute-  IpeObjectAttrFunctorElF (IpeMiniPage mps)      = MiniPageAttribute-  IpeObjectAttrFunctorElF (IpeUse  ss)           = SymbolAttribute-  IpeObjectAttrFunctorElF (IpePath ps)           = PathAttribute+type family AttributesOf (t :: * -> *) :: [u] where+  AttributesOf Group     = GroupAttributes+  AttributesOf Image     = CommonAttributes+  AttributesOf TextLabel = CommonAttributes+  AttributesOf MiniPage  = CommonAttributes+  AttributesOf IpeSymbol = SymbolAttributes+  AttributesOf Path      = PathAttributes  +-- | Attributes' :: * -> [AttributeUniverse] -> *+type Attributes' r = Attributes (AttrMapSym1 r) --- TODO: Maybe split this TF into two TFS' one that determines the core type, the other--- that gives the Attribute wrapper type--- It would be nice if we could tell taht IpeObjecTELF was injective ...+type IpeAttributes g r = Attributes' r (AttributesOf g) --- | An ipe Object is then simply a thin wrapper around the IpeObjectELF type family.-newtype IpeObject r (fld :: IpeObjectType k) =-  IpeObject { _ipeObject :: IpeObjectElF r fld } -makeLenses ''IpeObject+-- | An IpeObject' is essentially the oject ogether with its attributes+type IpeObject' g r = g r :+ IpeAttributes g r -type instance NumType (IpeObject r t) = r+attributes :: Lens' (IpeObject' g r) (IpeAttributes g r)+attributes = extra ---------------------------------------------------------------------------------+data IpeObject r =+    IpeGroup     (IpeObject' Group     r)+  | IpeImage     (IpeObject' Image     r)+  | IpeTextLabel (IpeObject' TextLabel r)+  | IpeMiniPage  (IpeObject' MiniPage  r)+  | IpeUse       (IpeObject' IpeSymbol r)+  | IpePath      (IpeObject' Path      r)  -symb'' :: IpeObjectElF Int (IpeUse '[Size])-symb'' = Symbol origin "myLargesymbol"  :+ ( sizeSymbol :& RNil )+deriving instance (Show r) => Show (IpeObject r)+deriving instance (Eq r)   => Eq   (IpeObject r) -symb :: IpeObjectElF Int (IpeUse ('[] :: [SymbolAttributeUniverse]))-symb = Symbol origin "foo" :+ RNil+type instance NumType   (IpeObject r) = r+type instance Dimension (IpeObject r) = 2 -symb' :: IpeObject Int (IpeUse '[Size])-symb' = IpeObject symb''+makePrisms ''IpeObject+makeLenses ''Group -gr :: Group '[IpeUse '[Size]] Int-gr = symb' :& RNil+class ToObject i where+  ipeObject' :: i r -> IpeAttributes i r -> IpeObject r -grr :: IpeObjectElF Int (IpeGroup ('[IpeUse '[Size]]-                                   :.:-                                   ('[] :: [GroupAttributeUniverse])-                                  )-                        )-grr = gr :+ RNil+instance ToObject Group      where ipeObject' g a = IpeGroup     (g :+ a)+instance ToObject Image      where ipeObject' p a = IpeImage     (p :+ a)+instance ToObject TextLabel  where ipeObject' p a = IpeTextLabel (p :+ a)+instance ToObject MiniPage   where ipeObject' p a = IpeMiniPage  (p :+ a)+instance ToObject IpeSymbol  where ipeObject' s a = IpeUse       (s :+ a)+instance ToObject Path       where ipeObject' p a = IpePath      (p :+ a) +instance Num r => IsTransformable (IpeObject r) where+  transformBy t (IpeGroup i)     = IpeGroup     $ i&core %~ transformBy t+  transformBy t (IpeImage i)     = IpeImage     $ i&core %~ transformBy t+  transformBy t (IpeTextLabel i) = IpeTextLabel $ i&core %~ transformBy t+  transformBy t (IpeMiniPage i)  = IpeMiniPage  $ i&core %~ transformBy t+  transformBy t (IpeUse i)       = IpeUse       $ i&core %~ transformBy t+  transformBy t (IpePath i)      = IpePath      $ i&core %~ transformBy t -grrr :: IpeObject Int (IpeGroup ('[IpeUse '[Size]] :.:-                                      ('[] :: [GroupAttributeUniverse])-                                )-                      )-grrr = IpeObject grr  -points' :: forall gt r. Group gt r -> [Point 2 r]-points' = fmap (^.ipeObject.core.symbolPoint) . filterRec' -filterRec' :: forall gt r fld. (fld ~ IpeUse '[Size]) =>-              Rec (IpeObject r) gt -> [IpeObject r fld]-filterRec' = undefined--- filterRec' = filterRec (Proxy :: Proxy fld)--+commonAttributes :: Lens' (IpeObject r) (Attributes (AttrMapSym1 r) CommonAttributes)+commonAttributes = lens (Attrs . g) (\x (Attrs a) -> s x a)+  where+    select :: (CommonAttributes ⊆ AttributesOf g) =>+              Lens' (IpeObject' g r) (Rec (Attr (AttrMapSym1 r)) CommonAttributes)+    select = attributes.unAttrs.rsubset +    g (IpeGroup i)     = i^.select+    g (IpeImage i)     = i^.select+    g (IpeTextLabel i) = i^.select+    g (IpeMiniPage i)  = i^.select+    g (IpeUse i)       = i^.select+    g (IpePath i)      = i^.select +    s (IpeGroup i)     a = IpeGroup     $ i&select .~ a+    s (IpeImage i)     a = IpeImage     $ i&select .~ a+    s (IpeTextLabel i) a = IpeTextLabel $ i&select .~ a+    s (IpeMiniPage i)  a = IpeMiniPage  $ i&select .~ a+    s (IpeUse i)       a = IpeUse       $ i&select .~ a+    s (IpePath i)      a = IpePath      $ i&select .~ a  --------------------------------------------------------------------------------  --type XmlTree = Text---newtype Layer = Layer {_layerName :: Text } deriving (Show,Read,Eq,Ord,IsString)-- -- | The definition of a view -- make active layer into an index ?-data View = View { _layerNames      :: [Layer]-                 , _activeLayer     :: Layer+data View = View { _layerNames      :: [LayerName]+                 , _activeLayer     :: LayerName                  }           deriving (Eq, Ord, Show) makeLenses ''View +-- instance Default + -- | for now we pretty much ignore these data IpeStyle = IpeStyle { _styleName :: Maybe Text-                         , _styleData :: XmlTree+                         , _styleData :: Node Text Text                          }-              deriving (Eq,Show,Read,Ord)+              deriving (Eq,Show) makeLenses ''IpeStyle ++basicIpeStyle :: IpeStyle+basicIpeStyle = IpeStyle (Just "basic") (xmlLiteral [litFile|resources/basic.isy|])++ -- | The maybe string is the encoding data IpePreamble  = IpePreamble { _encoding     :: Maybe Text-                                , _preambleData :: XmlTree+                                , _preambleData :: Text                                 }                   deriving (Eq,Read,Show,Ord) makeLenses ''IpePreamble -type IpeBitmap = XmlTree+type IpeBitmap = Text    -------------------------------------------------------------------------------- -- Ipe Pages ------ -- | An IpePage is essentially a Group, together with a list of layers and a -- list of views.-data IpePage gs r = IpePage { _layers :: [Layer]-                            , _views  :: [View]-                            , _pages  :: Group gs r-                            }-              -- deriving (Eq, Show)+data IpePage r = IpePage { _layers  :: [LayerName]+                         , _views   :: [View]+                         , _content :: [IpeObject r]+                         }+              deriving (Eq,Show) makeLenses ''IpePage +-- | Creates a simple page with no views.+fromContent     :: [IpeObject r] -> IpePage r+fromContent obs = IpePage layers' [] obs+  where+    layers' = mapMaybe (^.commonAttributes.attrLens SLayer) obs +-- | A complete ipe file+data IpeFile r = IpeFile { _preamble :: Maybe IpePreamble+                         , _styles   :: [IpeStyle]+                         , _pages    :: NE.NonEmpty (IpePage r)+                         }+               deriving (Eq,Show)+makeLenses ''IpeFile +-- | Convenience function to construct an ipe file consisting of a single page.+singlePageFile   :: IpePage r -> IpeFile r+singlePageFile p = IpeFile Nothing [basicIpeStyle] (p NE.:| []) +-- | Create a single page ipe file from a list of IpeObjects+singlePageFromContent :: [IpeObject r] -> IpeFile r+singlePageFromContent = singlePageFile . fromContent --- pGr :: IpePage '[IpeUse '[Size]] Int-pGr = IpePage [] [] gr +-------------------------------------------------------------------------------- +-- | Takes and applies the ipe Matrix attribute of this item.+applyMatrix'              :: ( IsTransformable (i r)+                             , AT.Matrix ∈ AttributesOf i+                             , Dimension (i r) ~ 2, r ~ NumType (i r))+                          => IpeObject' i r -> IpeObject' i r+applyMatrix' o@(i :+ ats) = maybe o (\m -> transformBy (Transformation m) i :+ ats') mm+  where+    (mm,ats') = takeAttr (Proxy :: Proxy AT.Matrix) ats +-- | Applies the matrix to an ipe object if it has one.+applyMatrix                  :: Num r => IpeObject r -> IpeObject r+applyMatrix (IpeGroup i)     = IpeGroup . applyMatrix'+                             $ i&core.groupItems.traverse %~ applyMatrix+                             -- note that for a group we first (recursively)+                             -- apply the matrices, and then apply+                             -- the matrix of the group to its members.+applyMatrix (IpeImage i)     = IpeImage     $ applyMatrix' i+applyMatrix (IpeTextLabel i) = IpeTextLabel $ applyMatrix' i+applyMatrix (IpeMiniPage i)  = IpeMiniPage  $ applyMatrix' i+applyMatrix (IpeUse i)       = IpeUse       $ applyMatrix' i+applyMatrix (IpePath i)      = IpePath      $ applyMatrix' i -newtype Page r gs = Page { _unP :: IpePage gs r }-makeLenses ''Page+applyMatrices   :: Num r => IpeFile r -> IpeFile r+applyMatrices f = f&pages.traverse %~ applyMatricesPage +applyMatricesPage   :: Num r => IpePage r -> IpePage r+applyMatricesPage p = p&content.traverse %~ applyMatrix -ppGr = Page pGr -type IpePages gss r = Rec (Page r) gss-+--------------------------------------------------------------------------------  --- | A complete ipe file-data IpeFile gs r = IpeFile { _preamble :: Maybe IpePreamble-                            , _styles   :: [IpeStyle]-                            , _ipePages :: IpePages gs r-                            }-                  -- deriving (Eq,Show)---- ifP :: IpeFile '[ '[IpeUse '[Size]]] Int-ifP = IpeFile Nothing [] (ppGr :& RNil)+-- -- | Access a path as if it was a PolyLine+-- _PolyLine :: Prism' (IpeObject' Path r)+--                     (PolyLine 2 () r :+ IpeAttributes Path r)+-- _PolyLine = prism' build' access+--   where+--     build'  p         = p&core %~ Path . S2.l1Singleton . PolyLineSegment+--     access ~(p :+ a) = (:+ a) <$> p^?pathSegments.S2.headL1._PolyLineSegment -makeLenses ''IpeFile+-- -- | Access a path as if it was a SimplePolygon+-- _SimplePolygon :: Prism' (IpeObject' Path r)+--                          (SimplePolygon () r :+ IpeAttributes Path r)+-- _SimplePolygon = prism' build' access+--   where+--     build'  p         = p&core %~ Path . S2.l1Singleton . PolygonPath+--     access ~(p :+ a) = (:+ a) <$> p^?pathSegments.S2.headL1._PolygonPath
src/Data/Geometry/Ipe/Writer.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-}@@ -6,32 +7,37 @@ module Data.Geometry.Ipe.Writer where  import           Control.Applicative hiding (Const(..))-import           Control.Lens((^.),(^..),(.~),(&), Prism', (#))+import           Control.Lens((^.),(^..),(.~),(&), to) import           Data.Ext+import           Data.Fixed import qualified Data.Foldable as F import           Data.Geometry.Ipe.Types import qualified Data.Geometry.Ipe.Types as IT import           Data.Geometry.LineSegment import           Data.Geometry.PolyLine+import           Data.Geometry.Polygon(SimplePolygon, outerBoundary) import qualified Data.Geometry.Transformation as GT import           Data.Geometry.Point+import           Data.Geometry.Box import           Data.Geometry.Vector import           Data.Maybe(catMaybes, mapMaybe, fromMaybe)-import           Data.Monoid+import           Data.Ratio+import           Data.Semigroup import           Data.Proxy import qualified Data.Traversable as Tr import           Data.Vinyl import           Data.Vinyl.Functor import           Data.Vinyl.TypeLevel-+import           Data.Singletons+import qualified Data.Geometry.Ipe.Attributes as IA import           Data.Geometry.Ipe.Attributes-import           GHC.Exts  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import           Data.List(nub) import qualified Data.Seq2     as S2 import           Data.Text(Text)+import qualified Data.Text as Text  import           Text.XML.Expat.Tree import           Text.XML.Expat.Format(format')@@ -44,17 +50,21 @@  -- | Given a prism to convert something of type g into an ipe file, a file path, -- and a g. Convert the geometry and write it to file.-writeIpe        :: ( RecAll (Page r) gs IpeWrite-                   , IpeWriteText r-                   ) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO ()-writeIpe p fp g = writeIpeFile (p # g) fp +-- writeIpe        :: ( RecAll (Page r) gs IpeWrite+--                    , IpeWriteText r+--                    ) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO ()+-- writeIpe p fp g = writeIpeFile (p # g) fp+ -- | Write an IpeFiele to file.-writeIpeFile :: ( RecAll (Page r) gs IpeWrite-                , IpeWriteText r-                ) => IpeFile gs r -> FilePath -> IO ()-writeIpeFile = writeIpeFile'+writeIpeFile :: IpeWriteText r => FilePath -> IpeFile r -> IO ()+writeIpeFile = flip writeIpeFile' +-- | Creates a single page ipe file with the given page+writeIpePage    :: IpeWriteText r => FilePath -> IpePage r -> IO ()+writeIpePage fp = writeIpeFile fp . singlePageFile++ -- | Convert the input to ipeXml, and prints it to standard out in such a way -- that the copied text can be pasted into ipe as a geometry object. printAsIpeSelection :: IpeWrite t => t -> IO ()@@ -92,49 +102,24 @@   ipeWrite :: t -> Maybe (Node Text Text)  --- | Ipe write for Exts-ipeWriteExt             :: ( IpeWrite t-                           , RecAll a as IpeWriteText, AllSatisfy IpeAttrName as-                           ) => t :+ Rec a as -> Maybe (Node Text Text)-ipeWriteExt (x :+ arec) = ipeWrite x `mAddAtts` ipeWriteAttrs arec----- | For the types representing attribute values we can get the name/key to use--- when serializing to ipe.-class IpeAttrName a where-  attrName :: Proxy a -> Text---type Attr = (Text,Text)+instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where+  ipeWriteText att = _getAttr att >>= ipeWriteText  -- | Functon to write all attributes in a Rec-ipeWriteAttrs :: ( RecAll f rs IpeWriteText-                 , AllSatisfy IpeAttrName rs-                 ) => Rec f rs -> [Attr]-ipeWriteAttrs rs = mapMaybe (\(x,my) -> (x,) <$> my) $ zip (writeAttrNames  rs)-                                                           (writeAttrValues rs)-+ipeWriteAttrs           :: ( AllSatisfy IpeAttrName rs+                           , RecAll (Attr f) rs IpeWriteText+                           ) => IA.Attributes f rs -> [(Text,Text)]+ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames  r)+                                                                   (writeAttrValues r)+  where+    f (Const n) (Const mv) = Const $ (n,) <$> mv  -- | Writing the attribute values-writeAttrValues :: RecAll f rs IpeWriteText => Rec f rs -> [Maybe Text]-writeAttrValues = recordToList-                . rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x)+writeAttrValues :: RecAll f rs IpeWriteText => Rec f rs -> Rec (Const (Maybe Text)) rs+writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x)                 . reifyConstraint (Proxy :: Proxy IpeWriteText) --- | Writing Attribute names-writeAttrNames           :: AllSatisfy IpeAttrName rs => Rec f rs -> [Text]-writeAttrNames RNil      = []-writeAttrNames (x :& xs) = write'' x : writeAttrNames xs-  where-    write''   :: forall f s. IpeAttrName s => f s -> Text-    write'' _ = attrName (Proxy :: Proxy s) --- | Function that states that all elements in xs satisfy a given constraint c-type family AllSatisfy (c :: k -> Constraint) (xs :: [k]) :: Constraint where-  AllSatisfy c '[] = ()-  AllSatisfy c (x ': xs) = (c x, AllSatisfy c xs)-- instance IpeWriteText Text where   ipeWriteText = Just @@ -155,12 +140,19 @@ instance IpeWriteText Int where   ipeWriteText = writeByShow +instance HasResolution p => IpeWriteText (Fixed p) where+  ipeWriteText = writeByShow +-- | This instance converts the ratio to a Pico, and then displays that.+instance Integral a => IpeWriteText (Ratio a) where+  ipeWriteText = ipeWriteText . f . fromRational . toRational+    where+      f :: Pico -> Pico+      f = id+ writeByShow :: Show t => t -> Maybe Text writeByShow = ipeWriteText . T.pack . show -- unwords' :: [Maybe Text] -> Maybe Text unwords' = fmap T.unwords . sequence @@ -178,10 +170,43 @@   ipeWriteText (Named t)  = ipeWriteText t   ipeWriteText (Valued v) = ipeWriteText v +instance IpeWriteText TransformationTypes where+  ipeWriteText Affine       = Just "affine"+  ipeWriteText Rigid        = Just "rigid"+  ipeWriteText Translations = Just "translations"++instance IpeWriteText PinType where+  ipeWriteText No         = Nothing+  ipeWriteText Yes        = Just "yes"+  ipeWriteText Horizontal = Just "h"+  ipeWriteText Vertical   = Just "v"+ deriving instance IpeWriteText r => IpeWriteText (IpeSize  r) deriving instance IpeWriteText r => IpeWriteText (IpePen   r) deriving instance IpeWriteText IpeColor +instance IpeWriteText r => IpeWriteText (IpeDash r) where+  ipeWriteText (DashNamed t) = Just t+  ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "["+                                                      , Text.intercalate " " ts+                                                      , "] ", t ])+                                    <$> Tr.mapM ipeWriteText xs+                                    <*> ipeWriteText x++instance IpeWriteText FillType where+  ipeWriteText Wind   = Just "wind"+  ipeWriteText EOFill = Just "eofill"++instance IpeWriteText r => IpeWriteText (IpeArrow r) where+  ipeWriteText (IpeArrow n s) = (\n' s' -> n' <> "/" <> s') <$> ipeWriteText n+                                                            <*> ipeWriteText s++instance IpeWriteText r => IpeWriteText (Path r) where+  ipeWriteText = fmap concat' . Tr.sequence . fmap ipeWriteText . _pathSegments+    where+      concat' = F.foldr1 (\t t' -> t <> "\n" <> t')++ -------------------------------------------------------------------------------- instance IpeWriteText r => IpeWrite (IpeSymbol r) where   ipeWrite (Symbol p n) = f <$> ipeWriteText p@@ -190,39 +215,11 @@                            , ("name", n)                            ] [] -instance IpeWriteText (SymbolAttrElf rs r) => IpeWriteText (SymbolAttribute r rs) where-  ipeWriteText (SymbolAttribute x) = ipeWriteText x+-- instance IpeWriteText (SymbolAttrElf rs r) => IpeWriteText (SymbolAttribute r rs) where+--   ipeWriteText (SymbolAttribute x) = ipeWriteText x  --- CommonAttributeUnivers-instance IpeAttrName Layer           where attrName _ = "layer"-instance IpeAttrName Matrix          where attrName _ = "matrix"-instance IpeAttrName Pin             where attrName _ = "pin"-instance IpeAttrName Transformations where attrName _ = "transformations" --- IpeSymbolAttributeUniversre-instance IpeAttrName SymbolStroke where attrName _ = "stroke"-instance IpeAttrName SymbolFill   where attrName _ = "fill"-instance IpeAttrName SymbolPen    where attrName _ = "pen"-instance IpeAttrName Size         where attrName _ = "size"---- PathAttributeUniverse-instance IpeAttrName Stroke     where attrName _ = "stroke"-instance IpeAttrName Fill       where attrName _ = "fill"-instance IpeAttrName Dash       where attrName _ = "dash"-instance IpeAttrName Pen        where attrName _ = "pen"-instance IpeAttrName LineCap    where attrName _ = "cap"-instance IpeAttrName LineJoin   where attrName _ = "join"-instance IpeAttrName FillRule   where attrName _ = "fillrule"-instance IpeAttrName Arrow      where attrName _ = "arrow"-instance IpeAttrName RArrow     where attrName _ = "rarrow"-instance IpeAttrName Opacity    where attrName _ = "opacity"-instance IpeAttrName Tiling     where attrName _ = "tiling"-instance IpeAttrName Gradient   where attrName _ = "gradient"---- GroupAttributeUniverse-instance IpeAttrName Clip     where attrName _ = "clip"- --------------------------------------------------------------------------------  instance IpeWriteText r => IpeWriteText (GT.Matrix 3 3 r) where@@ -251,53 +248,92 @@     (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest     -- the polyline type guarantees that there is at least one point +instance IpeWriteText r => IpeWriteText (SimplePolygon () r) where+  ipeWriteText pg = case pg^..outerBoundary.to F.toList.Tr.traverse.core of+    (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest ++ [ClosePath]+    _          -> Nothing+    -- TODO: We are not really guaranteed that there is at least one point, it would+    -- be nice if the type could guarantee that.  instance IpeWriteText r => IpeWriteText (PathSegment r) where   ipeWriteText (PolyLineSegment p) = ipeWriteText p+  ipeWriteText (PolygonPath     p) = ipeWriteText p   ipeWriteText (EllipseSegment  m) = ipeWriteText $ Ellipse m -instance IpeWriteText (PathAttrElf rs r) => IpeWriteText (PathAttribute r rs) where-  ipeWriteText (PathAttribute x) = ipeWriteText x- instance IpeWriteText r => IpeWrite (Path r) where-  ipeWrite (Path segs) = (\t -> Element "path" [] [Text t]) <$> mt-    where-      concat' = F.foldr1 (\t t' -> t <> "\n" <> t')-      mt      = fmap concat' . Tr.sequence . fmap ipeWriteText $ segs+  ipeWrite p = (\t -> Element "path" [] [Text t]) <$> ipeWriteText p  --------------------------------------------------------------------------------  -instance ( IpeObjectElF r fld  ~ (g :+ Rec f ats)+instance (IpeWriteText r) => IpeWrite (Group r) where+  ipeWrite (Group gs) = case mapMaybe ipeWrite gs of+                          [] -> Nothing+                          ns -> (Just $ Element "group" [] ns)+++instance ( AllSatisfy IpeAttrName rs+         , RecAll (Attr f) rs IpeWriteText          , IpeWrite g-         , RecAll f ats IpeWriteText, AllSatisfy IpeAttrName ats-         ) => IpeWrite (IpeObject r fld) where-  ipeWrite (IpeObject (g :+ ats)) = ipeWrite g `mAddAtts` ipeWriteAttrs ats+         ) => IpeWrite (g :+ IA.Attributes f rs) where+  ipeWrite (g :+ ats) = ipeWrite g `mAddAtts` ipeWriteAttrs ats  +instance IpeWriteText r => IpeWrite (MiniPage r) where+  ipeWrite (MiniPage t p w) = (\pt wt ->+                              Element "text" [ ("pos", pt)+                                             , ("type", "minipage")+                                             , ("width", wt)+                                             ] [Text t]+                              ) <$> ipeWriteText p+                                <*> ipeWriteText w++instance IpeWriteText r => IpeWrite (Image r) where+  ipeWrite (Image d (Box a b)) = (\dt p q ->+                                   Element "image" [("rect", p <> " " <> q)] [Text dt]+                                 )+                               <$> ipeWriteText d+                               <*> ipeWriteText (a^.core.(to getMin))+                               <*> ipeWriteText (b^.core.(to getMax))++-- TODO: Replace this one with s.t. that writes the actual image payload+instance IpeWriteText () where+  ipeWriteText () = Nothing++instance IpeWriteText r => IpeWrite (TextLabel r) where+  ipeWrite (Label t p) = (\pt ->+                         Element "text" [("pos", pt)+                                        ,("type", "label")+                                        ] [Text t]+                         ) <$> ipeWriteText p+++instance (IpeWriteText r) => IpeWrite (IpeObject r) where+    ipeWrite (IpeGroup     g) = ipeWrite g+    ipeWrite (IpeImage     i) = ipeWrite i+    ipeWrite (IpeTextLabel l) = ipeWrite l+    ipeWrite (IpeMiniPage  m) = ipeWrite m+    ipeWrite (IpeUse       s) = ipeWrite s+    ipeWrite (IpePath      p) = ipeWrite p++ ipeWriteRec :: RecAll f rs IpeWrite => Rec f rs -> [Node Text Text] ipeWriteRec = catMaybes . recordToList             . rmap (\(Compose (Dict x)) -> Const $ ipeWrite x)             . reifyConstraint (Proxy :: Proxy IpeWrite) -instance RecAll (IpeObject r) gt IpeWrite => IpeWrite (Group gt r) where-  -- basically the same implementation as ipeWriteAttrs: convert the rec to a Rec Const-  -- then turn that into a list. If the list is non-empty we construct a new group element.-  ipeWrite = fmap (Element "group" [])-           . wrap . ipeWriteRec-    where-      wrap [] = Nothing-      wrap xs = Just xs -instance IpeWriteText (GroupAttrElf rs r) => IpeWriteText (GroupAttribute r rs) where-  ipeWriteText (GroupAttribute x) = ipeWriteText x+-- instance IpeWriteText (GroupAttrElf rs r) => IpeWriteText (GroupAttribute r rs) where+--   ipeWriteText (GroupAttribute x) = ipeWriteText x   -------------------------------------------------------------------------------- -instance IpeWrite IT.Layer where-  ipeWrite (IT.Layer l) = Just $ Element "layer" [("name", l)] []+deriving instance IpeWriteText LayerName +instance IpeWrite LayerName where+  ipeWrite (LayerName n) = Just $ Element "layer" [("name",n)] []+ instance IpeWrite View where   ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls)                                                   , ("active", _layerName act)@@ -305,41 +341,36 @@     where       ls = T.unwords .  map _layerName $ lrs -instance IpeWrite (Group gs r) => IpeWrite (IpePage gs r) where-  ipeWrite (IpePage lrs vs pgs) = Just . Element "page" [] . catMaybes . concat $+instance (IpeWriteText r)  => IpeWrite (IpePage r) where+  ipeWrite (IpePage lrs vs objs) = Just .+                                  Element "page" [] . catMaybes . concat $                                   [ map ipeWrite lrs                                   , map ipeWrite vs-                                  , [ipeWrite pgs]+                                  , map ipeWrite objs                                   ] -instance RecAll (Page r) gs IpeWrite => IpeWrite (IpeFile gs r) where-  ipeWrite (IpeFile p s pgs) = Just $ Element "ipe" ipeAtts chs-    where-    ipeAtts = [("version","70005"),("creator", "HGeometry")]-    -- TODO: Add preamble and styles-    chs = ipeWriteRec pgs +instance IpeWrite IpeStyle where+  ipeWrite (IpeStyle _ xml) = Just xml --------------------------------------------------------------------------------- -type Atts = [(Text,Text)]+instance IpeWrite IpePreamble where+  ipeWrite (IpePreamble _ latex) = Just $ Element "preamble" [] [Text latex]+  -- TODO: I probably want to do something with the encoding .... -ipeWritePolyLines     :: IpeWriteText r-                      => [(PolyLine 2 () r, Atts)] -> Node Text Text-ipeWritePolyLines pls = Element "ipe" ipeAtts [Element "page" [] chs]-  where-    chs     = layers pls ++ mapMaybe f pls-    ipeAtts = [("version","70005"),("creator", "HGeometry 0.4.0.0")]+instance (IpeWriteText r) => IpeWrite (IpeFile r) where+  ipeWrite (IpeFile mp ss pgs) = Just $ Element "ipe" ipeAtts chs+    where+      ipeAtts = [("version","70005"),("creator", "HGeometry")]+      chs = mconcat [ catMaybes [mp >>= ipeWrite]+                    , mapMaybe ipeWrite ss+                    , mapMaybe ipeWrite . F.toList $ pgs+                    ] -    f (pl,ats) = ipeWrite (mkPath pl) `mAddAtts` ats-    mkPath     = Path . S2.l1Singleton . PolyLineSegment-    layers     = map mkLayer . nub . mapMaybe (lookup "layer" . snd)-    mkLayer n  = Element "layer" [("name",n)] []  -writePolyLineFile :: IpeWriteText r => FilePath -> [(PolyLine 2 () r, Atts)] -> IO ()-writePolyLineFile fp = B.writeFile fp . format' . ipeWritePolyLines +--------------------------------------------------------------------------------  instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where   ipeWrite p = ipeWrite path@@ -347,11 +378,12 @@       path = fromPolyLine $ p & points.Tr.traverse.extra .~ ()       -- TODO: Do something with the p's +fromPolyLine :: PolyLine 2 () r -> Path r fromPolyLine = Path . S2.l1Singleton . PolyLineSegment   instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where-  ipeWrite (LineSegment p q) = ipeWrite . fromPolyLine . fromPoints . map (^.core) $ [p,q]+  ipeWrite (LineSegment' p q) = ipeWrite . fromPolyLine . fromPoints . map (extra .~ ()) $ [p,q]   instance IpeWrite () where@@ -387,21 +419,17 @@   -testPoly :: PolyLine 2 () Double-testPoly = fromPoints [origin, point2 0 10, point2 10 10, point2 100 100]+-- testPoly :: PolyLine 2 () Double+-- testPoly = fromPoints' [origin, point2 0 10, point2 10 10, point2 100 100]    -testWriteUse :: Maybe (Node Text Text)-testWriteUse = ipeWriteExt sym-  where-    sym :: IpeSymbol Double :+ (Rec (SymbolAttribute Double) [Size, SymbolStroke])-    sym = Symbol origin "mark" :+ (  SymbolAttribute (IpeSize  $ Named "normal")-                                  :& SymbolAttribute (IpeColor $ Named "green")-                                  :& RNil-                                  )----foo = ipeWrite grrr+-- testWriteUse :: Maybe (Node Text Text)+-- testWriteUse = ipeWriteExt sym+--   where+--     sym :: IpeSymbol Double :+ (Rec (SymbolAttribute Double) [Size, SymbolStroke])+--     sym = Symbol origin "mark" :+ (  SymbolAttribute (IpeSize  $ Named "normal")+--                                   :& SymbolAttribute (IpeColor $ Named "green")+--                                   :& RNil+--                                   )
src/Data/Geometry/Line.hs view
@@ -1,11 +1,15 @@-module Data.Geometry.Line(module I+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Geometry.Line( module Data.Geometry.Line.Internal                          ) where -import Data.Geometry.Line.Internal as I+import Data.Geometry.Line.Internal import Data.Geometry.LineSegment-import           Data.Geometry.Transformation-import           Data.Geometry.Vector-+import Data.Geometry.Box+import Data.Geometry.Properties+import Data.Geometry.Point+import Data.Geometry.Boundary+import Data.Geometry.Transformation+import Data.Geometry.Vector  -- | Lines are transformable, via line segments instance (Num r, AlwaysTruePFT d) => IsTransformable (Line d r) where@@ -13,3 +17,23 @@     where       toLineSegment' :: (Num r, Arity d) => Line d r -> LineSegment d () r       toLineSegment' = toLineSegment+++type instance IntersectionOf (Line 2 r) (Boundary (Rectangle p r)) =+  [ NoIntersection, Point 2 r, (Point 2 r, Point 2 r) , LineSegment 2 () r]+++-- instance (Eq r, Fractional r)+--          => (Line 2 r) `IsIntersectableWith` (Boundary (Rectangle p r)) where+--   nonEmptyIntersection = defaultNonEmptyIntersection++--   _    `intersect` (Boundary Empty) = coRec NoIntersection+--   line `intersect` (Boundary rect)  = error "TODO"+--     where+--       (t,r,b,l) = sides' rect++--       ints = map (line `intersect`) [t,r,b,l]+++type instance IntersectionOf (Line 2 r) (Rectangle p r) =+  [ NoIntersection, Point 2 r, LineSegment 2 () r]
src/Data/Geometry/Line/Internal.hs view
@@ -1,21 +1,17 @@-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveFunctor  #-} module Data.Geometry.Line.Internal where -import           Control.Applicative import           Control.Lens-import           Data.Ext import qualified Data.Foldable as F-import           Data.Geometry.Box-import           Data.Geometry.Interval import           Data.Geometry.Point import           Data.Geometry.Properties import           Data.Geometry.Vector-import           Linear.Affine(Affine(..))-import           Linear.Vector((*^))-+import           Data.Ord(comparing)+import qualified Data.Traversable as T+import           Data.Vinyl+import           Frames.CoRec  -------------------------------------------------------------------------------- -- * d-dimensional Lines@@ -27,9 +23,14 @@                      } makeLenses ''Line -deriving instance (Show r, Arity d) => Show    (Line d r)-deriving instance Arity d           => Functor (Line d)+instance (Show r, Arity d) => Show (Line d r) where+  show (Line p v) = concat [ "Line (", show p, ") (", show v, ")" ]+deriving instance (Eq r,   Arity d) => Eq            (Line d r)+deriving instance Arity d           => Functor       (Line d)+deriving instance Arity d           => F.Foldable    (Line d)+deriving instance Arity d           => T.Traversable (Line d) + type instance Dimension (Line d r) = d type instance NumType   (Line d r) = r @@ -45,8 +46,9 @@ horizontalLine   :: Num r => r -> Line 2 r horizontalLine y = Line (point2 0 y) (v2 1 0) -perpendicularTo                          :: Num r => Line 2 r -> Line 2 r-perpendicularTo (Line p (Vector2 vx vy)) = Line p (v2 (-vy) vx)+-- | Given a line l with anchor point p, get the line perpendicular to l that also goes through p.+perpendicularTo                           :: Num r => Line 2 r -> Line 2 r+perpendicularTo (Line p ~(Vector2 vx vy)) = Line p (v2 (-vy) vx)   @@ -83,20 +85,21 @@   -- TODO: Maybe use a specialize pragma for 2D with an implementation using ccw  +-- | The intersection of two lines is either: NoIntersection, a point or a line.+type instance IntersectionOf (Line 2 r) (Line 2 r) = [ NoIntersection+                                                     , Point 2 r+                                                     , Line 2 r+                                                     ]  instance (Eq r, Fractional r) => (Line 2 r) `IsIntersectableWith` (Line 2 r) where -  data Intersection (Line 2 r) (Line 2 r) = SameLine             !(Line 2 r)-                                          | LineLineIntersection !(Point 2 r)-                                          | ParallelLines -- ^ No intersection-                                            deriving (Show) -  nonEmptyIntersection ParallelLines = False-  nonEmptyIntersection _             = True+  nonEmptyIntersection = defaultNonEmptyIntersection -  l@(Line p (Vector2 ux uy)) `intersect` m@(Line q v@(Vector2 vx vy))-      | areParallel = if q `onLine` l then SameLine l else ParallelLines-      | otherwise   = LineLineIntersection r+  l@(Line p ~(Vector2 ux uy)) `intersect` (Line q ~v@(Vector2 vx vy))+      | areParallel = if q `onLine` l then coRec l+                                      else coRec NoIntersection+      | otherwise   = coRec r     where       r = q .+^ alpha *^ v @@ -110,15 +113,19 @@       Point2 px py = p       Point2 qx qy = q -instance (Eq r, Fractional r) => Eq (Intersection (Line 2 r) (Line 2 r)) where-  (SameLine l)             == (SameLine m)             = case (l `intersect` m) of-                                                           SameLine _ -> True-                                                           _          -> False-  (LineLineIntersection p) == (LineLineIntersection q) = p == q-  ParallelLines            == ParallelLines            = True-  _                        == _                        = False+-- | Squared distance from point p to line l+sqDistanceTo   :: (Fractional r, Arity d) => Point d r -> Line d r -> r+sqDistanceTo p = fst . sqDistanceToArg p  +-- | The squared distance between the point p and the line l, and the point m+-- realizing this distance.+sqDistanceToArg              :: (Fractional r, Arity d)+                             => Point d r -> Line d r -> (r, Point d r)+sqDistanceToArg p (Line q v) = let u = q .-. p+                                   t = (-1 * (u `dot` v)) / (v `dot` v)+                                   m = q .+^ (v ^* t)+                               in (qdA m p, m)  -------------------------------------------------------------------------------- -- * Supporting Lines@@ -129,3 +136,57 @@  instance HasSupportingLine (Line d r) where   supportingLine = id++--------------------------------------------------------------------------------+-- * Convenience functions on Two dimensional lines++-- | Create a line from the linear function ax + b+fromLinearFunction     :: Num r => r -> r -> Line 2 r+fromLinearFunction a b = Line (point2 0 b) (v2 1 a)++-- | get values a,b s.t. the input line is described by y = ax + b.+-- returns Nothing if the line is vertical+toLinearFunction                             :: forall r. (Fractional r, Eq r)+                                             => Line 2 r -> Maybe (r,r)+toLinearFunction l@(Line _ ~(Vector2 vx vy)) = match (l `intersect` verticalLine (0 :: r)) $+       (H $ \NoIntersection -> Nothing)    -- l is a vertical line+    :& (H $ \(Point2 _ b)   -> Just (vy / vx,b))+    :& (H $ \_              -> Nothing)    -- l is a vertical line (through x=0)+    :& RNil++-- | Result of a side test+data SideTest = Below | On | Above deriving (Show,Read,Eq,Ord)++-- | Given a point q and a line l, compute to which side of l q lies. For+-- vertical lines the left side of the line is interpeted as below.+--+-- >>> point2 10 10 `onSide` (lineThrough origin $ point2 10 5)+-- Above+-- >>> point2 10 10 `onSide` (lineThrough origin $ point2 (-10) 5)+-- Above+-- >>> point2 5 5 `onSide` (verticalLine 10)+-- Below+-- >>> point2 5 5 `onSide` (lineThrough origin $ point2 (-3) (-3))+-- On+onSide                :: (Ord r, Num r) => Point 2 r -> Line 2 r -> SideTest+q `onSide` (Line p v) = let r    =  p .+^ v+                            f z         = (z^.xCoord, -z^.yCoord)+                            minBy g a b = F.minimumBy (comparing g) [a,b]+                            maxBy g a b = F.maximumBy (comparing g) [a,b]+                        in case ccw (minBy f p r) (maxBy f p r) q of+                          CCW      -> Above+                          CW       -> Below+                          CoLinear -> On++++-- | Test if the query point q lies (strictly) above line l+liesAbove       :: (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool+q `liesAbove` l = q `onSide` l == Above+++-- | Get the bisector between two points+bisector     :: Fractional r => Point 2 r -> Point 2 r -> Line 2 r+bisector p q = let v = q .-. p+                   h = p .+^ (v ^/ 2)+               in perpendicularTo (Line h v)
src/Data/Geometry/LineSegment.hs view
@@ -1,196 +1,265 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor  #-}-module Data.Geometry.LineSegment where+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.Geometry.LineSegment( LineSegment+                                , pattern LineSegment+                                , pattern LineSegment'+                                , pattern ClosedLineSegment +                                , _SubLine+++                                , toLineSegment+                                , onSegment+                                , orderedEndPoints+                                , segmentLength+                                , sqDistanceToSeg, sqDistanceToSegArg+                                , flipSegment+                                ) where++import           Data.Ord(comparing)+import           Control.Arrow((&&&)) import           Control.Applicative import           Control.Lens+import           Data.Bifunctor+import           Data.Semigroup import           Data.Ext-import           Data.Geometry.Box+import           Data.Geometry.Box.Internal import           Data.Geometry.Interval-import           Data.Geometry.Point import           Data.Geometry.Line.Internal+import           Data.Geometry.Point import           Data.Geometry.Properties+import           Data.Geometry.SubLine import           Data.Geometry.Transformation import           Data.Geometry.Vector-import           Linear.Vector((*^))-import           Linear.Affine(Affine(..),distanceA)-import qualified Data.List as L-import           Data.Maybe(maybe)-import           Data.Ord(comparing)-import           Data.Semigroup+import           Data.Range+import           Data.Vinyl+import           Data.UnBounded+import           Frames.CoRec+import qualified Data.Foldable as F  -------------------------------------------------------------------------------- -- * d-dimensional LineSegments + -- | Line segments. LineSegments have a start and end point, both of which may--- contain additional data of type p.-newtype LineSegment d p r = LineSeg { _unLineSeg :: Interval p (Point d r) }-pattern LineSegment s t = LineSeg (Interval s t)+-- contain additional data of type p. We can think of a Line-Segment being defined as+--+--  data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p))+--                                       (EndPoint (Point d r :+ p))+newtype LineSegment d p r = GLineSegment { _unLineSeg :: Interval p (Point d r)} +makeLenses ''LineSegment++-- | Pattern that essentially models the line segment as a:+--+-- data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p))+--                                      (EndPoint (Point d r :+ p))+pattern LineSegment           :: EndPoint (Point d r :+ p)+                              -> EndPoint (Point d r :+ p)+                              -> LineSegment d p r+pattern LineSegment       s t = GLineSegment (Interval s t)++-- | Gets the start and end point, but forgetting if they are open or closed.+pattern LineSegment'          :: Point d r :+ p+                              -> Point d r :+ p+                              -> LineSegment d p r+pattern LineSegment'      s t <- ((^.start) &&& (^.end) -> (s,t))+++pattern ClosedLineSegment     :: Point d r :+ p+                              -> Point d r :+ p+                              -> LineSegment d p r+pattern ClosedLineSegment s t = GLineSegment (ClosedInterval s t)++type instance Dimension (LineSegment d p r) = d+type instance NumType   (LineSegment d p r) = r+ instance HasStart (LineSegment d p r) where   type StartCore  (LineSegment d p r) = Point d r   type StartExtra (LineSegment d p r) = p-  start = lens (_start . _unLineSeg) (\(LineSegment _ t) s -> LineSegment s t)+  start = unLineSeg.start  instance HasEnd (LineSegment d p r) where   type EndCore  (LineSegment d p r) = Point d r   type EndExtra (LineSegment d p r) = p-  end = lens (_end . _unLineSeg) (\(LineSegment s _) t -> LineSegment s t)+  end = unLineSeg.end +_SubLine :: (Fractional r, Eq r, Arity d) => Iso' (LineSegment d p r) (SubLine d p r)+_SubLine = iso segment2SubLine subLineToSegment++segment2SubLine    :: (Fractional r, Eq r, Arity d)+                   => LineSegment d p r -> SubLine d p r+segment2SubLine ss = SubLine l (Interval s e)+  where+    l = supportingLine ss+    f = flip toOffset l+    (Interval p q)  = ss^.unLineSeg++    s = p&unEndPoint.core %~ f+    e = q&unEndPoint.core %~ f++subLineToSegment    :: (Num r, Arity d) => SubLine d p r -> LineSegment d p r+subLineToSegment sl = let (Interval s' e') = (fixEndPoints sl)^.subRange+                          s = s'&unEndPoint %~ (^.extra)+                          e = e'&unEndPoint %~ (^.extra)+                      in LineSegment s e+ instance (Num r, Arity d) => HasSupportingLine (LineSegment d p r) where-  supportingLine (LineSegment (p :+ _) (q :+ _)) = lineThrough p q+  supportingLine s = lineThrough (s^.start.core) (s^.end.core) -deriving instance (Show r, Show p, Arity d) => Show (LineSegment d p r)+instance (Show r, Show p, Arity d) => Show (LineSegment d p r) where+  show ~(LineSegment p q) = concat ["LineSegment (", show p, ") (", show q, ")"]+ deriving instance (Eq r, Eq p, Arity d)     => Eq (LineSegment d p r)-deriving instance (Ord r, Ord p, Arity d)   => Ord (LineSegment d p r)+-- deriving instance (Ord r, Ord p, Arity d)   => Ord (LineSegment d p r) deriving instance Arity d                   => Functor (LineSegment d p)-type instance Dimension (LineSegment d p r) = d-type instance NumType   (LineSegment d p r) = r  instance PointFunctor (LineSegment d p) where-  pmap f (LineSegment s e) = LineSegment (f <$> s) (f <$> e)+  pmap f ~(LineSegment s e) = LineSegment (s&unEndPoint %~ first f)+                                          (e&unEndPoint %~ first f)  instance Arity d => IsBoxable (LineSegment d p r) where-  boundingBox l = boundingBoxList [l^.start.core, l^.end.core]+  boundingBox l = boundingBox (l^.start.core) <> boundingBox (l^.end.core)  instance (Num r, AlwaysTruePFT d) => IsTransformable (LineSegment d p r) where   transformBy = transformPointFunctor ----+instance Arity d => Bifunctor (LineSegment d) where+  bimap f g (GLineSegment i) = GLineSegment $ bimap f (fmap g) i    -- ** Converting between Lines and LineSegments +-- | Directly convert a line into a line segment. toLineSegment            :: (Monoid p, Num r, Arity d) => Line d r -> LineSegment d p r-toLineSegment (Line p v) = LineSegment (p       :+ mempty)-                                       (p .+^ v :+ mempty)+toLineSegment (Line p v) = ClosedLineSegment (p       :+ mempty)+                                             (p .+^ v :+ mempty)  -- *** Intersecting LineSegments +type instance IntersectionOf (LineSegment 2 p r) (LineSegment 2 p r) = [ NoIntersection+                                                                       , Point 2 r+                                                                       , LineSegment 2 p r+                                                                       ]++type instance IntersectionOf (LineSegment 2 p r) (Line 2 r) = [ NoIntersection+                                                              , Point 2 r+                                                              , LineSegment 2 p r+                                                              ]++ instance (Ord r, Fractional r) =>          (LineSegment 2 p r) `IsIntersectableWith` (LineSegment 2 p r) where+  nonEmptyIntersection = defaultNonEmptyIntersection -  data Intersection (LineSegment 2 p r) (LineSegment 2 p r) =-        OverlappingSegment         !(LineSegment 2 p r)-      | LineSegLineSegIntersection !(Point 2 r)-      | NoIntersection-      deriving (Show,Eq)+  a `intersect` b = match ((a^._SubLine) `intersect` (b^._SubLine)) $+         (H coRec)+      :& (H coRec)+      :& (H $ coRec . subLineToSegment)+      :& RNil -  nonEmptyIntersection NoIntersection = False-  nonEmptyIntersection _              = True -  a@(LineSegment p q) `intersect` b@(LineSegment s t) = case la `intersect` lb of-      SameLine _                                ->-          maybe NoIntersection OverlappingSegment $ overlap a b-      LineLineIntersection r | onBothSegments r -> LineSegLineSegIntersection r-      _                                         -> NoIntersection-    where-      la = supportingLine a-      lb = supportingLine b-      onBothSegments r = onSegment r a && onSegment r b- instance (Ord r, Fractional r) =>          (LineSegment 2 p r) `IsIntersectableWith` (Line 2 r) where-  data Intersection (LineSegment 2 p r) (Line 2 r) =-           LineContainsSegment !(LineSegment 2 p r)-         | LineLineSegmentIntersection !(Point 2 r)-         | NoLineLineSegmentIntersection-         deriving (Show,Eq)--  nonEmptyIntersection NoLineLineSegmentIntersection = False-  nonEmptyIntersection _                             = True--  s `intersect` l = case (supportingLine s) `intersect` l of-    SameLine _                               -> LineContainsSegment s-    LineLineIntersection p | p `onSegment` s -> LineLineSegmentIntersection p-    _                                        -> NoLineLineSegmentIntersection+  nonEmptyIntersection = defaultNonEmptyIntersection +  ~s@(LineSegment p q) `intersect` l = let f  = bimap (fmap Val) (const ())+                                           s' = LineSegment (p&unEndPoint %~ f)+                                                            (q&unEndPoint %~ f)+                                    in match ((s'^._SubLine) `intersect` (fromLine l)) $+         (H   coRec)+      :& (H $ coRec . fmap (_unUnBounded))+      :& (H $ const (coRec s))+      :& RNil  -- * Functions on LineSegments  -- | Test if a point lies on a line segment. ----- >>> (point2 1 0) `onSegment` (LineSegment (origin :+ ()) (point2 2 0 :+ ()))+-- >>> (point2 1 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ())) -- True--- >>> (point2 1 1) `onSegment` (LineSegment (origin :+ ()) (point2 2 0 :+ ()))+-- >>> (point2 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ())) -- False--- >>> (point2 5 0) `onSegment` (LineSegment (origin :+ ()) (point2 2 0 :+ ()))+-- >>> (point2 5 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ())) -- False--- >>> (point2 (-1) 0) `onSegment` (LineSegment (origin :+ ()) (point2 2 0 :+ ()))+-- >>> (point2 (-1) 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ())) -- False--- >>> (point2 1 1) `onSegment` (LineSegment (origin :+ ()) (point2 3 3 :+ ()))+-- >>> (point2 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 3 3 :+ ())) -- True -- -- Note that the segments are assumed to be closed. So the end points lie on the segment. ----- >>> (point2 2 0) `onSegment` (LineSegment (origin :+ ()) (point2 2 0 :+ ()))+-- >>> (point2 2 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ())) -- True--- >>> origin `onSegment` (LineSegment (origin :+ ()) (point2 2 0 :+ ()))+-- >>> origin `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ())) -- True -- -- -- This function works for arbitrary dimensons. ----- >>> (point3 1 1 1) `onSegment` (LineSegment (origin :+ ()) (point3 3 3 3 :+ ()))+-- >>> (point3 1 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point3 3 3 3 :+ ())) -- True--- >>> (point3 1 2 1) `onSegment` (LineSegment (origin :+ ()) (point3 3 3 3 :+ ()))+-- >>> (point3 1 2 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point3 3 3 3 :+ ())) -- False onSegment       :: (Ord r, Fractional r, Arity d)                 => Point d r -> LineSegment d p r -> Bool-p `onSegment` l = let s         = l^.start.core-                      t         = l^.end.core-                      inRange x = 0 <= x && x <= 1-                  in maybe False inRange $ scalarMultiple (p .-. s) (t .-. s)+p `onSegment` l = let s          = l^.start.core+                      t          = l^.end.core+                      inRange' x = 0 <= x && x <= 1+                  in maybe False inRange' $ scalarMultiple (p .-. s) (t .-. s)  --- | Compute the overlap between the two segments (if they overlap/intersect)-overlap     :: (Ord r, Fractional r, Arity d)-            => LineSegment d p r -> LineSegment d p r -> Maybe (LineSegment d p r)-overlap l m = mim >>= \im -> case il `intersect` im of-    IntervalIntersection (Interval s e) -> Just $ LineSegment (s^.extra) (e^.extra)-    NoOverlap                           -> Nothing+-- | The left and right end point (or left below right if they have equal x-coords)+orderedEndPoints   :: Ord r => LineSegment 2 p r -> (Point 2 r :+ p, Point 2 r :+ p)+orderedEndPoints s = if pc <= qc then (p, q) else (q,p)   where-    p = l^.start-    q = l^.end-    r = m^.start-    s = m^.end+    p@(pc :+ _) = s^.start+    q@(qc :+ _) = s^.end -    u = q^.core .-. p^.core -    -- lineseg l corresp to an interval from 0 1-    il = Interval (0 :+ p) (1 :+ q)+-- | Length of the line segment+segmentLength                     :: (Arity d, Floating r) => LineSegment d p r -> r+segmentLength ~(LineSegment' p q) = distanceA (p^.core) (q^.core)  -    -- let lambda x denote the scalar s.t. x = p + (lambda x) *^ u-    ---    -- lambda' computes lambda' and pairs it with the associated point.-    -- lambda  :: (Point d r :+ extra) -> Maybe (r :+ (Point d r :+ extra)-    lambda' x = (:+ x) <$> scalarMultiple u (x^.core .-. p^.core)+-- | Squared distance from the point to the Segment s. The same remark as for+-- the 'sqDistanceToSegArg' applies here.+sqDistanceToSeg   :: (Arity d, Fractional r, Ord r) => Point d r -> LineSegment d p r -> r+sqDistanceToSeg p = fst . sqDistanceToSegArg p -    -- lineseg m corresponds to an interval-    -- [min (lambda r, lambda s), max (lambda r, lambda s)]-    ---    -- mim denotes this interval, assuming it exists (i.e. that is,-    -- assuming r and s are indeed colinear with pq.-    mim = mapM lambda' [r, s] >>= (f . L.sortBy (comparing (^.core))) -    -- Make sure we have two elems, s.t. both r and s are colinear with pq-    f [a,b] = Just $ Interval a b-    f _     = Nothing+-- | Squared distance from the point to the Segment s, and the point on s+-- realizing it.  Note that if the segment is *open*, the closest point+-- returned may be one of the (open) end points, even though technically the+-- end point does not lie on the segment. (The true closest point then lies+-- arbitrarily close to the end point).+sqDistanceToSegArg     :: (Arity d, Fractional r, Ord r)+                       => Point d r -> LineSegment d p r -> (r, Point d r)+sqDistanceToSegArg p s = let m  = sqDistanceToArg p (supportingLine s)+                             xs = m : map (\(q :+ _) -> (qdA p q, q)) [s^.start, s^.end]+                         in   F.minimumBy (comparing fst)+                            . filter (flip onSegment s . snd) $ xs +-- | flips the start and end point of the segment+flipSegment   :: LineSegment d p r -> LineSegment d p r+flipSegment s = let p = s^.start+                    q = s^.end+                in (s&start .~ q)&end .~ p --- | The left and right end point (or left below right if they have equal x-coords)-orderedEndPoints   :: Ord r => LineSegment 2 p r -> (Point 2 r :+ p, Point 2 r :+ p)-orderedEndPoints s = if pc <= qc then (p, q) else (q,p)-  where-    p@(pc :+ _) = s^.start-    q@(qc :+ _) = s^.end+-- testSeg :: LineSegment 2 () Rational+-- testSeg = LineSegment (Open $ ext origin)  (Closed $ ext (point2 10 0)) +-- horL' :: Line 2 Rational+-- horL' = horizontalLine 0 --- | Length of the line segment-segmentLength                   :: (Arity d, Floating r) => LineSegment d p r -> r-segmentLength (LineSegment p q) = distanceA (p^.core) (q^.core)+-- testI = testSeg `intersect` horL'+++-- ff = bimap (fmap Val) (const ())++-- ss' = let (LineSegment p q) = testSeg in+--       LineSegment (p&unEndPoint %~ ff)+--                   (q&unEndPoint %~ ff)++-- ss'' = ss'^._SubLine
src/Data/Geometry/Point.hs view
@@ -1,35 +1,25 @@ {-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveFunctor  #-} module Data.Geometry.Point where -import           Data.Proxy- import           Control.Applicative+import           Data.Monoid(mconcat) import           Control.Lens---- import Data.TypeLevel.Common-import           Data.Typeable-import           Data.Vinyl hiding (Nat)-import qualified Data.Vinyl as V-import           Data.Vinyl.Functor(Const(..))-import qualified Data.Vinyl.TypeLevel as TV--import           Data.Vinyl.TypeLevel hiding (Nat)+import           Data.Proxy +import qualified Data.Traversable as T+import qualified Data.Foldable as F import qualified Data.Vector.Fixed as FV--- import qualified Data.Vector.Fixed.Cont as C-+import qualified Data.List as L +import           Data.Ext import           Data.Geometry.Properties import           Data.Geometry.Vector import           GHC.TypeLits  import qualified Data.Geometry.Vector as Vec--import           Linear.Vector(Additive(..))-import           Linear.Affine hiding (Point(..), origin)+import qualified Data.CircularList as C+import qualified Data.CircularList.Util as CU  -------------------------------------------------------------------------------- @@ -48,17 +38,23 @@ -- | A d-dimensional point. newtype Point d r = Point { toVec :: Vector d r } -deriving instance (Show r, Arity d) => Show (Point d r)+instance (Show r, Arity d) => Show (Point d r) where+  show (Point (Vector v)) = mconcat [ "Point", show $ FV.length v , " "+                                    , show $ F.toList v+                                    ]+++ deriving instance (Eq r, Arity d)   => Eq (Point d r) deriving instance (Ord r, Arity d)  => Ord (Point d r) deriving instance Arity d           => Functor (Point d)+deriving instance Arity d           => F.Foldable (Point d)+deriving instance Arity d           => T.Traversable (Point d)   type instance NumType (Point d r) = r type instance Dimension (Point d r) = d -- instance Arity d =>  Affine (Point d) where   type Diff (Point d) = Vector d @@ -69,7 +65,7 @@ -- | Point representing the origin in d dimensions -- -- >>> origin :: Point 4 Int--- Point {toVec = Vector {_unV = fromList [0,0,0,0]}}+-- Point4 [0,0,0,0] origin :: (Arity d, Num r) => Point d r origin = Point $ pure 0 @@ -79,9 +75,9 @@ -- | Lens to access the vector corresponding to this point. -- -- >>> (point3 1 2 3) ^. vector--- Vector {_unV = fromList [1,2,3]}+-- Vector3 [1,2,3] -- >>> origin & vector .~ v3 1 2 3--- Point {toVec = Vector {_unV = fromList [1,2,3]}}+-- Point3 [1,2,3] vector :: Lens' (Point d r) (Vector d r) vector = lens toVec (const Point) @@ -101,9 +97,9 @@ -- >>> point3 1 2 3 ^. coord (C :: C 2) -- 2 -- >>> point3 1 2 3 & coord (C :: C 1) .~ 10--- Point {toVec = Vector {_unV = fromList [10,2,3]}}+-- Point3 [10,2,3] -- >>> point3 1 2 3 & coord (C :: C 3) %~ (+1)--- Point {toVec = Vector {_unV = fromList [1,2,4]}}+-- Point3 [1,2,4] coord   :: forall proxy i d r. (Index' (i-1) d, Arity d) => proxy i -> Lens' (Point d r) r coord _ = vector . Vec.element (Proxy :: Proxy (i-1)) @@ -126,6 +122,7 @@ -- 1 -- -- if we want.+pattern Point2       :: r -> r -> Point 2 r pattern Point2 x y   <- (_point2 -> (x,y))  -- | Similarly, we can write:@@ -137,12 +134,13 @@ --   in g myPoint -- :} -- 3+pattern Point3       :: r -> r -> r -> Point 3 r pattern Point3 x y z <- (_point3 -> (x,y,z))  -- | Construct a 2 dimensional point -- -- >>> point2 1 2--- Point {toVec = Vector {_unV = fromList [1,2]}}+-- Point2 [1,2] point2     :: r -> r -> Point 2 r point2 x y = Point $ v2 x y @@ -157,7 +155,7 @@ -- | Construct a 3 dimensional point -- -- >>> point3 1 2 3--- Point {toVec = Vector {_unV = fromList [1,2,3]}}+-- Point3 [1,2,3] point3       :: r -> r -> r -> Point 3 r point3 x y z = Point $ v3 x y z @@ -176,7 +174,7 @@ -- >>> point3 1 2 3 ^. xCoord -- 1 -- >>> point2 1 2 & xCoord .~ 10--- Point {toVec = Vector {_unV = fromList [10,2]}}+-- Point2 [10,2] xCoord :: (1 <=. d) => Lens' (Point d r) r xCoord = coord (C :: C 1) @@ -185,7 +183,7 @@ -- >>> point2 1 2 ^. yCoord -- 2 -- >>> point3 1 2 3 & yCoord %~ (+1)--- Point {toVec = Vector {_unV = fromList [1,3,3]}}+-- Point3 [1,3,3] yCoord :: (2 <=. d) => Lens' (Point d r) r yCoord = coord (C :: C 2) @@ -194,10 +192,12 @@ -- >>> point3 1 2 3 ^. zCoord -- 3 -- >>> point3 1 2 3 & zCoord %~ (+1)--- Point {toVec = Vector {_unV = fromList [1,2,4]}}+-- Point3 [1,2,4] zCoord :: (3 <=. d) => Lens' (Point d r) r zCoord = coord (C :: C 3) ++ -------------------------------------------------------------------------------- -- * Point Functors @@ -228,3 +228,120 @@        Vector2 ux uy = q .-. p        Vector2 vx vy = r .-. p        z             = ux * vy - uy * vx++-- | Sort the points arround the given point p in counter clockwise order with+-- respect to the rightward horizontal ray starting from p.  If two points q+-- and r are colinear with p, the closest one to p is reported first.+-- running time: O(n log n)+sortArround   :: (Ord r, Num r)+               => Point 2 r :+ p -> [Point 2 r :+ p] -> [Point 2 r :+ p]+sortArround c = L.sortBy (ccwCmpAround c)++-- sortArround       :: (Ord r, Num r)+--                   => Point 2 r :+ p -> [Point 2 r :+ p] -> [Point 2 r :+ p]+-- sortArround p pts = concatMap sortArround' [ topR, topL, bottomL, bottomR ]+--   where+--     (topL, topR, bottomL, bottomR) = partitionIntoQuadrants p pts+--     sortArround' = L.sortBy cmp++--     cmp q r = case ccw (p^.core) (q^.core) (r^.core) of+--                 CCW      -> LT+--                 CW       -> GT+--                 CoLinear -> qdA (p^.core) (q^.core) `compare` qdA (p^.core) (r^.core)++-- | Quadrants of two dimensional points. in CCW order+data Quadrant = TopRight | TopLeft | BottomLeft | BottomRight+              deriving (Show,Read,Eq,Ord,Enum,Bounded)++-- | Quadrants around point c; quadrants are closed on their "previous"+-- boundary (i..e the boundary with the previous quadrant in the CCW order),+-- open on next boundary. The origin itself is assigned the topRight quadrant+quadrantWith                   :: (Arity d, Ord r, 1 <=. d, 2 <=. d)+                               => Point d r :+ q -> Point d r :+ p -> Quadrant+quadrantWith (c :+ _) (p :+ _) = case ( (c^.xCoord) `compare` (p^.xCoord)+                                      , (c^.yCoord) `compare` (p^.yCoord) ) of+                                   (EQ, EQ) -> TopRight+                                   (LT, EQ) -> TopRight+                                   (LT, LT) -> TopRight+                                   (EQ, LT) -> TopLeft+                                   (GT, LT) -> TopLeft+                                   (GT, EQ) -> BottomLeft+                                   (GT, GT) -> BottomLeft+                                   (EQ, GT) -> BottomRight+                                   (LT, GT) -> BottomRight++-- | Quadrants with respect to the origin+quadrant :: (Arity d, Ord r, Num r, 1 <=. d, 2 <=. d) => Point d r :+ p -> Quadrant+quadrant = quadrantWith (ext origin)++-- | Given a center point c, and a set of points, partition the points into+-- quadrants around c (based on their x and y coordinates). The quadrants are+-- reported in the order topLeft, topRight, bottomLeft, bottomRight. The points+-- are in the same order as they were in the original input lists.+-- Points with the same x-or y coordinate as p, are "rounded" to above.+partitionIntoQuadrants       :: (Ord r, Arity d, 1 <=. d, 2 <=. d)+                             => Point d r :+ q+                             -> [Point d r :+ p]+                             -> ( [Point d r :+ p], [Point d r :+ p]+                                , [Point d r :+ p], [Point d r :+ p]+                                )+partitionIntoQuadrants c pts = (topL, topR, bottomL, bottomR)+  where+    (below',above')   = L.partition (on yCoord) pts+    (bottomL,bottomR) = L.partition (on xCoord) below'+    (topL,topR)       = L.partition (on xCoord) above'++    on l q       = q^.core.l < c^.core.l++-- | Counter clockwise ordering of the points around c. Points are ordered with+-- respect to the positive x-axis.+-- Points nearer to the center come before+-- points further away.+ccwCmpAround       :: (Num r, Ord r)+                   => Point 2 r :+ qc -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering+ccwCmpAround c q r = case (quadrantWith c q `compare` quadrantWith c r) of+                       EQ -> case ccw (c^.core) (q^.core) (r^.core) of+                         CCW      -> LT+                         CW       -> GT+                         CoLinear -> qdA (c^.core) (q^.core)+                                     `compare`+                                     qdA (c^.core) (r^.core)+                       x -> x -- if the quadrant differs, use the order+                              -- specified by the quadrant.++-- | Clockwise ordering of the points around c. Points are ordered with+-- respect to the positive x-axis. Points nearer to the center come before+-- points further away.+cwCmpAround       :: (Num r, Ord r)+                  => Point 2 r :+ qc -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering+cwCmpAround c q r = case (quadrantWith c q `compare` quadrantWith c r) of+                       EQ -> case ccw (c^.core) (q^.core) (r^.core) of+                         CCW      -> GT+                         CW       -> LT+                         CoLinear -> qdA (c^.core) (q^.core)+                                     `compare`+                                     qdA (c^.core) (r^.core)+                       LT -> GT+                       GT -> LT -- if the quadrant differs, use the order+                                -- specified by the quadrant.++++-- | Given a center c, a new point p, and a list of points ps, sorted in+-- counter clockwise order around c. Insert p into the cyclic order. The focus+-- of the returned cyclic list is the new point p.+--+-- running time: O(n)+insertIntoCyclicOrder   :: (Ord r, Num r)+                        => Point 2 r :+ q -> Point 2 r :+ p+                        -> C.CList (Point 2 r :+ p) -> C.CList (Point 2 r :+ p)+insertIntoCyclicOrder c = CU.insertOrdBy (ccwCmpAround c)+++-- | Squared Euclidean distance between two points+squaredEuclideanDist :: (Num r, Arity d) => Point d r -> Point d r -> r+squaredEuclideanDist = qdA++-- | Euclidean distance between two points+euclideanDist :: (Floating r, Arity d) => Point d r -> Point d r -> r+euclideanDist = distanceA
src/Data/Geometry/PolyLine.hs view
@@ -1,19 +1,23 @@ {-# LANGUAGE TemplateHaskell  #-} {-# LANGUAGE DeriveFunctor  #-}+{-# LANGUAGE UndecidableInstances  #-} module Data.Geometry.PolyLine where  import           Control.Applicative import           Control.Lens+import           Data.Bifunctor import           Data.Ext import qualified Data.Foldable as F import           Data.Geometry.Box-import           Data.Geometry.Interval+import           Data.Geometry.LineSegment import           Data.Geometry.Point import           Data.Geometry.Properties import           Data.Geometry.Transformation import           Data.Geometry.Vector import qualified Data.Seq2 as S2+import qualified Data.Sequence as Seq import           Data.Semigroup+import qualified Data.List.NonEmpty as NE  -------------------------------------------------------------------------------- -- * d-dimensional Polygonal Lines (PolyLines)@@ -25,7 +29,10 @@ deriving instance (Show r, Show p, Arity d) => Show    (PolyLine d p r) deriving instance (Eq r, Eq p, Arity d)     => Eq      (PolyLine d p r) deriving instance (Ord r, Ord p, Arity d)   => Ord     (PolyLine d p r)-deriving instance Arity d                   => Functor (PolyLine d p)++instance Arity d => Functor (PolyLine d p) where+  fmap f (PolyLine ps) = PolyLine $ fmap (first (fmap f)) ps+ type instance Dimension (PolyLine d p r) = d type instance NumType   (PolyLine d p r) = r @@ -33,15 +40,42 @@   (PolyLine pts) <> (PolyLine pts') = PolyLine $ pts <> pts'  instance Arity d => IsBoxable (PolyLine d p r) where-  boundingBox = boundingBoxList . toListOf (points.traverse.core)+  boundingBox = boundingBoxList . NE.fromList . toListOf (points.traverse.core)  instance (Num r, AlwaysTruePFT d) => IsTransformable (PolyLine d p r) where   transformBy = transformPointFunctor  instance PointFunctor (PolyLine d p) where-  pmap f = over points (fmap (fmap f))+  pmap f = over points (fmap (first f)) +instance Arity d => Bifunctor (PolyLine d) where+  bimap f g (PolyLine pts) = PolyLine $ fmap (bimap (fmap g) f) pts + -- | pre: The input list contains at least two points-fromPoints :: (Monoid p) => [Point d r] -> PolyLine d p r-fromPoints = PolyLine . S2.fromList . map (\p -> p :+ mempty)+fromPoints :: [Point d r :+ p] -> PolyLine d p r+fromPoints = PolyLine . S2.fromList++-- | pre: The input list contains at least two points. All extra vields are+-- initialized with mempty.+fromPoints' :: (Monoid p) => [Point d r] -> PolyLine d p r+fromPoints' = fromPoints . map (\p -> p :+ mempty)+++-- | We consider the line-segment as closed.+fromLineSegment                     :: LineSegment d p r -> PolyLine d p r+fromLineSegment ~(LineSegment' p q) = fromPoints [p,q]++-- | Convert to a closed line segment by taking the first two points.+asLineSegment                              :: PolyLine d p r -> LineSegment d p r+asLineSegment (PolyLine (S2.Seq2 p mid q)) = ClosedLineSegment p (f $ Seq.viewl mid)+  where+    f Seq.EmptyL    = q+    f (q' Seq.:< _) = q'++-- | Stricter version of asLineSegment that fails if the Polyline contains more+-- than two points.+asLineSegment'                            :: PolyLine d p r -> Maybe (LineSegment d p r)+asLineSegment' (PolyLine (S2.Seq2 p m q))+  | Seq.null m                            = Just $ ClosedLineSegment p q+  | otherwise                             = Nothing
src/Data/Geometry/Polygon.hs view
@@ -1,30 +1,50 @@-{-# LANGUAGE TemplateHaskell  #-} {-# LANGUAGE ScopedTypeVariables  #-} module Data.Geometry.Polygon where   import           Control.Applicative import           Control.Lens hiding (Simple)-import qualified Data.Foldable as F-+import           Data.Bifunctor import           Data.Ext+import           Data.Semigroup+import qualified Data.Foldable as F+import           Data.Geometry.Box+import           Data.Geometry.Vector+import           Data.Geometry.Boundary+import           Data.Geometry.LineSegment import           Data.Geometry.Point+import           Data.Geometry.Line import           Data.Geometry.Properties import           Data.Geometry.Transformation-import           Data.Geometry.Box--import qualified Data.CircularList as C+import           Data.Maybe(mapMaybe)+import           Data.Proxy+import           Data.Range+import           Frames.CoRec(asA)+import qualified Data.CircularSeq as C+-- import qualified Data.CircularList as C+import           Linear.Vector(Additive(..), (^*), (^/))  -------------------------------------------------------------------------------- -- * Polygons +{- $setup+>>> :{+let simplePoly :: SimplePolygon () Rational+    simplePoly = SimplePolygon . C.fromList . map ext $ [ point2 0 0+                                                        , point2 10 0+                                                        , point2 10 10+                                                        , point2 5 15+                                                        , point2 1 11+                                                        ]+:} -}+ -- | We distinguish between simple polygons (without holes) and Polygons with holes. data PolygonType = Simple | Multi   data Polygon (t :: PolygonType) p r where-  SimplePolygon :: C.CList (Point 2 r :+ p)                         -> Polygon Simple p r-  MultiPolygon  :: C.CList (Point 2 r :+ p) -> [Polygon Simple p r] -> Polygon Multi  p r+  SimplePolygon :: C.CSeq (Point 2 r :+ p)                         -> Polygon Simple p r+  MultiPolygon  :: C.CSeq (Point 2 r :+ p) -> [Polygon Simple p r] -> Polygon Multi  p r  type SimplePolygon = Polygon Simple @@ -34,35 +54,269 @@ type instance Dimension (Polygon t p r) = 2 type instance NumType   (Polygon t p r) = r +instance (Show p, Show r) => Show (Polygon t p r) where+  show (SimplePolygon vs)   = "SimplePolygon " <> show vs+  show (MultiPolygon vs hs) = "MultiPolygon " <> show vs <> " " <> show hs++instance (Eq p, Eq r) => Eq (Polygon t p r) where+  (SimplePolygon vs)   == (SimplePolygon vs')    = vs == vs'+  (MultiPolygon vs hs) == (MultiPolygon vs' hs') = vs == vs' && hs == hs'+  _                    == _                      = False++instance PointFunctor (Polygon t p) where+  pmap f (SimplePolygon vs)   = SimplePolygon (fmap (first f) vs)+  pmap f (MultiPolygon vs hs) = MultiPolygon  (fmap (first f) vs) (map (pmap f) hs)++instance Num r => IsTransformable (Polygon t p r) where+  transformBy = transformPointFunctor++ -- * Functions on Polygons -outerBoundary :: forall t p r. Lens' (Polygon t p r) (C.CList (Point 2 r :+ p))-outerBoundary = lens get set+outerBoundary :: forall t p r. Lens' (Polygon t p r) (C.CSeq (Point 2 r :+ p))+outerBoundary = lens g s   where-    get                     :: Polygon t p r -> C.CList (Point 2 r :+ p)-    get (SimplePolygon vs)  = vs-    get (MultiPolygon vs _) = vs+    g                     :: Polygon t p r -> C.CSeq (Point 2 r :+ p)+    g (SimplePolygon vs)  = vs+    g (MultiPolygon vs _) = vs -    set                           :: Polygon t p r -> C.CList (Point 2 r :+ p) -> Polygon t p r-    set (SimplePolygon _)      vs = SimplePolygon vs-    set (MultiPolygon  _   hs) vs = MultiPolygon vs hs+    s                           :: Polygon t p r -> C.CSeq (Point 2 r :+ p)+                                -> Polygon t p r+    s (SimplePolygon _)      vs = SimplePolygon vs+    s (MultiPolygon  _   hs) vs = MultiPolygon vs hs  holes :: forall p r. Lens' (Polygon Multi p r) [Polygon Simple p r]-holes = lens get set+holes = lens g s   where-    get :: Polygon Multi p r -> [Polygon Simple p r]-    get (MultiPolygon _ hs) = hs-    set :: Polygon Multi p r -> [Polygon Simple p r] -> Polygon Multi p r-    set (MultiPolygon vs _) hs = MultiPolygon vs hs+    g                     :: Polygon Multi p r -> [Polygon Simple p r]+    g (MultiPolygon _ hs) = hs+    s                     :: Polygon Multi p r -> [Polygon Simple p r]+                          -> Polygon Multi p r+    s (MultiPolygon vs _) = MultiPolygon vs  +-- | Access the i^th vertex on the outer boundary+outerVertex   :: Int -> Lens' (Polygon t p r) (Point 2 r :+ p)+outerVertex i = outerBoundary.C.item i++-- running time: $O(\log i)$+outerBoundaryEdge     :: Int -> Polygon t p r -> LineSegment 2 p r+outerBoundaryEdge i p = let u = p^.outerVertex i+                            v = p^.outerVertex (i+1)+                        in LineSegment (Closed u) (Open v)+++-- | Get all holes in a polygon+holeList                     :: Polygon t p r -> [Polygon Simple p r]+holeList (SimplePolygon _)   = []+holeList (MultiPolygon _ hs) = hs++ -- | The vertices in the polygon. No guarantees are given on the order in which -- they appear! vertices :: Polygon t p r -> [Point 2 r :+ p]-vertices (SimplePolygon vs)   = C.toList vs-vertices (MultiPolygon vs hs) = C.toList vs ++ concatMap vertices hs+vertices (SimplePolygon vs)   = F.toList vs+vertices (MultiPolygon vs hs) = F.toList vs ++ concatMap vertices hs    fromPoints :: [Point 2 r :+ p] -> SimplePolygon p r fromPoints = SimplePolygon . C.fromList++-- | The edges along the outer boundary of the polygon. The edges are half open.+outerBoundaryEdges :: Polygon t p r -> C.CSeq (LineSegment 2 p r)+outerBoundaryEdges = toEdges . (^.outerBoundary)++-- | Gets the i^th edge on the outer boundary of the polygon, that is the edge+-- with vertices i and i+1 with respect to the current focus. All indices+-- modulo n.+--++-- | Given the vertices of the polygon. Produce a list of edges. The edges are+-- half-open.+toEdges    :: C.CSeq (Point 2 r :+ p) -> C.CSeq (LineSegment 2 p r)+toEdges vs = let vs' = F.toList vs in+  C.fromList $ zipWith (\p q -> LineSegment (Closed p) (Open q)) vs' (tail vs' ++ vs')+++-- | Test if q lies on the boundary of the polygon. Running time: O(n)+--+-- >>> point2 1 1 `onBoundary` simplePoly+-- False+-- >>> point2 0 0 `onBoundary` simplePoly+-- True+-- >>> point2 10 0 `onBoundary` simplePoly+-- True+-- >>> point2 5 13 `onBoundary` simplePoly+-- False+-- >>> point2 5 10 `onBoundary` simplePoly+-- False+-- >>> point2 10 5 `onBoundary` simplePoly+-- True+-- >>> point2 20 5 `onBoundary` simplePoly+-- False+--+-- TODO: testcases multipolygon+onBoundary        :: (Fractional r, Ord r) => Point 2 r -> Polygon t p r -> Bool+q `onBoundary` pg = any (q `onSegment`) es+  where+    out = SimplePolygon $ pg^.outerBoundary+    es = concatMap (F.toList . outerBoundaryEdges) $ out : holeList pg++-- | Check if a point lies inside a polygon, on the boundary, or outside of the polygon.+-- Running time: O(n).+--+-- >>> point2 1 1 `inPolygon` simplePoly+-- Inside+-- >>> point2 0 0 `inPolygon` simplePoly+-- OnBoundary+-- >>> point2 10 0 `inPolygon` simplePoly+-- OnBoundary+-- >>> point2 5 13 `inPolygon` simplePoly+-- Inside+-- >>> point2 5 10 `inPolygon` simplePoly+-- Inside+-- >>> point2 10 5 `inPolygon` simplePoly+-- OnBoundary+-- >>> point2 20 5 `inPolygon` simplePoly+-- Outside+--+-- TODO: Add some testcases with multiPolygons+-- TODO: Add some more onBoundary testcases+inPolygon                                :: forall t p r. (Fractional r, Ord r)+                                         => Point 2 r -> Polygon t p r+                                         -> PointLocationResult+q `inPolygon` pg+    | q `onBoundary` pg                             = OnBoundary+    | odd kl && odd kr && not (any (q `inHole`) hs) = Inside+    | otherwise                                     = Outside+  where+    l = horizontalLine $ q^.yCoord++    -- Given a line segment, compute the intersection point (if a point) with the+    -- line l+    intersectionPoint = asA (Proxy :: Proxy (Point 2 r)) . (`intersect` l)++    -- Count the number of intersections that the horizontal line through q+    -- maxes with the polygon, that are strictly to the left and strictly to+    -- the right of q. If these numbers are both odd the point lies within the polygon.+    --+    --+    -- note that: - by the asA (Point 2 r) we ignore horizontal segments (as desired)+    --            - by the filtering, we effectively limit l to an open-half line, starting+    --               at the (open) point q.+    --            - by using half-open segments as edges we avoid double counting+    --               intersections that coincide with vertices.+    --            - If the point is outside, and on the same height as the+    --              minimum or maximum coordinate of the polygon. The number of+    --              intersections to the left or right may be one. Thus+    --              incorrectly classifying the point as inside. To avoid this,+    --              we count both the points to the left *and* to the right of+    --              p. Only if both are odd the point is inside.  so that if+    --              the point is outside, and on the same y-coordinate as one+    --              of the extermal vertices (one ofth)+    --+    -- See http://geomalgorithms.com/a03-_inclusion.html for more information.+    SP kl kr = count (\p -> (p^.xCoord) `compare` (q^.xCoord))+             . mapMaybe intersectionPoint . F.toList . outerBoundaryEdges $ pg++    -- For multi polygons we have to test if we do not lie in a hole .+    inHole = insidePolygon+    hs     = holeList pg++    count   :: (a -> Ordering) -> [a] -> SP Int Int+    count f = foldr (\x (SP lts gts) -> case f x of+                             LT -> SP (lts + 1) gts+                             EQ -> SP lts       gts+                             GT -> SP lts       (gts + 1)) (SP 0 0)+++++data SP a b = SP !a !b+++-- | Test if a point lies strictly inside the polgyon.+insidePolygon        :: (Fractional r, Ord r) => Point 2 r -> Polygon t p r -> Bool+q `insidePolygon` pg = q `inPolygon` pg == Inside+++-- testQ = map (`inPolygon` testPoly) [ point2 1 1    -- Inside+--                                    , point2 0 0    -- OnBoundary+--                                    , point2 5 14   -- Inside+--                                    , point2 5 10   -- Inside+--                                    , point2 10 5   -- OnBoundary+--                                    , point2 20 5   -- Outside+--                                    ]++-- testPoly :: SimplePolygon () Rational+-- testPoly = SimplePolygon . C.fromList . map ext $ [ point2 0 0+--                                                   , point2 10 0+--                                                   , point2 10 10+--                                                   , point2 5 15+--                                                   , point2 1 11+--                                                   ]++-- | Compute the area of a polygon+area                        :: Fractional r => Polygon t p r -> r+area poly@(SimplePolygon _) = abs $ signedArea poly+area (MultiPolygon vs hs)   = area (SimplePolygon vs) - sum [area h | h <- hs]+++-- | Compute the signed area of a simple polygon. The the vertices are in+-- clockwise order, the signed area will be negative, if the verices are given+-- in counter clockwise order, the area will be positive.+signedArea      :: Fractional r => SimplePolygon p r -> r+signedArea poly = x / 2+  where+    x = sum [ p^.core.xCoord * q^.core.yCoord - q^.core.xCoord * p^.core.yCoord+            | LineSegment' p q <- F.toList $ outerBoundaryEdges poly  ]+++-- | Compute the centroid of a simple polygon.+centroid      :: Fractional r => SimplePolygon p r -> Point 2 r+centroid poly = Point $ sum' xs ^/ (6 * signedArea poly)+  where+    xs = [ (toVec p ^+^ toVec q) ^* (p^.xCoord * q^.yCoord - q^.xCoord * p^.yCoord)+         | LineSegment' (p :+ _) (q :+ _) <- F.toList $ outerBoundaryEdges poly  ]++    sum' = F.foldl' (^+^) zero+++-- | Test if the outer boundary of the polygon is in clockwise or counter+-- clockwise order.+--+-- running time: $O(1)$+--+isCounterClockwise :: (Eq r, Fractional r) => Polygon t p r -> Bool+isCounterClockwise = (\x -> x == abs x) . signedArea+                   . fromPoints . take 3 . F.toList . (^.outerBoundary)+++-- | Orient the outer boundary to clockwise order+toClockwiseOrder   :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r+toClockwiseOrder p+  | isCounterClockwise p = p&outerBoundary %~ C.reverseDirection+  | otherwise            = p++-- | Convert a Polygon to a simple polygon by forgetting about any holes.+asSimplePolygon                        :: Polygon t p r -> SimplePolygon p r+asSimplePolygon poly@(SimplePolygon _) = poly+asSimplePolygon (MultiPolygon vs _)    = SimplePolygon vs+++-- | Comparison that compares which point is 'larger' in the direction given by+-- the vector u.+cmpExtreme       :: (Num r, Ord r)+                 => Vector 2 r -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering+cmpExtreme u p q = u `dot` (p^.core .-. q^.core) `compare` 0+++-- | Finds the extreme points, minimum and maximum, in a given direction+--+-- running time: $O(n)$+extremesLinear     :: (Ord r, Num r) => Vector 2 r -> Polygon t p r+                   -> (Point 2 r :+ p, Point 2 r :+ p)+extremesLinear u p = let vs = p^.outerBoundary+                         f  = cmpExtreme u+                     in (F.minimumBy f vs, F.maximumBy f vs)
+ src/Data/Geometry/Polygon/Convex.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-|+Module    : Data.Geometry.Polygon.Convex+Description: Convex Polygons+Copyright : (c) Frank Staals+License : See LICENCE file+-}+module Data.Geometry.Polygon.Convex( ConvexPolygon+                                   , merge+                                   , lowerTangent, upperTangent+                                   , isLeftOf, isRightOf++                                   , extremes+                                   , maxInDirection+                                   ) where++import           Control.Lens hiding ((:<), (:>))+import qualified Data.CircularSeq as C+import           Data.CircularSeq (focus,CSeq)+import           Data.Ext+import qualified Data.Foldable as F+import           Data.Function (on, )+import           Data.Geometry+import           Data.Geometry.Polygon (fromPoints, cmpExtreme)+import           Data.Maybe (fromJust)+import           Data.Ord (comparing)+import qualified Data.Sequence as S+import           Data.Sequence (viewl,viewr, ViewL(..), ViewR(..))++import           Data.Geometry.Ipe+import Debug.Trace+--------------------------------------------------------------------------------++type ConvexPolygon = SimplePolygon+++mainWith inFile outFile = do+    ePage <- readSinglePageFile inFile+    case ePage of+      Left err                         -> error "" -- err+      Right (page :: IpePage Rational) -> case page^..content.traverse._withAttrs _IpePath _asSimplePolygon.core of+        []         -> error "No points found"+        polies@(_:_) -> do+           -- let out  = [asIpe drawTriangulation dt, asIpe drawTree' emst]+           -- print $ length $ edges' dt+           -- print $ toPlaneGraph (Proxy :: Proxy DT) dt+           -- writeIpeFile outFile . singlePageFromContent $ out+           -- mapM_ (print . extremesNaive (v2 1 0)) polies+           pure $ map (maxInDirection (v2 (-1) 0)) polies+++++-- | Finds the extreme points, minimum and maximum, in a given direction+--+-- pre: The input polygon is strictly convex.+--+-- running time: $O(\log n)$+--+--+extremes     :: (Num r, Ord r) => Vector 2 r -> ConvexPolygon p r+             -> (Point 2 r :+ p, Point 2 r :+ p)+extremes u p = (maxInDirection ((-1) *^ u) p, maxInDirection u p)++-- | Finds the extreme maximum point in the given direction. Based on+-- http://geomalgorithms.com/a14-_extreme_pts.html+--+--+-- pre: The input polygon is strictly convex.+--+-- running time: $O(\log^2 n)$+maxInDirection     :: (Num r, Ord r) => Vector 2 r -> ConvexPolygon p r -> Point 2 r :+ p+maxInDirection u p = findMaxStart . C.rightElements $ p^.outerBoundary+  where+    findMaxStart s@(viewl -> (a:<r))+      | isLocalMax r a r = a+      | otherwise        = findMax s+    findMaxStart _       = error "absurd"++    findMax s = let i         = F.length s `div` 2+                    (ac,cb')  = S.splitAt i s+                    (c :< cb) = viewl cb'+                in findMax' ac c cb++    findMax' ac c cb+      | isLocalMax ac c cb = c+      | otherwise          = binSearch ac c cb++    -- | Given the vertices [a..] c [..b] find the exteral vtx+    binSearch ac@(viewl -> a:<r) c cb = case (isUpwards a r, isUpwards c cb, a >=. c) of+        (True,False,_)      -> findMax (ac |> c)+        (True,True,True)    -> findMax (ac |> c)+        (True,True,False)   -> findMax (c <| cb)++        (False,True,_)      -> findMax (c <| cb)+        (False,False,False) -> findMax (ac |> c)+        (False,False,True)  -> findMax (c <| cb)+    binSearch _                  _ _ = error "maxInDirection, binSearch: empty chain"++    isLocalMax (viewr -> _ :> l) c (viewl -> r :< _) = c >=. l && c >=. r+    isLocalMax (viewr -> _ :> l) c _                 = c >=. l+    isLocalMax _                 c (viewl -> r :< _) = c >=. r+    isLocalMax _                 _ _                 = True++    -- the Edge from a to b is upwards w.r.t b if a is not larger than b+    isUpwards a (viewl -> b :< _) = cmpExtreme u a b /= GT+    isUpwards _ _                 = error "isUpwards: no edge endpoint"++    p' >=. q = cmpExtreme u p' q /= LT+++--  | Given a convex polygon poly, and a point outside the polygon, find the+--  right tangent of q and the polygon, i.e. the vertex v of the convex polygon+--  s.t. the polygon lies completely to the right of the line from q to v.+--+-- running time: $O(\log^2 n)$.+-- rightTangent        :: ConvexPolygon p r -> Point 2 r -> Point 2 r :+ p+-- rightTangent poly q = undefined+-- TODO: same as maxInDirection, but with a slightly different ordering+++++++++-- * Merging Two convex Hulls+++-- | Rotating Right <-> rotate clockwise+--+-- Merging two convex hulls, based on the paper:+--+-- Two Algorithms for Constructing a Delaunay Triangulation+-- Lee and Schachter+-- International Journal of Computer and Information Sciences, Vol 9, No. 3, 1980+--+-- : (combined hull, lower tangent that was added, upper tangent thtat was+-- added)++-- pre: - lp and rp are disjoint, and there is a vertical line separating+--        the two polygons.+--      - The vertices of the polygons are given in clockwise order+--+-- Running time: O(n+m), where n and m are the sizes of the two polygons respectively+merge       :: (Num r, Ord r) => ConvexPolygon p r  -> ConvexPolygon p r+            -> (ConvexPolygon p r, LineSegment 2 p r, LineSegment 2 p r)+merge lp rp = (fromPoints $ r' ++ l', lt, ut)+  where+    lt@(ClosedLineSegment a b) = lowerTangent lp rp+    ut@(ClosedLineSegment c d) = upperTangent lp rp+++    takeUntil p xs = let (xs',x:_) = break p xs in xs' ++ [x]+    rightElems  = F.toList . C.rightElements++    r' = takeUntil (coreEq b) . rightElems . rotateTo' d $ rp^.outerBoundary+    l' = takeUntil (coreEq c) . rightElems . rotateTo' a $ lp^.outerBoundary+++rotateTo'   :: Eq a => (a :+ b) -> CSeq (a :+ b) -> CSeq (a :+ b)+rotateTo' x = fromJust . C.findRotateTo (coreEq x)+++coreEq :: Eq a => (a :+ b) -> (a :+ b) -> Bool+coreEq = (==) `on` (^.core)++-- | Compute the lower tangent of the two polgyons+--+--   pre: - polygons lp and rp have at least 1 vertex+--        - lp and rp are disjoint, and there is a vertical line separating+--          the two polygons.+--        - The vertices of the polygons are given in clockwise order+--+-- Running time: O(n+m), where n and m are the sizes of the two polygons respectively+lowerTangent                                     :: (Num r, Ord r)+                                                 => ConvexPolygon p r+                                                 -> ConvexPolygon p r+                                                 -> LineSegment 2 p r+lowerTangent (SimplePolygon l) (SimplePolygon r) = rotate xx yy zz zz''+  where+    xx = rightMost l+    yy = leftMost r++    zz   = pred' yy+    zz'' = succ' xx++    rotate x y z z''+      | focus z   `isRightOf` (focus x, focus y) = rotate x   z (pred' z) z''+                                                      -- rotate the right polygon CCW+      | focus z'' `isRightOf` (focus x, focus y) = rotate z'' y z         (succ' z'')+                                                      -- rotate the left polygon CW+      | otherwise                                = ClosedLineSegment (focus x)+                                                                     (focus y)++succ' :: CSeq a -> CSeq a+succ' = C.rotateR++pred' :: CSeq a -> CSeq a+pred' = C.rotateL++-- | Compute the upper tangent of the two polgyons+--+--   pre: - polygons lp and rp have at least 1 vertex+--        - lp and rp are disjoint, and there is a vertical line separating+--          the two polygons.+--        - The vertices of the polygons are given in clockwise order+--+-- Running time: O(n+m), where n and m are the sizes of the two polygons respectively+upperTangent                                     :: (Num r, Ord r)+                                                 => ConvexPolygon p r+                                                 -> ConvexPolygon p r+                                                 -> LineSegment 2 p r+upperTangent (SimplePolygon l) (SimplePolygon r) = rotate xx yy zz zz'+  where+    xx = rightMost l+    yy = leftMost r++    zz  = succ' yy+    zz' = pred' xx++    rotate x y z z'+      | focus z  `isLeftOf` (focus x, focus y) = rotate x  z (succ' z) z'+                                                    -- rotate the right polygon CW+      | focus z' `isLeftOf` (focus x, focus y) = rotate z' y z        (pred' z')+                                                    -- rotate the left polygon CCW+      | otherwise                              = ClosedLineSegment (focus x)+                                                                   (focus y)++isRightOf           :: (Num r, Ord r)+                    => Point 2 r :+ p -> (Point 2 r :+ p', Point 2 r :+ p'') -> Bool+a `isRightOf` (b,c) = ccw (b^.core) (c^.core) (a^.core) == CW++isLeftOf            :: (Num r, Ord r)+                    => Point 2 r :+ p -> (Point 2 r :+ p', Point 2 r :+ p'') -> Bool+a `isLeftOf` (b,c) = ccw (b^.core) (c^.core) (a^.core) == CCW+++--------------------------------------------------------------------------------++-- | Rotate to the rightmost point+rightMost    :: Ord r => CSeq (Point 2 r :+ p) -> CSeq (Point 2 r :+ p)+rightMost xs = let m = F.maximumBy (comparing (^.core.xCoord)) xs in rotateTo' m xs++-- | Rotate to the leftmost point+leftMost    :: Ord r => CSeq (Point 2 r :+ p) -> CSeq (Point 2 r :+ p)+leftMost xs = let m = F.minimumBy (comparing (^.core.xCoord)) xs in rotateTo' m xs+++-- -- | rotate right while p 'current' 'rightNeibhour' is true+-- rotateRWhile      :: (a -> a -> Bool) -> C.CList a -> C.CList a+-- rotateRWhile p lst+--   | C.isEmpty lst = lst+--   | otherwise     = go lst+--     where+--       go xs = let cur = focus xs+--                   xs' = C.rotR xs+--                   nxt = focus' xs'+--               in if p cur nxt then go xs' else xs
src/Data/Geometry/Properties.hs view
@@ -1,18 +1,45 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE DefaultSignatures #-} module Data.Geometry.Properties where +import           Control.Applicative+import           Data.Maybe(isJust)+import           Data.Proxy+import           Data.Vinyl.Core+import           Data.Vinyl.Functor+import           Data.Vinyl.Lens+import           Frames.CoRec+import           GHC.TypeLits+++ ---------------------------------------------------------------------------------import GHC.TypeLits --- | A type family for types that are associated with a dimension.+-- | A type family for types that are associated with a dimension. The+-- dimension is the dimension of the geometry they are embedded in. type family Dimension t :: Nat  -- | A type family for types that have an associated numeric type. type family NumType t :: * +-- | A simple data type expressing that there are no intersections+data NoIntersection = NoIntersection deriving (Show,Read,Eq,Ord) +-- | The result of interesecting two geometries is a CoRec,+type Intersection g h = CoRec Identity (IntersectionOf g h)++-- | The type family specifying the list of possible result types of an+-- intersection.+type family IntersectionOf g h :: [*]++-- | Helper to produce a corec+coRec :: (a ∈ as) => a -> CoRec Identity as+coRec = Col . Identity++ class IsIntersectableWith g h where-  data Intersection g h   intersect :: g -> h -> Intersection g h    -- | g `intersects` h  <=> The intersection of g and h is non-empty.@@ -21,12 +48,53 @@   -- and uses nonEmptyIntersection to determine if the intersection is   -- non-empty.   intersects :: g -> h -> Bool-  g `intersects` h = nonEmptyIntersection $ g `intersect` h+  g `intersects` h = nonEmptyIntersection (Identity g) (Identity h) $ g `intersect` h    -- | Helper to implement `intersects`.-  nonEmptyIntersection :: Intersection g h -> Bool+  nonEmptyIntersection :: proxy g -> proxy h -> Intersection g h -> Bool   {-# MINIMAL intersect , nonEmptyIntersection #-} +  default nonEmptyIntersection :: ( NoIntersection ∈ IntersectionOf g h+                                  , RecApplicative (IntersectionOf g h)+                                  )+                                  => proxy g -> proxy h -> Intersection g h -> Bool+  nonEmptyIntersection = defaultNonEmptyIntersection+++-- | When using IntersectionOf we may need some constraints that are always+-- true anyway.+type AlwaysTrueIntersection g h = RecApplicative (IntersectionOf g h)+++-- | Returns True iff the resultt is a NoIntersection+defaultNonEmptyIntersection :: forall g h proxy.+                            ( NoIntersection ∈ IntersectionOf g h+                            , RecApplicative (IntersectionOf g h)+                            )+                            => proxy g -> proxy h -> Intersection g h -> Bool+defaultNonEmptyIntersection _ _ = isJust . asA (Proxy :: Proxy NoIntersection)+++-- type IsAlwaysTrueFromEither a b = (VTL.RIndex b [a,b] ~ ((VTL.S VTL.Z)))+--                                   -- VTL.RIndex b [a,b] ~ ((VTL.S VTL.Z))(b  ∈ [a,b])++-- -- | Convert an either to a CoRec. The type class constraint is silly, and is+-- -- triviall true. Somehow GHC does not see that though.+-- fromEither           :: IsAlwaysTrueFromEither a b => Either a b -> CoRec Identity [a,b]+-- fromEither (Left x)  = coRec x+-- fromEither (Right x) = coRec x+++-- -- fromEither'           :: ( RElem b [a,b] ((VTL.S VTL.Z))+-- --                          ) => Either a b -> CoRec Identity [a,b]++-- fromEither'           :: ( VTL.RIndex b [a,b] ~ ((VTL.S VTL.Z))+-- --                           VTL.RIndex b '[b] ~ VTL.Z+--                          ) => Either a b -> CoRec Identity [a,b]+-- fromEither' (Left x)  = coRec x+-- fromEither' (Right x) = coRec x++type family Union g h :: *+ class IsUnionableWith g h where-  data Union g h   union :: g -> h -> Union g h
+ src/Data/Geometry/Slab.hs view
@@ -0,0 +1,137 @@+{-# Language ScopedTypeVariables #-}+{-# Language TemplateHaskell #-}+module Data.Geometry.Slab where+++import           Control.Applicative+import           Control.Lens(makeLenses, (^.),(%~),(.~),(&), Lens', both)+import           Data.Bitraversable+import           Data.Ext+import qualified Data.Foldable as F+import           Data.Geometry.Properties+import           Data.Geometry.Interval+import           Data.Geometry.Point+import           Data.Geometry.Box.Internal+import           Data.Geometry.LineSegment+import           Data.Geometry.Line+import           Data.Geometry.SubLine+import           Data.Range+import           Data.Semigroup+import qualified Data.Traversable as T+import           Data.Vinyl+import           Frames.CoRec+import           Data.Bifunctor++--------------------------------------------------------------------------------++data Orthogonal = Horizontal | Vertical+                deriving (Show,Eq,Read)++++newtype Slab (o :: Orthogonal) a r = Slab { _unSlab :: Interval a r }+                                     deriving (Show,Eq)+makeLenses ''Slab++-- | Smart consturctor for creating a horizontal slab+horizontalSlab     :: (r :+ a) -> (r :+ a) -> Slab Horizontal a r+horizontalSlab l h = Slab $ ClosedInterval l h++-- | Smart consturctor for creating a vertical slab+verticalSlab :: (r :+ a) -> (r :+ a) -> Slab Vertical a r+verticalSlab l r = Slab $ ClosedInterval l r++instance Functor (Slab o a) where+  fmap = T.fmapDefault++instance F.Foldable (Slab o a) where+  foldMap = T.foldMapDefault++instance T.Traversable (Slab o a) where+  traverse f (Slab i) = Slab <$> T.traverse f i+++instance Bifunctor (Slab o) where+  bimap f g (Slab i) = Slab $ bimap f g i+++type instance IntersectionOf (Slab o a r)          (Slab o a r) =+  [NoIntersection, Slab o a r]+type instance IntersectionOf (Slab Horizontal a r) (Slab Vertical a r) =+  '[Rectangle (a,a) r]+++instance Ord r => (Slab o a r) `IsIntersectableWith` (Slab o a r) where+  nonEmptyIntersection = defaultNonEmptyIntersection++  (Slab i) `intersect` (Slab i') = match (i `intersect` i') $+        (H $ \NoIntersection -> coRec NoIntersection)+     :& (H $ \i''            -> coRec (Slab i'' :: Slab o a r))+     :& RNil++instance (Slab Horizontal a r) `IsIntersectableWith` (Slab Vertical a r) where+  nonEmptyIntersection _ _ _ = True++  (Slab h) `intersect` (Slab v) = coRec $ fromCornerPoints low high+    where+      low  = point2 (v^.start.core) (h^.start.core) :+ (v^.start.extra, h^.start.extra)+      high = point2 (v^.end.core)   (h^.end.core)   :+ (v^.end.extra,   h^.end.extra)++++class HasBoundingLines (o :: Orthogonal) where+  -- | The two bounding lines of the slab, first the lower one, then the higher one:+  --+  boundingLines :: Num r => Slab o a r -> (Line 2 r :+ a, Line 2 r :+ a)++  inSlab :: Ord r => Point 2 r -> Slab o a r -> Bool+++instance HasBoundingLines Horizontal where+  boundingLines (Slab i) = (i^.start, i^.end)&both.core %~ horizontalLine++  p `inSlab` (Slab i) = (p^.yCoord) `inInterval` i+++instance HasBoundingLines Vertical where+  boundingLines (Slab i) = (i^.start, i^.end)&both.core %~ verticalLine++  p `inSlab` (Slab i) = (p^.xCoord) `inInterval` i+++type instance IntersectionOf (Line 2 r) (Slab o a r) =+  [NoIntersection, Line 2 r, LineSegment 2 a r]++instance (Fractional r, Ord r, HasBoundingLines o) =>+         Line 2 r `IsIntersectableWith` (Slab o a r) where+  nonEmptyIntersection = defaultNonEmptyIntersection++  l@(Line p _) `intersect` s = match (l `intersect` a) $+         (H $ \NoIntersection -> if p `inSlab` s then coRec l else coRec NoIntersection)+      :& (H $ \pa             -> match (l `intersect` b) $+            (H $ \NoIntersection -> coRec NoIntersection)+         :& (H $ \pb             -> coRec $ lineSegment' pa pb)+         :& (H $ \_              -> coRec l)+         :& RNil+         )+      :& (H $ \_              -> coRec l)+      :& RNil+    where+      (a :+ _,b :+ _) = boundingLines s++      -- note that this maintains the open/closedness of the slab+      lineSegment' pa pb = let Interval a' b' = s^.unSlab+                           in LineSegment (a'&unEndPoint.core .~ pa)+                                          (b'&unEndPoint.core .~ pb)++++type instance IntersectionOf (SubLine 2 p r) (Slab o a r) =+  [NoIntersection, SubLine 2 a r, LineSegment 2 a r]++instance (Fractional r, Ord r, HasBoundingLines o) =>+         SubLine 2 a r `IsIntersectableWith` (Slab o a r) where++  nonEmptyIntersection = defaultNonEmptyIntersection++  (SubLine l r) `intersect` (Slab i) = undefined
+ src/Data/Geometry/SubLine.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell  #-}+module Data.Geometry.SubLine where++import           Control.Applicative+import qualified Data.Foldable as F+import qualified Data.Traversable as T+import Control.Lens+import Data.Ext+import Data.Geometry.Interval+import Data.Geometry.Line.Internal+import Data.Geometry.Point+import Data.Geometry.Properties+import Data.Geometry.Vector+import Data.Range+import Data.UnBounded+import           Frames.CoRec+import Data.Vinyl++--------------------------------------------------------------------------------++-- | Part of a line. The interval is ranged based on the unit-vector of the+-- line l, and s.t.t zero is the anchorPoint of l.+data SubLine d p r = SubLine { _line     :: Line d r+                             , _subRange :: Interval p r+                             }+++makeLenses ''SubLine++type instance Dimension (SubLine d p r) = d+type instance NumType   (SubLine d p r) = r++deriving instance (Show r, Show p, Arity d) => Show (SubLine d p r)+deriving instance (Eq r, Eq p, Arity d)     => Eq (SubLine d p r)+deriving instance Arity d                   => Functor (SubLine d p)+deriving instance Arity d                   => F.Foldable (SubLine d p)+deriving instance Arity d                   => T.Traversable (SubLine d p)+++-- | Get the point at the given position along line, where 0 corresponds to the+-- anchorPoint of the line, and 1 to the point anchorPoint .+^ directionVector+pointAt              :: (Num r, Arity d) => r -> Line d r -> Point d r+pointAt a (Line p v) = p .+^ (a *^ v)++-- | Annotate the subRange with the actual ending points+fixEndPoints    :: (Num r, Arity d) => SubLine d p r -> SubLine d (Point d r :+ p) r+fixEndPoints sl = sl&subRange %~ f+  where+    ptAt              = flip pointAt (sl^.line)+    label (c :+ e)    = (c :+ (ptAt c :+ e))+    f ~(Interval l u) = Interval (l&unEndPoint %~ label)+                                 (u&unEndPoint %~ label)+++-- | given point p on line (Line q v), Get the scalar lambda s.t.+-- p = q + lambda v+toOffset              :: (Eq r, Fractional r, Arity d) => Point d r -> Line d r -> r+toOffset p (Line q v) = fromJust' $ scalarMultiple (p .-. q) v+  where+    fromJust' (Just x) = x+    fromJust' _        = error "toOffset: Nothing"++type instance IntersectionOf (SubLine 2 p r) (SubLine 2 q r) = [ NoIntersection+                                                               , Point 2 r+                                                               , SubLine 2 p r+                                                               ]+++instance (Ord r, Fractional r) =>+         (SubLine 2 p r) `IsIntersectableWith` (SubLine 2 p r) where++  nonEmptyIntersection = defaultNonEmptyIntersection++  (SubLine l r) `intersect` (SubLine m s) = match (l `intersect` m) $+         (H $ \NoIntersection -> coRec NoIntersection)+      :& (H $ \p@(Point _)    -> if (toOffset p l) `inInterval` r+                                    &&+                                    (toOffset p m) `inInterval` s+                                 then coRec p+                                 else coRec NoIntersection)+      :& (H $ \_             -> match (r `intersect` s') $+                                      (H $ \NoIntersection -> coRec NoIntersection)+                                   :& (H $ \i              -> coRec $ SubLine l i)+                                   :& RNil+           )+      :& RNil+    where+      s' = shiftLeft' (toOffset (m^.anchorPoint) l) s+++fromLine   :: Arity d => Line d r -> SubLine d () (UnBounded r)+fromLine l = SubLine (fmap Val l) (OpenInterval (ext MinInfinity) (ext MaxInfinity))+++-- testL :: SubLine 2 () (UnBounded Rational)+-- testL = SubLine (horizontalLine 0) (Interval (Closed (only 0)) (Open $ only 10))++-- horL :: SubLine 2 () (UnBounded Rational)+-- horL = fromLine $ horizontalLine 0+++-- test = (testL^.subRange) `intersect` (horL^.subRange)
src/Data/Geometry/Transformation.hs view
@@ -17,13 +17,10 @@  import           GHC.TypeLits import           Linear.Matrix((!*),(!*!))-import           Linear.Vector(zero)  import qualified Data.Vector.Fixed as FV import qualified Data.Geometry.Vector as V -import           Data.Vinyl.TypeLevel hiding (Nat)- -------------------------------------------------------------------------------- -- * Matrices @@ -87,7 +84,7 @@          ) => IsTransformable (Point d r) where   transformBy (Transformation m) (Point v) = Point . V.init $ m `mult` v'     where-      v'    = snoc v 0+      v'    = snoc v 1   --------------------------------------------------------------------------------
src/Data/Geometry/Triangle.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} module Data.Geometry.Triangle where +import Data.Bifunctor import Control.Lens import Data.Ext import Data.Geometry.Point@@ -11,8 +12,12 @@ data Triangle p r = Triangle (Point 2 r :+ p)                              (Point 2 r :+ p)                              (Point 2 r :+ p)-                    deriving (Show,Eq,Functor)+                    deriving (Show,Eq) +instance Functor (Triangle p) where+  fmap f (Triangle p q r) = let f' = first (fmap f) in Triangle (f' p) (f' q) (f' r)++ type instance NumType   (Triangle p r) = r type instance Dimension (Triangle p r) = 2 @@ -39,7 +44,7 @@     Point2 cx cy = c^.core  --- | get the inscribed circle. Returns Nothing if the triangle is degenerate,+-- | get the inscribed disk. Returns Nothing if the triangle is degenerate, -- i.e. if the points are colinear.-inscribedCircle                  :: (Eq r, Fractional r) => Triangle p r -> Maybe (Circle () r)-inscribedCircle (Triangle p q r) = circle (p^.core) (q^.core) (r^.core)+inscribedDisk                  :: (Eq r, Fractional r) => Triangle p r -> Maybe (Disk () r)+inscribedDisk (Triangle p q r) = disk (p^.core) (q^.core) (r^.core)
src/Data/Geometry/Vector.hs view
@@ -1,12 +1,21 @@-module Data.Geometry.Vector( module GV-                           , module FV+module Data.Geometry.Vector( module Data.Geometry.Vector.VectorFixed+                           , module LV+                           , Affine(..)+                           , qdA, distanceA+                           , dot, norm                            , isScalarMultipleOf                            , scalarMultiple                            ) where -import qualified Data.Vector.Fixed                as FV+import           Data.Monoid import qualified Data.Foldable                    as F+import           Data.Geometry.Vector.VectorFixed import           Data.Geometry.Vector.VectorFixed as GV+import           Data.Maybe+import qualified Data.Vector.Fixed                as FV+import           Linear.Affine(Affine(..), qdA, distanceA)+import           Linear.Metric(dot,norm)+import           Linear.Vector as LV   -- | Test if v is a scalar multiple of u.@@ -23,26 +32,59 @@ -- False -- >>> v2 2 1 `isScalarMultipleOf` v2 4 2 -- True+-- >>> v2 2 1 `isScalarMultipleOf` v2 4 0+-- False isScalarMultipleOf       :: (Eq r, Fractional r, GV.Arity d)                          => Vector d r -> Vector d r -> Bool-u `isScalarMultipleOf` v = fst $  scalarMultiple' u v+u `isScalarMultipleOf` v = isJust $ scalarMultiple u v  -- | Get the scalar labmda s.t. v = lambda * u (if it exists) scalarMultiple     :: (Eq r, Fractional r, GV.Arity d)                    => Vector d r -> Vector d r -> Maybe r-scalarMultiple u v = case scalarMultiple' u v of-    (False,_)             -> Nothing-    (_, mm@(Just lambda)) -> mm-    (_, _)                -> Just . fromIntegral $ 0+scalarMultiple u v+      | allZero u || allZero v = Just 0+      | otherwise              = scalarMultiple' u v --- | Helper function for computing the scalar multiple. The result is a pair--- (b,mm), where b indicates if v is a scalar multiple of u, and mm is a Maybe--- scalar multiple. If the result is Nothing, the scalar multiple is zero.-scalarMultiple'     :: (Eq r, Fractional r, GV.Arity d)-                    => Vector d r -> Vector d r -> (Bool,Maybe r)-scalarMultiple' u v = F.foldr allLambda (True,Nothing) $ FV.zipWith f u v++-- -- | Helper function for computing the scalar multiple. The result is a pair+-- -- (b,mm), where b indicates if v is a scalar multiple of u, and mm is a Maybe+-- -- scalar multiple. If the result is Nothing, the scalar multiple is zero.+-- scalarMultiple'     :: (Eq r, Fractional r, GV.Arity d)+--                     => Vector d r -> Vector d r -> (Bool,Maybe r)+-- scalarMultiple' u v = F.foldr allLambda (True,Nothing) $ FV.zipWith f u v+--   where+--     f ui vi = (ui == 0 && vi == 0, ui / vi)+--     allLambda (True,_)      x               = x+--     allLambda (_, myLambda) (b,Nothing)     = (b,Just myLambda) -- no lambda yet+--     allLambda (_, myLambda) (b,Just lambda) = (myLambda == lambda && b, Just lambda)+++allZero :: (GV.Arity d, Eq r, Num r) => Vector d r -> Bool+allZero = F.all (== 0)+++data ScalarMultiple r = No | Maybe | Yes r deriving (Eq,Show)++instance Eq r => Monoid (ScalarMultiple r) where+  mempty = Maybe++  No      `mappend` _       = No+  _       `mappend` No      = No+  Maybe   `mappend` x       = x+  x       `mappend` Maybe   = x+  (Yes x) `mappend` (Yes y)+     | x == y               = Yes x+     | otherwise            = No+++scalarMultiple'      :: (Eq r, Fractional r, GV.Arity d)+                     => Vector d r -> Vector d r -> Maybe r+scalarMultiple' u v = g . F.foldr mappend mempty $ FV.zipWith f u v   where-    f ui vi = (ui == 0 && vi == 0, ui / vi)-    allLambda (True,_)      x               = x-    allLambda (_, myLambda) (b,Nothing)     = (b,Just myLambda) -- no lambda yet-    allLambda (_, myLambda) (b,Just lambda) = (myLambda == lambda && b, Just lambda)+    f 0  0  = Maybe -- we don't know lambda yet, but it may still be a scalar mult.+    f _  0  = No      -- Not a scalar multiple+    f ui vi = Yes $ ui / vi -- can still be a scalar multiple++    g No      = Nothing+    g Maybe   = error "scalarMultiple': found a Maybe, which means the vectors either have length zero, or one of them is all Zero!"+    g (Yes x) = Just x
src/Data/Geometry/Vector/VectorFixed.hs view
@@ -3,17 +3,14 @@ {-# LANGUAGE UndecidableInstances #-} module Data.Geometry.Vector.VectorFixed where +import           Data.Monoid import           Control.Applicative- import           Control.Lens--import           Data.Proxy- import           Data.Foldable import           Data.Traversable  import           Data.Vector.Fixed.Boxed-import           Data.Vector.Fixed.Cont(Z(..),S(..),ToPeano(..),ToNat(..))+import           Data.Vector.Fixed.Cont(Z, S, ToPeano)  import           GHC.TypeLits @@ -47,12 +44,26 @@  type Index' i d = V.Index (ToPeano i) (ToPeano d) ++-- | Lens into the i th element element   :: forall proxy i d r. (Arity d, Index' i d) => proxy i -> Lens' (Vector d r) r element _ = V.elementTy (undefined :: (ToPeano i)) +-- | Similar to 'element' above. Except that we don't have a static guarantee+-- that the index is in bounds. Hence, we can only return a Traversal+element'   :: forall d r. (KnownNat d, Arity d) => Int -> Traversal' (Vector d r) r+element' i f v+  | 0 <= i && i < fromInteger (natVal (C :: C d)) = f (v V.! i)+                                                 <&> \a -> (v&V.element i .~ a)+       -- Implementation based on that of Ixed Vector in Control.Lens.At+  | otherwise                                     = pure v  -deriving instance (Show r, Arity d) => Show (Vector d r)+instance (Show r, Arity d) => Show (Vector d r) where+  show (Vector v) = mconcat [ "Vector", show $ V.length v , " "+                            , show $ toList v+                            ]+ deriving instance (Eq r, Arity d)   => Eq (Vector d r) deriving instance (Ord r, Arity d)  => Ord (Vector d r) deriving instance Arity d  => Functor (Vector d)@@ -103,8 +114,8 @@ --------------------------------------------------------------------------------  -- | Conversion to a Linear.V3-toV3   :: Vector 3 a -> L3.V3 a-toV3 (Vector3 a b c) = L3.V3 a b c+toV3                  :: Vector 3 a -> L3.V3 a+toV3 ~(Vector3 a b c) = L3.V3 a b c  -- | Conversion from a Linear.V3 fromV3               :: L3.V3 a -> Vector 3 a@@ -162,5 +173,8 @@   -- | Pattern synonym for two and three dim vectors+pattern Vector2       :: r -> r -> Vector 2 r pattern Vector2 x y   <- (_unV2 -> (x,y))++pattern Vector3       :: r -> r -> r -> Vector 3 r pattern Vector3 x y z <- (_unV3 -> (x,y,z))
+ src/Data/Permutation.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Permutation where++import           Control.Lens+import           Control.Monad (forM)+import           Control.Monad.ST (runST)+import qualified Data.Foldable as F+import           Data.Maybe (catMaybes)+import qualified Data.Traversable as T+import qualified Data.Vector as V+import qualified Data.Vector.Generic as GV+import qualified Data.Vector.Unboxed as UV+import qualified Data.Vector.Unboxed.Mutable as UMV++--------------------------------------------------------------------------------++-- | Orbits (Cycles) are represented by vectors+type Orbit a = V.Vector a++-- | Cyclic representation of a permutation.+data Permutation a = Permutation { _orbits  :: V.Vector (Orbit a)+                                 , _indexes :: UV.Vector (Int,Int)+                                               -- ^ idxes (fromEnum a) = (i,j)+                                               -- implies that a is the j^th+                                               -- item in the i^th orbit+                                 }+                   deriving (Show,Eq)+makeLenses ''Permutation++instance Functor Permutation where+  fmap = T.fmapDefault++instance F.Foldable Permutation where+  foldMap = T.foldMapDefault++instance T.Traversable Permutation where+  traverse f (Permutation os is) = flip Permutation is <$> T.traverse (T.traverse f) os+++elems :: Permutation a -> V.Vector a+elems = GV.concat . GV.toList . _orbits++size      :: Permutation a -> Int+size perm = GV.length (perm^.indexes)++-- | The cycle containing a given item+cycleOf        :: Enum a => Permutation a -> a -> Orbit a+cycleOf perm x = perm^.orbits.ix' (perm^.indexes.ix' (fromEnum x)._1)+++-- | Next item in a cyclic permutation+next     :: GV.Vector v a => v a -> Int -> a+next v i = let n = GV.length v in v GV.! ((i+1) `mod` n)++-- | Lookup the indices of an element, i.e. in which orbit the item is, and the+-- index within the orbit.+lookupIdx        :: Enum a => Permutation a -> a -> (Int,Int)+lookupIdx perm x = perm^.indexes.ix' (fromEnum x)++-- | Apply the permutation, i.e. consider the permutation as a function.+apply        :: Enum a => Permutation a -> a -> a+apply perm x = let (c,i) = lookupIdx perm x+               in next (perm^.orbits.ix' c) i+++-- | Find the cycle in the permutation starting at element s+orbitFrom     :: Eq a => a -> (a -> a) -> [a]+orbitFrom s p = s : (takeWhile (/= s) . tail $ iterate p s)++-- Given a vector with items in the permutation, and a permutation (by its+-- functional representation) construct the cyclic representation of the+-- permutation.+cycleRep        :: (GV.Vector v a, Enum a, Eq a) => v a -> (a -> a) -> Permutation a+cycleRep v perm = toCycleRep n $ runST $ do+    bv    <- UMV.replicate n False -- bit vector of marks+    morbs <- forM [0..(n - 1)] $ \i -> do+               m <- UMV.read bv (fromEnum $ v GV.! i)+               if m then pure Nothing -- already visited+                    else do+                      let xs = orbitFrom (v GV.! i) perm+                      markAll bv $ map fromEnum xs+                      pure . Just $ xs+    pure . catMaybes $ morbs+  where+    n  = GV.length v++    mark    bv i = UMV.write bv i True+    markAll bv   = mapM_ (mark bv)+++-- | Given the size n, and a list of Cycles, turns the cycles into a+-- cyclic representation of the Permutation.+toCycleRep      :: Enum a => Int -> [[a]] -> Permutation a+toCycleRep n os = Permutation (V.fromList . map V.fromList $ os) (genIndexes n os)+++genIndexes      :: Enum a => Int -> [[a]] -> UV.Vector (Int,Int)+genIndexes n os = UV.create $ do+                                v <- UMV.new n+                                mapM_ (uncurry $ UMV.write v) ixes'+                                pure v+  where+    f i c = zipWith (\x j -> (fromEnum x,(i,j))) c [0..]+    ixes' = concat $ zipWith f [0..] os++++--------------------------------------------------------------------------------+-- * Helper stuff++-- | lens indexing into a vector+ix'   :: (GV.Vector v a, Index (v a) ~ Int, IxValue (v a) ~ a, Ixed (v a))+      => Int -> Lens' (v a) a+ix' i = singular (ix i)
+ src/Data/PlanarGraph.hs view
@@ -0,0 +1,492 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.PlanarGraph( Arc(..)+                       , Direction(..), rev++                       , Dart(..), arc, direction+                       , twin, isPositive++                       , World(..)++                       , Dual++                       , VertexId(..)++                       , PlanarGraph+                       , embedding, vertexData, dartData, faceData+                       , edgeData++                       , planarGraph, planarGraph'++                       , numVertices, numDarts, numEdges, numFaces+                       , darts', darts, edges', edges, vertices', vertices, faces', faces++                       , tailOf, headOf, endPoints+                       , incidentEdges, incomingEdges, outgoingEdges, neighboursOf++                       , vDataOf, eDataOf, fDataOf, endPointDataOf, endPointData+++                       , dual++                       , FaceId(..)+                       , leftFace, rightFace, boundary+                       ) where++import           Control.Lens+import           Control.Monad (forM_)+import           Data.Permutation+import qualified Data.Vector as V+import qualified Data.Foldable as F+import qualified Data.Vector.Mutable as MV++--------------------------------------------------------------------------------++--------------------------------------------------------------------------------+-- $setup+-- >>> :{+-- let dart i s = Dart (Arc i) (read s)+--     (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]+--     myGraph :: PlanarGraph Test Primal_ () String ()+--     myGraph = planarGraph' [ [ (Dart aA Negative, "a-")+--                              , (Dart aC Positive, "c+")+--                              , (Dart aB Positive, "b+")+--                              , (Dart aA Positive, "a+")+--                              ]+--                            , [ (Dart aE Negative, "e-")+--                              , (Dart aB Negative, "b-")+--                              , (Dart aD Negative, "d-")+--                              , (Dart aG Positive, "g+")+--                              ]+--                            , [ (Dart aE Positive, "e+")+--                              , (Dart aD Positive, "d+")+--                              , (Dart aC Negative, "c-")+--                              ]+--                            , [ (Dart aG Negative, "g-")+--                              ]+--                            ]+-- :}++-- TODO: Add a fig. of the Graph+++--------------------------------------------------------------------------------++-- | An Arc is a directed edge in a planar graph. The type s is used to tie+-- this arc to a particular graph.+newtype Arc s = Arc { _unArc :: Int } deriving (Eq,Ord,Enum,Bounded)++instance Show (Arc s) where+  show (Arc i) = "Arc " ++ show i+++data Direction = Negative | Positive deriving (Eq,Ord,Bounded,Enum)++instance Show Direction where+  show Positive = "+1"+  show Negative = "-1"++instance Read Direction where+  readsPrec _ "-1" = [(Negative,"")]+  readsPrec _ "+1" = [(Positive,"")]+  readsPrec _ _    = []++-- | Reverse the direcion+rev          :: Direction -> Direction+rev Negative = Positive+rev Positive = Negative++-- | A dart represents a bi-directed edge. I.e. a dart has a direction, however+-- the dart of the oposite direction is always present in the planar graph as+-- well.+data Dart s = Dart { _arc       :: !(Arc s)+                   , _direction :: !Direction+                   } deriving (Eq,Ord)+makeLenses ''Dart++++instance Show (Dart s) where+  show (Dart a d) = "Dart (" ++ show a ++ ") " ++ show d++-- | Get the twin of this dart (edge)+--+-- >>> twin (dart 0 "+1")+-- Dart (Arc 0) -1+-- >>> twin (dart 0 "-1")+-- Dart (Arc 0) +1+twin            :: Dart s -> Dart s+twin (Dart a d) = Dart a (rev d)++-- | test if a dart is Positive+isPositive   :: Dart s -> Bool+isPositive d = d^.direction == Positive+++instance Enum (Dart s) where+  toEnum x+    | even x    = Dart (Arc $ x `div` 2)       Positive+    | otherwise = Dart (Arc $ (x `div` 2) + 1) Negative+  -- get the back edge by adding one++  fromEnum (Dart (Arc i) d) = case d of+                                Positive -> 2*i+                                Negative -> 2*i + 1+++-- | The world in which the graph lives+data World = Primal_ | Dual_ deriving (Show,Eq)++type family Dual (sp :: World) where+  Dual Primal_ = Dual_+  Dual Dual_   = Primal_+++-- | A vertex in a planar graph. A vertex is tied to a particular planar graph+-- by the phantom type s, and to a particular world w.+newtype VertexId s (w :: World) = VertexId { _unVertexId :: Int } deriving (Eq,Ord,Enum)+-- VertexId's are in the range 0...|orbits|-1++instance Show (VertexId s w) where+  show (VertexId i) = "VertexId " ++ show i+++--------------------------------------------------------------------------------+-- * The graph type itself++-- | A *connected* Planar graph with bidirected edges. I.e. the edges (darts) are+-- directed, however, for every directed edge, the edge in the oposite+-- direction is also in the graph.+--+-- The types v, e, and f are the are the types of the data associated with the+-- vertices, edges, and faces, respectively.+--+-- The orbits in the embedding are assumed to be in counterclockwise order.+data PlanarGraph s (w :: World) v e f = PlanarGraph { _embedding  :: Permutation (Dart s)+                                                    , _vertexData :: V.Vector v+                                                    , _rawDartData :: V.Vector e+                                                    , _faceData    :: V.Vector f+                                                    }+                                      deriving (Show,Eq)+makeLenses ''PlanarGraph+++-- | lens to access the Dart Data+dartData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f)+                 (V.Vector (Dart s, e)) (V.Vector (Dart s, e'))+dartData = lens darts (\g xs -> g&rawDartData .~ reorderEdgeData xs)++-- | edgeData is just an alias for 'dartData'+edgeData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f)+                 (V.Vector (Dart s, e)) (V.Vector (Dart s, e'))+edgeData = dartData+++-- | Reorders the edge data to be in the right order to set edgeData+reorderEdgeData    :: Foldable f => f (Dart s, e) -> V.Vector e+reorderEdgeData ds = V.create $ do+                                  v <- MV.new (F.length ds)+                                  forM_ (F.toList ds) $ \(d,x) ->+                                    MV.write v (fromEnum d) x+                                  pure v+++-- | Construct a planar graph+planarGraph      :: Permutation (Dart s) -> PlanarGraph s Primal_ () () ()+planarGraph perm = PlanarGraph perm vData eData fData+  where+    d = size perm+    e = d `div` 2+    v = V.length (perm^.orbits)+    f = e - v + 2++    vData  = V.replicate v ()+    eData  = V.replicate d ()+    fData  = V.replicate f ()++++-- | Construct a planar graph.+--+planarGraph'    :: [[(Dart s,e)]] -> PlanarGraph s Primal_ () e ()+planarGraph' ds = (planarGraph perm)&dartData .~ (V.fromList . concat $ ds)+  where+    n     = sum . map length $ ds+    perm  = toCycleRep n $ map (map fst) ds++++-- | Get the number of vertices+--+-- >>> numVertices myGraph+-- 4+numVertices :: PlanarGraph s w v e f -> Int+numVertices g = V.length (g^.embedding.orbits)++-- | Get the number of Darts+--+-- >>> numDarts myGraph+-- 12+numDarts :: PlanarGraph s w v e f -> Int+numDarts g = size (g^.embedding)++-- | Get the number of Edges+--+-- >>> numEdges myGraph+-- 6+numEdges :: PlanarGraph s w v e f -> Int+numEdges g = numDarts g `div` 2++-- | Get the number of faces+--+-- >>> numFaces myGraph+-- 4+numFaces   :: PlanarGraph s w v e f -> Int+numFaces g = numEdges g - numVertices g + 2+++-- | Enumerate all vertices+--+-- >>> vertices' myGraph+-- [VertexId 0,VertexId 1,VertexId 2,VertexId 3]+vertices'   :: PlanarGraph s w v e f -> V.Vector (VertexId s w)+vertices' g = VertexId <$> V.enumFromN 0 (V.length (g^.embedding.orbits))++-- | Enumerate all vertices, together with their vertex data++-- >>> vertices myGraph+-- [(VertexId 0,()),(VertexId 1,()),(VertexId 2,()),(VertexId 3,())]+vertices   :: PlanarGraph s w v e f -> V.Vector (VertexId s w, v)+vertices g = V.zip (vertices' g) (g^.vertexData)+++-- | Enumerate all darts+darts' :: PlanarGraph s w v e f -> V.Vector (Dart s)+darts' = elems . _embedding++-- | Get all darts together with their data+--+-- >>> mapM_ print $ darts myGraph+-- (Dart (Arc 0) -1,"a-")+-- (Dart (Arc 2) +1,"c+")+-- (Dart (Arc 1) +1,"b+")+-- (Dart (Arc 0) +1,"a+")+-- (Dart (Arc 4) -1,"e-")+-- (Dart (Arc 1) -1,"b-")+-- (Dart (Arc 3) -1,"d-")+-- (Dart (Arc 5) +1,"g+")+-- (Dart (Arc 4) +1,"e+")+-- (Dart (Arc 3) +1,"d+")+-- (Dart (Arc 2) -1,"c-")+-- (Dart (Arc 5) -1,"g-")+darts   :: PlanarGraph s w v e f -> V.Vector (Dart s, e)+darts g = (\d -> (d,g^.eDataOf d)) <$> darts' g++-- | Enumerate all edges. We report only the Positive darts+edges' :: PlanarGraph s w v e f -> V.Vector (Dart s)+edges' = V.filter isPositive . darts'++-- | Enumerate all edges with their edge data. We report only the Positive+-- darts.+--+-- >>> mapM_ print $ edges myGraph+-- (Dart (Arc 2) +1,"c+")+-- (Dart (Arc 1) +1,"b+")+-- (Dart (Arc 0) +1,"a+")+-- (Dart (Arc 5) +1,"g+")+-- (Dart (Arc 4) +1,"e+")+-- (Dart (Arc 3) +1,"d+")+edges :: PlanarGraph s w v e f -> V.Vector (Dart s, e)+edges = V.filter (isPositive . fst) . darts+++++++-- | The tail of a dart, i.e. the vertex this dart is leaving from+--+tailOf     :: Dart s -> PlanarGraph s w v e f -> VertexId s w+tailOf d g = VertexId . fst $ lookupIdx (g^.embedding) d++-- | The vertex this dart is heading in to+headOf   :: Dart s -> PlanarGraph s w v e f -> VertexId s w+headOf d = tailOf (twin d)++-- | endPoints d g = (tailOf d g, headOf d g)+endPoints :: Dart s -> PlanarGraph s w v e f -> (VertexId s w, VertexId s w)+endPoints d g = (tailOf d g, headOf d g)+++-- | All edges incident to vertex v, in counterclockwise order around v.+incidentEdges                :: VertexId s w -> PlanarGraph s w v e f+                             -> V.Vector (Dart s)+incidentEdges (VertexId v) g = g^.embedding.orbits.ix' v++-- | All incoming edges incident to vertex v, in counterclockwise order around v.+incomingEdges     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)+incomingEdges v g = V.filter (not . isPositive) $ incidentEdges v g++-- | All outgoing edges incident to vertex v, in counterclockwise order around v.+outgoingEdges     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)+outgoingEdges v g = V.filter isPositive $ incidentEdges v g+++-- | Gets the neighbours of a particular vertex, in counterclockwise order+-- around the vertex.+neighboursOf     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w)+neighboursOf v g = otherVtx <$> incidentEdges v g+  where+    otherVtx d = let u = tailOf d g in if u == v then headOf d g else u++-- outgoingNeighbours :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w)+-- outgoingNeighbours = undefined++-- incomingNeighbours :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w)+-- incomingNeighbours = undefined+++--------------------------------------------------------------------------------+-- * Access data++-- | Get the vertex data associated with a node. Note that updating this data may be+-- expensive!!+vDataOf              :: VertexId s w -> Lens' (PlanarGraph s w v e f) v+vDataOf (VertexId i) = vertexData.ix' i++-- | Edge data of a given dart+eDataOf   :: Dart s -> Lens' (PlanarGraph s w v e f) e+eDataOf d = rawDartData.ix' (fromEnum d)++-- | Data of a face of a given face+fDataOf                       :: FaceId s w -> Lens' (PlanarGraph s w v e f) f+fDataOf (FaceId (VertexId i)) = faceData.ix' i+++-- | Data corresponding to the endpoints of the dart+endPointDataOf   :: Dart s -> Getter (PlanarGraph s w v e f) (v,v)+endPointDataOf d = to $ endPointData d+++-- | Data corresponding to the endpoints of the dart+endPointData     :: Dart s -> PlanarGraph s w v e f -> (v,v)+endPointData d g = let (u,v) = endPoints d g in (g^.vDataOf u, g^.vDataOf v)++--------------------------------------------------------------------------------+-- * The Dual graph++-- | The dual of this graph+--+-- >>> :{+--  let fromList = V.fromList+--      answer = fromList [ fromList [dart 0 "-1"]+--                        , fromList [dart 2 "+1",dart 4 "+1",dart 1 "-1",dart 0 "+1"]+--                        , fromList [dart 1 "+1",dart 3 "-1",dart 2 "-1"]+--                        , fromList [dart 4 "-1",dart 3 "+1",dart 5 "+1",dart 5 "-1"]+--                        ]+--  in (dual myGraph)^.embedding.orbits == answer+-- :}+-- True+dual   :: PlanarGraph s w v e f -> PlanarGraph s (Dual w) f e v+dual g = let perm = g^.embedding+         in PlanarGraph (cycleRep (elems perm) (apply perm . twin))+                        (g^.faceData)+                        (g^.rawDartData)+                        (g^.vertexData)++-- | A face+newtype FaceId s w = FaceId { _unFaceId :: VertexId s (Dual w) } deriving (Eq,Ord)++instance Show (FaceId s w) where+  show (FaceId (VertexId i)) = "FaceId " ++ show i++-- | Enumerate all faces in the planar graph+faces' :: PlanarGraph s w v e f -> V.Vector (FaceId s w)+faces' = fmap FaceId . vertices' . dual++-- | All faces with their face data.+faces   :: PlanarGraph s w v e f -> V.Vector (FaceId s w, f)+faces g = V.zip (faces' g) (g^.faceData)++-- | The face to the left of the dart+--+-- >>> leftFace (dart 1 "+1") myGraph+-- FaceId 1+-- >>> leftFace (dart 1 "-1") myGraph+-- FaceId 2+-- >>> leftFace (dart 2 "+1") myGraph+-- FaceId 2+-- >>> leftFace (dart 0 "+1") myGraph+-- FaceId 0+leftFace     :: Dart s -> PlanarGraph s w v e f -> FaceId s w+leftFace d g = FaceId . headOf d $ dual g+++-- | The face to the right of the dart+--+-- >>> rightFace (dart 1 "+1") myGraph+-- FaceId 2+-- >>> rightFace (dart 1 "-1") myGraph+-- FaceId 1+-- >>> rightFace (dart 2 "+1") myGraph+-- FaceId 1+-- >>> rightFace (dart 0 "+1") myGraph+-- FaceId 1+rightFace     :: Dart s -> PlanarGraph s w v e f -> FaceId s w+rightFace d g = FaceId . tailOf d $ dual g+++-- | The darts bounding this face, for internal faces in clockwise order, for+-- the outer face in counter clockwise order.+--+--+boundary     :: FaceId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)+boundary (FaceId v) g = incidentEdges v $ dual g+++++--------------------------------------------------------------------------------+-- Testing stuff++testPerm :: Permutation (Dart s)+testPerm = let (a:b:c:d:e:g:_) = take 6 [Arc 0..]+           in toCycleRep 12 [ [ Dart a Negative+                              , Dart c Positive+                              , Dart b Positive+                              , Dart a Positive+                              ]+                            , [ Dart e Negative+                              , Dart b Negative+                              , Dart d Negative+                              , Dart g Positive+                              ]+                            , [ Dart e Positive+                              , Dart d Positive+                              , Dart c Negative+                              ]+                            , [ Dart g Negative+                              ]+                            ]++data Test++testG :: PlanarGraph Test Primal_ () String ()+testG = planarGraph' [ [ (Dart aA Negative, "a-")+                       , (Dart aC Positive, "c+")+                       , (Dart aB Positive, "b+")+                       , (Dart aA Positive, "a+")+                       ]+                     , [ (Dart aE Negative, "e-")+                       , (Dart aB Negative, "b-")+                       , (Dart aD Negative, "d-")+                       , (Dart aG Positive, "g+")+                       ]+                     , [ (Dart aE Positive, "e+")+                       , (Dart aD Positive, "d+")+                       , (Dart aC Negative, "c-")+                       ]+                     , [ (Dart aG Negative, "g-")+                       ]+                     ]+  where+    (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..]
+ src/Data/PlaneGraph.hs view
@@ -0,0 +1,24 @@+module Data.PlaneGraph( module Data.PlanarGraph+                      , PlaneGraph++                      , withEdgeDistances+                      ) where++import Data.Ext+import Control.Lens+import Data.PlanarGraph+import Data.Geometry.Point+++--------------------------------------------------------------------------------++type PlaneGraph s w v e f r = PlanarGraph s w (Point 2 r :+ v) e f+++-- | Labels the edges of a plane graph with their distances, as specified by+-- the distance function.+withEdgeDistances     :: (Point 2 r ->  Point 2 r -> a)+                      -> PlaneGraph s w p e f r -> PlaneGraph s w p (a :+ e) f r+withEdgeDistances f g = g&dartData %~ fmap (\(d,x) -> (d,len d :+ x))+  where+    len d = uncurry f . over both (^.core) $ endPointData d g
+ src/Data/Range.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE TemplateHaskell   #-}+module Data.Range( EndPoint(..)+                 , isOpen, isClosed+                 , unEndPoint+                 , Range(..)+                 , prettyShow+                 , lower, upper+                 , pattern OpenRange, pattern ClosedRange, pattern Range'+                 , inRange, width, clipLower, clipUpper, midPoint+                 , isValid++                 , shiftLeft, shiftRight+                 ) where++import           Control.Applicative+import           Control.Arrow((&&&))+import           Control.Lens+import qualified Data.Foldable as F+import           Data.Geometry.Properties+import qualified Data.Traversable as T++--------------------------------------------------------------------------------+++data EndPoint a = Open   a+                | Closed a+                deriving (Show,Read,Eq,Functor,F.Foldable,T.Traversable)++_unEndPoint            :: EndPoint a -> a+_unEndPoint (Open a)   = a+_unEndPoint (Closed a) = a++unEndPoint :: Lens (EndPoint a) (EndPoint b) a b+unEndPoint = lens _unEndPoint f+  where+    f (Open _) a   = Open a+    f (Closed _) a = Closed a+++isOpen          :: EndPoint a -> Bool+isOpen (Open _) = True+isOpen _        = False++isClosed :: EndPoint a -> Bool+isClosed = not . isOpen+++--------------------------------------------------------------------------------++data Range a = Range { _lower :: EndPoint a+                     , _upper :: EndPoint a+                     }+               deriving (Show,Read,Eq,Functor,F.Foldable,T.Traversable)++makeLenses ''Range++pattern OpenRange   l u = Range (Open l)   (Open u)+pattern ClosedRange l u = Range (Closed l) (Closed u)++-- | A range from l to u, ignoring/forgetting the type of the enpoints+pattern Range' l u <- (_lower &&& _upper -> (l,u))++++prettyShow             :: Show a => Range a -> String+prettyShow (Range l u) = concat [ lowerB, show (l^.unEndPoint), ", "+                                , show (u^.unEndPoint), upperB+                                ]+  where+    lowerB = if isOpen l then "(" else "["+    upperB = if isOpen u then ")" else "]"++++-- | Test if a value lies in a range.+--+-- >>> 1 `inRange` (OpenRange 0 2)+-- True+-- >>> 1 `inRange` (OpenRange 0 1)+-- False+-- >>> 1 `inRange` (ClosedRange 0 1)+-- True+-- >>> 1 `inRange` (ClosedRange 1 1)+-- True+-- >>> 10 `inRange` (OpenRange 1 10)+-- False+-- >>> 10 `inRange` (ClosedRange 0 1)+-- False+inRange                 :: Ord a => a -> Range a -> Bool+x `inRange` (Range l u) = case ((l^.unEndPoint) `compare` x, x `compare` (u^.unEndPoint)) of+    (_, GT) -> False+    (GT, _) -> False+    (LT,LT) -> True+    (LT,EQ) -> include u -- depends on only u+    (EQ,LT) -> include l -- depends on only l+    (EQ,EQ) -> include l || include u -- depends on l and u+  where+    include = isClosed++type instance IntersectionOf (Range a) (Range a) = [ NoIntersection, Range a]++instance Ord a => (Range a) `IsIntersectableWith` (Range a) where++  nonEmptyIntersection = defaultNonEmptyIntersection++  -- The intersection is empty, if after clipping, the order of the end points is inverted+  -- or if the endpoints are the same, but both are open.+  (Range l u) `intersect` s = let i = clipLower' l . clipUpper' u $ s+                              in if isValid i then coRec i else coRec NoIntersection++-- | Get the width of the interval+--+-- >>> width $ ClosedRange 1 10+-- 9+-- >>> width $ OpenRange 5 10+-- 5+width   :: Num r => Range r -> r+width i = i^.upper.unEndPoint - i^.lower.unEndPoint++midPoint   :: Fractional r => Range r -> r+midPoint r = let w = width r in r^.lower.unEndPoint + (w / 2)+++--------------------------------------------------------------------------------+-- * Helper functions++-- | Clip the interval from below. I.e. intersect with the interval {l,infty),+-- where { is either open, (, orr closed, [.+clipLower     :: Ord a => EndPoint a -> Range a -> Maybe (Range a)+clipLower l r = let r' = clipLower' l r in if isValid r' then Just r' else Nothing++-- | Clip the interval from above. I.e. intersect with (-\infty, u}, where } is+-- either open, ), or closed, ],+clipUpper     :: Ord a => EndPoint a -> Range a -> Maybe (Range a)+clipUpper u r = let r' = clipUpper' u r in if isValid r' then Just r' else Nothing+++-- | Check if the range is valid and nonEmpty, i.e. if the lower endpoint is+-- indeed smaller than the right endpoint. Note that we treat empty open-ranges+-- as invalid as well.+isValid             :: Ord a => Range a -> Bool+isValid (Range l u) = case (_unEndPoint l) `compare` (_unEndPoint u) of+                          LT                            -> True+                          EQ | isClosed l || isClosed u -> True+                          _                             -> False++-- operation is unsafe, as it may produce an invalid range (where l > u)+clipLower'                  :: Ord a => EndPoint a -> Range a -> Range a+clipLower' l' r@(Range l u) = case l' `cmpLower` l of+                                GT -> Range l' u+                                _  -> r+-- operation is unsafe, as it may produce an invalid range (where l > u)+clipUpper'                  :: Ord a => EndPoint a -> Range a -> Range a+clipUpper' u' r@(Range l u) = case u' `cmpUpper` u of+                                LT -> Range l u'+                                _  -> r++-- | Compare end points, Closed < Open+cmpLower     :: Ord a => EndPoint a -> EndPoint a -> Ordering+cmpLower a b = case (_unEndPoint a) `compare` (_unEndPoint b) of+                 LT -> LT+                 GT -> GT+                 EQ -> case (a,b) of+                         (Open _,   Open _)   -> EQ  -- if both are same type, report EQ+                         (Closed _, Closed _) -> EQ+                         (Open _,  _)         -> GT  -- otherwise, choose the Closed one+                         (Closed _,_)         -> LT  -- is the *smallest*+++-- | Compare the end points, Open < Closed+cmpUpper     :: Ord a => EndPoint a -> EndPoint a -> Ordering+cmpUpper a b = case (_unEndPoint a) `compare` (_unEndPoint b) of+                 LT -> LT+                 GT -> GT+                 EQ -> case (a,b) of+                         (Open _,   Open _)   -> EQ  -- if both are same type, report EQ+                         (Closed _, Closed _) -> EQ+                         (Open _,  _)         -> LT  -- otherwise, choose the Closed one+                         (Closed _,_)         -> GT  -- is the *largest*+++++--------------------------------------------------------------------------------++-- | Shift a range x units to the left+--+-- >>> prettyShow $ shiftLeft 10 (ClosedRange 10 20)+-- "[0, 10]"+-- >>> prettyShow $ shiftLeft 10 (OpenRange 15 25)+-- "(5, 15)"+shiftLeft   :: Num r => r -> Range r -> Range r+shiftLeft x = shiftRight (-x)++-- | Shifts the range to the right+--+-- >>> prettyShow $ shiftRight 10 (ClosedRange 10 20)+-- "[20, 30]"+-- >>> prettyShow $ shiftRight 10 (OpenRange 15 25)+-- "(25, 35)"+shiftRight   :: Num r => r -> Range r -> Range r+shiftRight x = fmap (+x)
src/Data/Seq2.hs view
@@ -1,16 +1,20 @@ module Data.Seq2 where -import           Prelude hiding (foldr,foldl,head,tail,last)- import           Control.Applicative-import           Data.List.NonEmpty+import           Control.Lens ((%~), (&), (<&>), (^?), Lens', lens)+import           Control.Lens.At (Ixed(..), Index, IxValue)+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Maybe (fromJust) import           Data.Semigroup+import           Prelude hiding (foldr,foldl,head,tail,last,length)   import qualified Data.Traversable as T import qualified Data.Foldable as F import qualified Data.Sequence as S +--------------------------------------------------------------------------------+ -- | Basically Data.Sequence but with the guarantee that the list contains at -- least two elements. data Seq2 a = Seq2 a (S.Seq a) a@@ -26,29 +30,36 @@  instance F.Foldable Seq2 where   foldMap = T.foldMapDefault+  length ~(Seq2 _ s _) = 2 + S.length s  instance Semigroup (Seq2 a) where   l <> r = l >< r +type instance Index (Seq2 a)   = Int+type instance IxValue (Seq2 a) = a+instance Ixed (Seq2 a) where+  ix i f s@(Seq2 l m r)+    | i == 0      = f l                 <&> \a -> Seq2 a m r+    | i < 1 + mz  = f (S.index m (i-1)) <&> \a -> Seq2 l (S.update (i-1) a m) r+    | i == mz + 1 = f r                 <&> \a -> Seq2 l m a+    | otherwise   = pure s+      where+        mz = S.length m+ duo     :: a -> a -> Seq2 a duo a b = Seq2 a S.empty b -length               :: Seq2 a -> Int-length ~(Seq2 _ s _) = 2 + S.length s-- -- | get the element with index i, counting from the left and starting at 0. -- O(log(min(i,n-i)))-index                 :: Seq2 a -> Int -> a-index ~(Seq2 l s r) i-  | i == 0      = l-  | i < 1 + sz  = S.index s (i+1)-  | i == sz + 1 = r-  | otherwise   = error "index: index out of bounds."-    where-      sz = S.length s+index     :: Seq2 a -> Int -> a+index s i = fromJust $ s^?ix i +adjust       :: (a -> a) -> Int -> Seq2 a -> Seq2 a+adjust f i s = s&ix i %~ f +++ (<|) :: a -> Seq2 a -> Seq2 a x <| ~(Seq2 l s r) = Seq2 x (l S.<| s) r @@ -58,7 +69,8 @@   -- | Concatenate two sequences. O(log(min(n1,n2)))-~(Seq2 ll ls lr) >< ~(Seq2 rl rs rr) = Seq2 ll ((ls S.|> lr) S.>< (rl S.<| rs)) rr+(><) :: Seq2 a -> Seq2 a -> Seq2 a+s >< l = fromSeqUnsafe $ toSeq s S.>< toSeq l   -- | pre: the list contains at least two elements@@ -66,6 +78,36 @@ fromList (a:b:xs) = F.foldl' (\s x -> s |> x) (duo a b) xs fromList _        = error "Seq2.fromList: Not enough values" +++-- | fmap but with an index+mapWithIndex                  :: (Int -> a -> b) -> Seq2 a -> Seq2 b+mapWithIndex f s@(Seq2 a m b) = Seq2 (f 0 a) (S.mapWithIndex f' m) (f l b)+  where+    l    = F.length s - 1+    f' i = f (i+1)+++take   :: Int -> Seq2 a -> S.Seq a+take i = S.take i . toSeq+++drop   :: Int -> Seq2 a -> S.Seq a+drop i = S.drop i . toSeq+++toSeq               :: Seq2 a -> S.Seq a+toSeq ~(Seq2 a m b) = ((a S.<| m) S.|> b)+++-- | Convert a Seq into a Seq2. It is not checked that the length is at least two+fromSeqUnsafe   :: S.Seq a -> Seq2 a+fromSeqUnsafe s = Seq2 a m b+  where+    ~(a S.:< s') = S.viewl s+    ~(m S.:> b)  = S.viewr s'++ -------------------------------------------------------------------------------- -- | Left views @@ -80,8 +122,12 @@  instance F.Foldable ViewL2 where   foldMap = T.foldMapDefault+  length ~(_ :<< s) = 1 + F.length s  +++ -- | At least one element data ViewL1 a = a :< S.Seq a deriving (Show,Read,Eq,Ord) @@ -93,16 +139,25 @@  instance F.Foldable ViewL1 where   foldMap = T.foldMapDefault+  length ~(_ :< s) = 1 + S.length s  -- | We throw away information here; namely that the combined list contains two elements. instance Semigroup (ViewL1 a) where   ~(a :< s) <> ~(b :< t) = a :< (s <> S.singleton b <> t)  -toNonEmpty          :: ViewL1 a -> NonEmpty a-toNonEmpty ~(a :< s) = (a :| F.toList s)+headL1 :: Lens' (ViewL1 a) a+headL1 = lens (\(l :< _) -> l) (\(_ :< s) l -> l :< s)  ++toNonEmpty           :: ViewL1 a -> NonEmpty.NonEmpty a+toNonEmpty ~(a :< s) = (a NonEmpty.:| F.toList s)++viewL1FromNonEmpty                     :: NonEmpty.NonEmpty a -> ViewL1 a+viewL1FromNonEmpty ~(x NonEmpty.:| xs) = x :< S.fromList xs++ -- | O(1) get a left view viewl                 :: Seq2 a -> ViewL2 a viewl ~(Seq2 l s r) = l :<< (s :> r)@@ -111,6 +166,10 @@ l1Singleton :: a -> ViewL1 a l1Singleton = (:< S.empty) +viewL1toR1           :: ViewL1 a -> ViewR1 a+viewL1toR1 ~(l :< s) = let (s' S.:> r) = S.viewr (l S.<| s) in s' :> r++ -------------------------------------------------------------------------------- -- | Right views @@ -126,7 +185,7 @@  instance F.Foldable ViewR2 where   foldMap = T.foldMapDefault-+  length (s :>> _) = 1 + F.length s  -- | A view of the right end of the sequence, with the guarantee that it has at -- least one element.@@ -140,6 +199,7 @@  instance F.Foldable ViewR1 where   foldMap = T.foldMapDefault+  length (s :> _) = 1 + S.length s   -- | O(1) get a right view
+ src/Data/Sequence/Util.hs view
@@ -0,0 +1,57 @@+module Data.Sequence.Util where++import Data.Sequence(Seq, ViewL(..),ViewR(..))+import qualified Data.Sequence as S++--------------------------------------------------------------------------------++-- | Get the index h such that everything strictly smaller than h has: p i =+-- False, and all i >= h, we have p h = True+--+-- returns Nothing if no element satisfies p+--+-- running time: $O(\log^2 n + T*\log n)$, where $T$ is the time to execute the+-- predicate.+binarySearchSeq     :: (a -> Bool) -> Seq a -> Maybe Int+binarySearchSeq p s = case S.viewr s of+                       EmptyR                 -> Nothing+                       (_ :> x)   | p x       -> Just $ case S.viewl s of+                         (y :< _) | p y          -> 0+                         _                       -> binarySearch p' 0 u+                                  | otherwise -> Nothing+  where+    p' = p . S.index s+    u  = S.length s - 1+++-- | Partition the seq s given a monotone predicate p into (xs,ys) such that+--+-- all elements in xs do *not* satisfy the predicate p+-- all elements in ys do       satisfy the predicate p+--+-- all elements in s occur in either xs or ys.+--+-- running time: $O(\log^2 n + T*\log n)$, where $T$ is the time to execute the+-- predicate.+splitMonotone     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+splitMonotone p s = case binarySearchSeq p s of+                      Nothing -> (s,S.empty)+                      Just i  -> S.splitAt i s+++-- | Given a monotonic predicate p, a lower bound l, and an upper bound u, with:+--  p l = False+--  p u = True+--  l < u.+--+-- Get the index h such that everything strictly smaller than h has: p i =+-- False, and all i >= h, we have p h = True+--+-- running time: $O(\log(u - l))$+{-# SPECIALIZE binarySearch :: (Int -> Bool) -> Int -> Int -> Int #-}+binarySearch       :: Integral a => (a -> Bool) -> a -> a -> a+binarySearch p l u = let d = u - l+                         m = l + (d `div` 2)+                     in if d == 1 then u else+                          if p m then binarySearch p l m+                                 else binarySearch p m u
+ src/Data/UnBounded.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE TemplateHaskell   #-}+module Data.UnBounded( Top, topToMaybe+                     , pattern ValT, pattern Top++                     , Bottom, bottomToMaybe+                     , pattern Bottom, pattern ValB++                     , UnBounded(..)+                     , unUnBounded+                     , unBoundedToMaybe+                     ) where++import           Control.Applicative+import           Control.Lens+import qualified Data.Foldable as F+import qualified Data.Traversable as T+++--------------------------------------------------------------------------------+-- * Top and Bottom++-- | `Top a` represents the type a, together with a 'Top' element, i.e. an element+-- that is greater than any other element. We can think of `Top a` being defined as:+--+-- >>> data Top a = ValT a | Top+newtype Top a = GTop { topToMaybe :: Maybe a }+                deriving (Eq,Functor,F.Foldable,T.Traversable,Applicative,Monad)++pattern ValT x = GTop (Just x)+pattern Top    = GTop Nothing++instance Ord a => Ord (Top a) where+  Top       `compare` Top      = EQ+  _         `compare` Top      = LT+  Top       `compare` _        = GT+  ~(ValT x) `compare` ~(ValT y) = x `compare` y++instance Show a => Show (Top a) where+  show Top       = "Top"+  show ~(ValT x) = "ValT " ++ show x++--------------------------------------------------------------------------------++-- | `Bottom a` represents the type a, together with a 'Bottom' element,+-- i.e. an element that is smaller than any other element. We can think of+-- `Bottom a` being defined as:+--+-- >>> data Bottom a = ValB+newtype Bottom a = GBottom { bottomToMaybe :: Maybe a }+                 deriving (Eq,Ord,Functor,F.Foldable,T.Traversable,Applicative,Monad)++pattern Bottom = GBottom Nothing+pattern ValB x = GBottom (Just x)++instance Show a => Show (Bottom a) where+  show Bottom    = "Bottom"+  show ~(ValB x) = "ValB " ++ show x++--------------------------------------------------------------------------------++-- | `UnBounded a` represents the type a, together with an element+-- `MaxInfinity` larger than any other element, and an element `MinInfinity`,+-- smaller than any other element.+data UnBounded a = MinInfinity | Val { _unUnBounded :: a }  | MaxInfinity+                 deriving (Eq,Ord,Functor,F.Foldable,T.Traversable)++makeLenses ''UnBounded++instance Show a => Show (UnBounded a) where+  show MinInfinity = "MinInfinity"+  show (Val x)     = "Val " ++ show x+  show MaxInfinity = "MaxInfinity"++instance Num a => Num (UnBounded a) where+  MinInfinity + _           = MinInfinity+  _           + MinInfinity = MinInfinity+  (Val x)     + (Val y)     = Val $ x + y+  _           + MaxInfinity = MaxInfinity+  MaxInfinity + _           = MaxInfinity+++  MinInfinity * _           = MinInfinity+  _           * MinInfinity = MinInfinity++  (Val x)     * (Val y)     = Val $ x * y+  _           * MaxInfinity = MaxInfinity+  MaxInfinity * _           = MaxInfinity++  abs MinInfinity = MinInfinity+  abs (Val x)     = Val $ abs x+  abs MaxInfinity = MaxInfinity++  signum MinInfinity = -1+  signum (Val x)     = Val $ signum x+  signum MaxInfinity = 1++  fromInteger = Val . fromInteger++  negate MinInfinity = MaxInfinity+  negate (Val x)     = Val $ negate x+  negate MaxInfinity = MinInfinity++instance Fractional a => Fractional (UnBounded a) where+  MinInfinity / _       = MinInfinity+  (Val x)     / (Val y) = Val $ x / y+  (Val _)     / _       = 0+  MaxInfinity / _       = MaxInfinity++  fromRational = Val . fromRational+++unBoundedToMaybe         :: UnBounded a -> Maybe a+unBoundedToMaybe (Val x) = Just x+unBoundedToMaybe _       = Nothing
+ test/Algorithms/Geometry/DelaunayTriangulation/DTSpec.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE LambdaCase #-}+module Algorithms.Geometry.DelaunayTriangulation.DTSpec where++import Util++import Test.Hspec+import Control.Lens+import Data.Geometry+import Data.Maybe(mapMaybe, fromJust)+import Algorithms.Geometry.DelaunayTriangulation.Types+import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConqueror as DC+import qualified Algorithms.Geometry.DelaunayTriangulation.Naive              as Naive+import qualified Data.List.NonEmpty as NonEmpty+import Data.Geometry.Ipe+import Data.Ext+import Data.Traversable(traverse)+import qualified Data.CircularList.Util as CU+import qualified Data.Map as M+import qualified Data.Vector as V+++dtEdges :: (Fractional r, Ord r)+        => NonEmpty.NonEmpty (Point 2 r :+ p) -> [(VertexID, VertexID)]+dtEdges = tEdges . DC.delaunayTriangulation++take'   :: Int -> NonEmpty.NonEmpty a -> NonEmpty.NonEmpty a+take' i = NonEmpty.fromList . NonEmpty.take i++--------------------------------------------------------------------------------++spec :: Spec+spec = do+  describe "Testing Divide and Conqueror Algorithm for Delaunay Triangulation" $ do+    it "singleton " $ do+      dtEdges (take' 1 myPoints) `shouldBe` []+    toSpec (TestCase "myPoints" myPoints)+    toSpec (TestCase "myPoints'" myPoints')+    ipeSpec++ipeSpec :: Spec+ipeSpec = testCases "test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe"++testCases    :: FilePath -> Spec+testCases fp = (runIO $ readInput fp) >>= \case+    Left e    -> it "reading Delaunay Triangulation disk file" $+                   expectationFailure $ "Failed to read ipe file " ++ show e+    Right tcs -> mapM_ toSpec tcs+++-- | Point sets per color, Crosses form the solution+readInput    :: FilePath -> IO (Either ConversionError [TestCase Rational])+readInput fp = fmap f <$> readSinglePageFile fp+  where+    f page = [ TestCase "?" $ fmap (\p -> p^.core.symbolPoint :+ ()) pSet+             | pSet <- byStrokeColour' syms+             ]+      where+        syms = page^..content.traverse._IpeUse+        byStrokeColour' = mapMaybe NonEmpty.nonEmpty . byStrokeColour++++data TestCase r = TestCase { _color    :: String+                           , _pointSet :: NonEmpty.NonEmpty (Point 2 r :+ ())+                           } deriving (Show,Eq)+++toSpec                    :: (Fractional r, Ord r, Show r) => TestCase r -> Spec+toSpec (TestCase c pts) = describe ("testing on " ++ c ++ " points") $ do+                            sameAsNaive c pts++sameAsNaive       :: (Fractional r, Ord r, Show p, Show r)+                  => String -> NonEmpty.NonEmpty (Point 2 r :+ p) -> Spec+sameAsNaive s pts = it ("Divide And Conqueror same answer as Naive on " ++ s) $+                      (Naive.delaunayTriangulation pts+                       `sameEdges`+                       DC.delaunayTriangulation pts) `shouldBe` True+++sameEdges             :: Triangulation p r -> Triangulation p r -> Bool+triA `sameEdges` triB = all sameAdj . M.assocs $ mapping'+  where+    sameAdj (a, b) = (f $ adjA V.! a) `CU.isShiftOf` (adjB V.! b)++    adjA = triA^.neighbours+    adjB = triB^.neighbours++    mapping' = M.fromList $ zip (M.elems $ triA^.vertexIds) (M.elems $ triB^.vertexIds)++    f = fmap (fromJust . flip M.lookup mapping')++myPoints :: NonEmpty.NonEmpty (Point 2 Rational :+ ())+myPoints = NonEmpty.fromList . map ext $+           [ point2 1  3+           , point2 4  26+           , point2 5  17+           , point2 6  7+           , point2 12 16+           , point2 19 4+           , point2 20 0+           , point2 20 11+           , point2 23 23+           , point2 31 14+           , point2 33 5+           ]++myPoints' :: NonEmpty.NonEmpty (Point 2 Rational :+ ())+myPoints' = NonEmpty.fromList . map ext $+            [ point2 64  736+            , point2 96 688+            , point2 128 752+            , point2 160 704+            , point2 128 672+            , point2 64 656+            , point2 192 736+            , point2 208 704+            , point2 192 672+            ]
+ test/Algorithms/Geometry/SmallestEnclosingDisk/RISpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+module Algorithms.Geometry.SmallestEnclosingDisk.RISpec where++import Util++import Control.Monad(when)+import System.Random(mkStdGen)+import Control.Lens+import Data.Ext+import Data.Maybe+import Data.Proxy+import Test.Hspec+import Data.Geometry+import Data.Geometry.Ball(fromDiameter, disk, Disk)+import Data.Geometry.Ipe++import Algorithms.Geometry.SmallestEnclosingBall.Types+import qualified Algorithms.Geometry.SmallestEnclosingBall.RandomizedIncrementalConstruction as RIC+import qualified Algorithms.Geometry.SmallestEnclosingBall.Naive as Naive+++spec :: Spec+spec = testCases "test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe"++testCases    :: FilePath -> Spec+testCases fp = (runIO $ readInput fp) >>= \case+    Left e    -> it "reading Smallest enclosing disk file" $+                   expectationFailure $ "Failed to read ipe file " ++ show e+    Right tcs -> mapM_ toSpec tcs+++data TestCase r = TestCase { _pointSet :: [Point 2 r :+ ()]+                           , _solution :: Maybe (TwoOrThree (Point 2 r))+                           }+                  deriving (Show,Eq)+++toSpec                    :: (Fractional r, Ord r, Show r) => TestCase r -> Spec+toSpec (TestCase pts sol) =+    describe ("testing point set with solution " ++ show sol) $ do+      it "comparing with naive solution" $+        ((RIC.smallestEnclosingDisk (mkStdGen 2123) pts)^.enclosingDisk)+        `shouldBe`+        ((Naive.smallestEnclosingDisk pts)^.enclosingDisk)+      when (isJust sol) $+        it "manal solution" $+          ((RIC.smallestEnclosingDisk (mkStdGen 5) pts)^.enclosingDisk)+          `shouldBe`+          (diskOf $ fromJust sol)+++diskOf               :: (Fractional r, Eq r)+                     => TwoOrThree (Point 2 r) -> Disk () r+diskOf (Two p q)     = fromDiameter p q+diskOf (Three p q r) = fromMaybe (error "Wrong manual disk") $ disk p q r+++-- | Point sets per color, Crosses form the solution+readInput    :: FilePath -> IO (Either ConversionError [TestCase Rational])+readInput fp = fmap f <$> readSinglePageFile fp+  where+    f page = [ TestCase [p^.core.symbolPoint :+ () | p <- pSet] (solutionOf pSet)+             | pSet <- byStrokeColour syms+             ]+      where+        syms = page^..content.traverse._IpeUse++        -- | Crosses form a solution+        isInSolution s = s^.core.symbolName == "mark/cross(sx)"++        right = either (const Nothing) Just+        solutionOf = right . fromList . map (^.core.symbolPoint) . filter isInSolution
+ test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe view
@@ -0,0 +1,369 @@+<?xml version="1.0"?>+<!DOCTYPE ipe SYSTEM "ipe.dtd">+<ipe version="70107" creator="Ipe 7.1.7">+<info created="D:20151023214323" modified="D:20160123195914"/>+<ipestyle name="basic">+<symbol name="arrow/arc(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/farc(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/ptarc(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/fptarc(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="mark/circle(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+0.4 0 0 0.4 0 0 e+</path>+</symbol>+<symbol name="mark/disk(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+</path>+</symbol>+<symbol name="mark/fdisk(sfx)" transformations="translations">+<group>+<path fill="sym-fill">+0.5 0 0 0.5 0 0 e+</path>+<path fill="sym-stroke" fillrule="eofill">+0.6 0 0 0.6 0 0 e+0.4 0 0 0.4 0 0 e+</path>+</group>+</symbol>+<symbol name="mark/box(sx)" transformations="translations">+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+-0.4 -0.4 m+0.4 -0.4 l+0.4 0.4 l+-0.4 0.4 l+h+</path>+</symbol>+<symbol name="mark/square(sx)" transformations="translations">+<path fill="sym-stroke">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+</path>+</symbol>+<symbol name="mark/fsquare(sfx)" transformations="translations">+<group>+<path fill="sym-fill">+-0.5 -0.5 m+0.5 -0.5 l+0.5 0.5 l+-0.5 0.5 l+h+</path>+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+-0.4 -0.4 m+0.4 -0.4 l+0.4 0.4 l+-0.4 0.4 l+h+</path>+</group>+</symbol>+<symbol name="mark/cross(sx)" transformations="translations">+<group>+<path fill="sym-stroke">+-0.43 -0.57 m+0.57 0.43 l+0.43 0.57 l+-0.57 -0.43 l+h+</path>+<path fill="sym-stroke">+-0.43 0.57 m+0.57 -0.43 l+0.43 -0.57 l+-0.57 0.43 l+h+</path>+</group>+</symbol>+<symbol name="arrow/fnormal(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/pointed(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/fpointed(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/linear(spx)">+<path stroke="sym-stroke" pen="sym-pen">+-1 0.333 m+0 0 l+-1 -0.333 l+</path>+</symbol>+<symbol name="arrow/fdouble(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+-1 0 m+-2 0.333 l+-2 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/double(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+-1 0 m+-2 0.333 l+-2 -0.333 l+h+</path>+</symbol>+<pen name="heavier" value="0.8"/>+<pen name="fat" value="1.2"/>+<pen name="ultrafat" value="2"/>+<symbolsize name="large" value="5"/>+<symbolsize name="small" value="2"/>+<symbolsize name="tiny" value="1.1"/>+<arrowsize name="large" value="10"/>+<arrowsize name="small" value="5"/>+<arrowsize name="tiny" value="3"/>+<color name="red" value="1 0 0"/>+<color name="green" value="0 1 0"/>+<color name="blue" value="0 0 1"/>+<color name="yellow" value="1 1 0"/>+<color name="orange" value="1 0.647 0"/>+<color name="gold" value="1 0.843 0"/>+<color name="purple" value="0.627 0.125 0.941"/>+<color name="gray" value="0.745"/>+<color name="brown" value="0.647 0.165 0.165"/>+<color name="navy" value="0 0 0.502"/>+<color name="pink" value="1 0.753 0.796"/>+<color name="seagreen" value="0.18 0.545 0.341"/>+<color name="turquoise" value="0.251 0.878 0.816"/>+<color name="violet" value="0.933 0.51 0.933"/>+<color name="darkblue" value="0 0 0.545"/>+<color name="darkcyan" value="0 0.545 0.545"/>+<color name="darkgray" value="0.663"/>+<color name="darkgreen" value="0 0.392 0"/>+<color name="darkmagenta" value="0.545 0 0.545"/>+<color name="darkorange" value="1 0.549 0"/>+<color name="darkred" value="0.545 0 0"/>+<color name="lightblue" value="0.678 0.847 0.902"/>+<color name="lightcyan" value="0.878 1 1"/>+<color name="lightgray" value="0.827"/>+<color name="lightgreen" value="0.565 0.933 0.565"/>+<color name="lightyellow" value="1 1 0.878"/>+<dashstyle name="dashed" value="[4] 0"/>+<dashstyle name="dotted" value="[1 3] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<textsize name="large" value="\large"/>+<textsize name="small" value="\small"/>+<textsize name="tiny" value="\tiny"/>+<textsize name="Large" value="\Large"/>+<textsize name="LARGE" value="\LARGE"/>+<textsize name="huge" value="\huge"/>+<textsize name="Huge" value="\Huge"/>+<textsize name="footnote" value="\footnotesize"/>+<textstyle name="center" begin="\begin{center}" end="\end{center}"/>+<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>+<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>+<gridsize name="4 pts" value="4"/>+<gridsize name="8 pts (~3 mm)" value="8"/>+<gridsize name="16 pts (~6 mm)" value="16"/>+<gridsize name="32 pts (~12 mm)" value="32"/>+<gridsize name="10 pts (~3.5 mm)" value="10"/>+<gridsize name="20 pts (~7 mm)" value="20"/>+<gridsize name="14 pts (~5 mm)" value="14"/>+<gridsize name="28 pts (~10 mm)" value="28"/>+<gridsize name="56 pts (~20 mm)" value="56"/>+<anglesize name="90 deg" value="90"/>+<anglesize name="60 deg" value="60"/>+<anglesize name="45 deg" value="45"/>+<anglesize name="30 deg" value="30"/>+<anglesize name="22.5 deg" value="22.5"/>+<tiling name="falling" angle="-60" step="4" width="1"/>+<tiling name="rising" angle="30" step="4" width="1"/>+</ipestyle>+<ipestyle name="frank">+<arrowsize name="normal" value="5"/>+<arrowsize name="large" value="8"/>+<arrowsize name="small" value="3"/>+<arrowsize name="tiny" value="1"/>+<arrowsize name="huge" value="10"/>+<dashstyle name="dashed" value="[2 2] 0"/>+<dashstyle name="dotted" value="[0.5 1] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<gridsize name="1 pts" value="1"/>+<gridsize name="2 pts" value="2"/>+<opacity name="10%" value="0.1"/>+<opacity name="20%" value="0.2"/>+<opacity name="30%" value="0.3"/>+<opacity name="40%" value="0.4"/>+<opacity name="50%" value="0.5"/>+<opacity name="60%" value="0.6"/>+<opacity name="70%" value="0.7"/>+<opacity name="80%" value="0.8"/>+<opacity name="90%" value="0.9"/>+</ipestyle>+<page>+<layer name="alpha"/>+<layer name="beta"/>+<layer name="gamma"/>+<layer name="delta"/>+<view layers="alpha beta gamma delta" active="delta"/>+<use layer="alpha" name="mark/cross(sx)" pos="112 736" size="normal" stroke="black"/>+<use name="mark/cross(sx)" pos="336 640" size="normal" stroke="black"/>+<use name="mark/cross(sx)" pos="336 816" size="normal" stroke="black"/>+<use matrix="1 0 0 1 6.13784 -3.9059" name="mark/disk(sx)" pos="304 784" size="normal" stroke="black"/>+<use matrix="1 0 0 1 4.44908 -4.21815" name="mark/disk(sx)" pos="320 736" size="normal" stroke="black"/>+<use matrix="1 0 0 1 0.586099 6.64103" name="mark/disk(sx)" pos="352 736" size="normal" stroke="black"/>+<path stroke="black">+129.39 0 0 129.39 241.143 728 e+</path>+<use name="mark/disk(sx)" pos="264.671 689.288" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="222.264 731.137" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="289.78 722.767" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="215.01 683.15" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="197.154 741.181" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="194.365 766.848" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="230.076 767.406" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="155.864 708.26" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="238.445 743.413" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="280.294 767.964" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="274.715 659.157" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="221.148 609.496" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="310.984 638.512" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="223.38 649.671" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="169.813 689.846" size="normal" stroke="black"/>+<use name="mark/disk(sx)" pos="201.618 709.934" size="normal" stroke="black"/>+<use layer="beta" name="mark/disk(sx)" pos="368 608" size="normal" stroke="red"/>+<use matrix="1 0 0 1 2.78993 -9.48576" name="mark/disk(sx)" pos="336 608" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="352 592" size="normal" stroke="red"/>+<use matrix="1 0 0 1 10.0437 -7.8118" name="mark/disk(sx)" pos="368 576" size="normal" stroke="red"/>+<use matrix="1 0 0 1 2.78993 1.11597" name="mark/disk(sx)" pos="320 576" size="normal" stroke="red"/>+<use matrix="1 0 0 1 -8.36979 -11.1597" name="mark/disk(sx)" pos="352 576" size="normal" stroke="red"/>+<use matrix="1 0 0 1 30.6892 -15.0656" name="mark/disk(sx)" pos="400 608" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="400 576" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="304 560" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="368 544" size="normal" stroke="red"/>+<use name="mark/cross(sx)" pos="288.737 510.098" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="379.689 503.96" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="409.82 541.903" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="363.507 541.345" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="437.719 527.954" size="normal" stroke="red"/>+<use name="mark/cross(sx)" pos="476.778 591.564" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="403.682 564.223" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="409.82 562.549" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="414.284 563.107" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="462.271 545.809" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="450.553 567.013" size="normal" stroke="red"/>+<use name="mark/disk(sx)" pos="343.978 524.606" size="normal" stroke="red"/>+<path stroke="red">+102.465 0 0 102.465 382.758 550.831 e+</path>+<use layer="gamma" matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="368 608" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 9.39047 -5.35868" name="mark/disk(sx)" pos="336 608" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="352 592" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 16.6443 -3.68472" name="mark/disk(sx)" pos="368 576" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 9.39047 5.24305" name="mark/disk(sx)" pos="320 576" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 -1.76925 -7.03264" name="mark/disk(sx)" pos="352 576" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 37.2898 -10.9385" name="mark/disk(sx)" pos="400 608" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="400 576" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="304 560" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="368 544" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="379.689 503.96" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="409.82 541.903" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="363.507 541.345" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="437.719 527.954" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="403.682 564.223" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="409.82 562.549" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="414.284 563.107" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="462.271 545.809" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="450.553 567.013" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="343.978 524.606" size="normal" stroke="blue"/>+<use layer="delta" name="mark/disk(sx)" pos="71.4684 472.509" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="90.3283 458.001" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="75.0953 453.649" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="101.209 426.084" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="45.3547 421.732" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="76.5461 421.007" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="56.9608 430.437" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="85.2506 433.338" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="113.541 435.514" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="75.0953 453.649" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="46.8054 454.374" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 39.896 -3.62691" name="mark/disk(sx)" pos="75.0953 453.649" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="105.561 473.96" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="107.012 458.727" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="135.302 418.105" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 4.52803 -3.42357" name="mark/disk(sx)" pos="101.209 426.084" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="90.2821 422.711" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="118.434 461.101" size="normal" stroke="blue"/>+<use matrix="1 0 0 1 5.59154 0.698943" name="mark/disk(sx)" pos="57.5231 446.257" size="normal" stroke="blue"/>+<use name="mark/disk(sx)" pos="68.9116 432.574" size="normal" stroke="blue"/>+</page>+</ipe>
+ test/Data/Geometry/Ipe/ReaderSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Geometry.Ipe.ReaderSpec where++import Test.Hspec+import Data.Ext+import Data.Geometry+import Data.Geometry.Ipe+import Data.ByteString(ByteString)+import Data.Proxy+++-- | specializes to use Double as Numtype+fromIpeXML' :: IpeRead (t Double) => ByteString -> Either ConversionError (t Double)+fromIpeXML' = fromIpeXML+++spec :: Spec+spec = do+    describe "IpeReadText" $ do+      it "parses a polyline into a Path" $+        ipeReadText "\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n"+        `shouldBe` Right ops+    describe "IpeReadAttrs" $ do+      it "parses a symbols attributes" $+        (show $ readXML useTxt+                >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double))+        `shouldBe`+        "Right (Attrs {_unAttrs = {GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Just (IpeColor (Valued \"black\"))}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Nothing}, GAttr {_getAttr = Just (IpeSize (Named \"normal\"))}}})"++    describe "IpeRead" $ do+      it "parses a Symbol" $+        fromIpeXML' useTxt+        `shouldBe` Right useSym+    -- it "parses a path" $+      --   (show $ fromIpeXML'+          -- "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+-- )+      --   `shouldBe`+-- "Right (Path {_pathSegments = PolyLineSegment (PolyLine {_points = Seq2 (Point2 [128.0,656.0] :+ ()) (fromList [Point2 [224.0,768.0] :+ (),Point2 [304.0,624.0] :+ ()]) (Point2 [432.0,752.0] :+ ())}) :< fromList []})"+++  where+    useTxt = "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+    useSym = Symbol (point2 320 736) "mark/disk(sx)"+--     symAttrs =++    translatedUse = "<use matrix=\"1 0 0 1 4.44908 -4.21815\" name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"+++++    ops = [ MoveTo $ point2 128 (656 :: Double)+          , LineTo $ point2 224 768+          , LineTo $ point2 304 624+          , LineTo $ point2 432 752+          ]
+ test/Data/Geometry/PointSpec.hs view
@@ -0,0 +1,87 @@+module Data.Geometry.PointSpec where++import Data.Ext+import Data.Geometry.Point+import Test.Hspec+import qualified Data.CircularList as C+++spec :: Spec+spec = do+  describe "Sort Arround a Point test" $ do+    it "Sort around origin" $+      sortArround (ext origin) (map ext [ point2 (-3) (-3)+                                        , point2 (-1) (-5)+                                        , point2 5    5+                                        , point2 6    (-4)+                                        , point2 (-5) 3+                                        , point2 10   1+                                        , point2 20   0+                                        , point2 0    (-6)+                                        , point2 5    7+                                        , point2 5    5+                                        , point2 2    2+                                        , point2 26   (-2)+                                        , point2 0    (-5)+                                        ])+      `shouldBe` map ext [ point2 20   0+                         , point2 10   1+                         , point2 2    2+                         , point2 5    5+                         , point2 5    5+                         , point2 5    7+                         , point2 (-5) 3+                         , point2 (-3) (-3)+                         , point2 (-1) (-5)+                         , point2 0    (-5)+                         , point2 0    (-6)+                         , point2 6    (-4)+                         , point2 26   (-2)+                         ]+    it "degenerate points on horizontal line" $+      sortArround (ext origin) (map ext [ point2 2    0+                                        , point2 (-1) 0+                                        , point2 10   0+                                        ])+      `shouldBe` map ext [ point2 2 0, point2 10 0, point2 (-1) 0 ]+    it "degenerate points on vertical line" $+      sortArround (ext origin) (map ext [ point2 0 2+                                        , point2 0 (-1)+                                        , point2 0 10+                                        ])+      `shouldBe` map ext [ point2 0 2, point2 0 10, point2 0 (-1) ]+++  describe "Insert point in ciclically ordered list" $ do+    it "insert" $+      insertIntoCyclicOrder (ext origin) (ext $ point2 (-4) (-5))  (+        C.fromList $ map ext [ point2 20   0+                             , point2 10   1+                             , point2 2    2+                             , point2 5    5+                             , point2 5    5+                             , point2 5    7+                             , point2 (-5) 3+                             , point2 (-3) (-3)+                             , point2 (-1) (-5)+                             , point2 0    (-5)+                             , point2 0    (-6)+                             , point2 6    (-4)+                             , point2 26   (-2)+                             ])+      `shouldBe`+        (C.fromList $ map ext [ point2 20   0+                              , point2 10   1+                              , point2 2    2+                              , point2 5    5+                              , point2 5    5+                              , point2 5    7+                              , point2 (-5) 3+                              , point2 (-3) (-3)+                              , point2 (-4) (-5)+                              , point2 (-1) (-5)+                              , point2 0    (-5)+                              , point2 0    (-6)+                              , point2 6    (-4)+                              , point2 26   (-2)+                              ])
+ test/Data/Geometry/Polygon/Convex/ConvexSpec.hs view
@@ -0,0 +1,59 @@+module Data.Geometry.Polygon.Convex.ConvexSpec where++import           Control.Applicative+import           Control.Arrow ((&&&))+import           Control.Lens+import           Data.Ext+import qualified Data.Foldable as F+import           Data.Geometry+import           Data.Geometry.Ipe+import           Data.Geometry.Polygon (extremesLinear)+import           Data.Geometry.Polygon.Convex+import           Data.Traversable (traverse)+import           Test.Hspec++++spec :: Spec+spec = testCases "test/Data/Geometry/Polygon/Convex/convexTests.ipe"++testCases    :: FilePath -> Spec+testCases fp = runIO (readInputFromFile fp) >>= \case+    Left e    -> it "reading ConvexTests file" $+                   expectationFailure . unwords $+                     [ "Failed to read ipe file", show fp, ":", show e]+    Right tcs -> mapM_ toSpec tcs+++data TestCase r = TestCase { _polygon    :: ConvexPolygon () r+                           }+                  deriving (Show)++toSingleSpec        :: (Num r, Ord r, Show r)+                    => ConvexPolygon q r -> Vector 2 r -> SpecWith ()+toSingleSpec poly u = it msg $+  -- test that the reported extremes are equally far in direction u+    F.all allEq (unzip [extremes u poly, extremesLinear u poly]) `shouldBe` True+  where+    allEq (p:ps) = all (\q -> cmpExtreme u p q == EQ) ps+    msg = "Extremes test with direction " ++ show u++-- | generates 360 vectors "equally" spaced/angled+directions :: Num r => [Vector 2 r]+directions = map (fmap toRat . uncurry v2 . (cos &&& sin) . toRad) ([0..359] :: [Double])+  where+    toRad i = i * (pi / 180)+    toRat x = fromIntegral . round $ 100000 * x++toSpec                 :: (Num r, Ord r, Show r) => TestCase r -> SpecWith ()+toSpec (TestCase poly) = do+                           describe "Extreme points; binsearch same as linear" $+                             mapM_ (toSingleSpec poly) directions+++readInputFromFile    :: FilePath -> IO (Either ConversionError [TestCase Rational])+readInputFromFile fp = fmap f <$> readSinglePageFile fp+  where+    f page = [ TestCase poly | (poly :+ _) <- polies ]+      where+        polies = page^..content.traverse._withAttrs _IpePath _asSimplePolygon
+ test/Data/Geometry/Polygon/Convex/convexTests.ipe view
@@ -0,0 +1,308 @@+<?xml version="1.0"?>+<!DOCTYPE ipe SYSTEM "ipe.dtd">+<ipe version="70107" creator="Ipe 7.2.2">+<info created="D:20160608222645" modified="D:20160611094216"/>+<ipestyle name="basic">+<symbol name="arrow/arc(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/farc(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/ptarc(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/fptarc(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="mark/circle(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+0.4 0 0 0.4 0 0 e+</path>+</symbol>+<symbol name="mark/disk(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+</path>+</symbol>+<symbol name="mark/fdisk(sfx)" transformations="translations">+<group>+<path fill="sym-fill">+0.5 0 0 0.5 0 0 e+</path>+<path fill="sym-stroke" fillrule="eofill">+0.6 0 0 0.6 0 0 e+0.4 0 0 0.4 0 0 e+</path>+</group>+</symbol>+<symbol name="mark/box(sx)" transformations="translations">+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+-0.4 -0.4 m+0.4 -0.4 l+0.4 0.4 l+-0.4 0.4 l+h+</path>+</symbol>+<symbol name="mark/square(sx)" transformations="translations">+<path fill="sym-stroke">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+</path>+</symbol>+<symbol name="mark/fsquare(sfx)" transformations="translations">+<group>+<path fill="sym-fill">+-0.5 -0.5 m+0.5 -0.5 l+0.5 0.5 l+-0.5 0.5 l+h+</path>+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+-0.4 -0.4 m+0.4 -0.4 l+0.4 0.4 l+-0.4 0.4 l+h+</path>+</group>+</symbol>+<symbol name="mark/cross(sx)" transformations="translations">+<group>+<path fill="sym-stroke">+-0.43 -0.57 m+0.57 0.43 l+0.43 0.57 l+-0.57 -0.43 l+h+</path>+<path fill="sym-stroke">+-0.43 0.57 m+0.57 -0.43 l+0.43 -0.57 l+-0.57 0.43 l+h+</path>+</group>+</symbol>+<symbol name="arrow/fnormal(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/pointed(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/fpointed(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/linear(spx)">+<path stroke="sym-stroke" pen="sym-pen">+-1 0.333 m+0 0 l+-1 -0.333 l+</path>+</symbol>+<symbol name="arrow/fdouble(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+-1 0 m+-2 0.333 l+-2 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/double(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+-1 0 m+-2 0.333 l+-2 -0.333 l+h+</path>+</symbol>+<pen name="heavier" value="0.8"/>+<pen name="fat" value="1.2"/>+<pen name="ultrafat" value="2"/>+<symbolsize name="large" value="5"/>+<symbolsize name="small" value="2"/>+<symbolsize name="tiny" value="1.1"/>+<arrowsize name="large" value="10"/>+<arrowsize name="small" value="5"/>+<arrowsize name="tiny" value="3"/>+<color name="red" value="1 0 0"/>+<color name="green" value="0 1 0"/>+<color name="blue" value="0 0 1"/>+<color name="yellow" value="1 1 0"/>+<color name="orange" value="1 0.647 0"/>+<color name="gold" value="1 0.843 0"/>+<color name="purple" value="0.627 0.125 0.941"/>+<color name="gray" value="0.745"/>+<color name="brown" value="0.647 0.165 0.165"/>+<color name="navy" value="0 0 0.502"/>+<color name="pink" value="1 0.753 0.796"/>+<color name="seagreen" value="0.18 0.545 0.341"/>+<color name="turquoise" value="0.251 0.878 0.816"/>+<color name="violet" value="0.933 0.51 0.933"/>+<color name="darkblue" value="0 0 0.545"/>+<color name="darkcyan" value="0 0.545 0.545"/>+<color name="darkgray" value="0.663"/>+<color name="darkgreen" value="0 0.392 0"/>+<color name="darkmagenta" value="0.545 0 0.545"/>+<color name="darkorange" value="1 0.549 0"/>+<color name="darkred" value="0.545 0 0"/>+<color name="lightblue" value="0.678 0.847 0.902"/>+<color name="lightcyan" value="0.878 1 1"/>+<color name="lightgray" value="0.827"/>+<color name="lightgreen" value="0.565 0.933 0.565"/>+<color name="lightyellow" value="1 1 0.878"/>+<dashstyle name="dashed" value="[4] 0"/>+<dashstyle name="dotted" value="[1 3] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<textsize name="large" value="\large"/>+<textsize name="Large" value="\Large"/>+<textsize name="LARGE" value="\LARGE"/>+<textsize name="huge" value="\huge"/>+<textsize name="Huge" value="\Huge"/>+<textsize name="small" value="\small"/>+<textsize name="footnote" value="\footnotesize"/>+<textsize name="tiny" value="\tiny"/>+<textstyle name="center" begin="\begin{center}" end="\end{center}"/>+<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>+<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>+<gridsize name="4 pts" value="4"/>+<gridsize name="8 pts (~3 mm)" value="8"/>+<gridsize name="16 pts (~6 mm)" value="16"/>+<gridsize name="32 pts (~12 mm)" value="32"/>+<gridsize name="10 pts (~3.5 mm)" value="10"/>+<gridsize name="20 pts (~7 mm)" value="20"/>+<gridsize name="14 pts (~5 mm)" value="14"/>+<gridsize name="28 pts (~10 mm)" value="28"/>+<gridsize name="56 pts (~20 mm)" value="56"/>+<anglesize name="90 deg" value="90"/>+<anglesize name="60 deg" value="60"/>+<anglesize name="45 deg" value="45"/>+<anglesize name="30 deg" value="30"/>+<anglesize name="22.5 deg" value="22.5"/>+<opacity name="10%" value="0.1"/>+<opacity name="30%" value="0.3"/>+<opacity name="50%" value="0.5"/>+<opacity name="75%" value="0.75"/>+<tiling name="falling" angle="-60" step="4" width="1"/>+<tiling name="rising" angle="30" step="4" width="1"/>+</ipestyle>+<ipestyle name="frank">+<arrowsize name="normal" value="5"/>+<arrowsize name="large" value="8"/>+<arrowsize name="huge" value="10"/>+<arrowsize name="small" value="3"/>+<arrowsize name="tiny" value="1"/>+<dashstyle name="dashed" value="[2 2] 0"/>+<dashstyle name="dotted" value="[0.5 1] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<gridsize name="1 pts" value="1"/>+<gridsize name="2 pts" value="2"/>+<opacity name="10%" value="0.1"/>+<opacity name="30%" value="0.3"/>+<opacity name="50%" value="0.5"/>+<opacity name="20%" value="0.2"/>+<opacity name="40%" value="0.4"/>+<opacity name="60%" value="0.6"/>+<opacity name="70%" value="0.7"/>+<opacity name="80%" value="0.8"/>+<opacity name="90%" value="0.9"/>+</ipestyle>+<page>+<layer name="alpha"/>+<layer name="beta"/>+<view layers="alpha beta" active="beta"/>+<path layer="alpha" stroke="black">+144 720 m+224 768 l+368 672 l+320 592 l+240 544 l+112 528 l+96 640 l+h+</path>+<path stroke="black">+224 656 m+352 784 l+416 816 l+544 800 l+576 752 l+592 720 l+592 672 l+576 640 l+544 608 l+480 560 l+400 544 l+320 544 l+272 560 l+240 608 l+h+</path>+</page>+</ipe>
+ test/Data/Geometry/PolygonSpec.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Geometry.PolygonSpec where++import Data.Traversable(traverse)+import Data.Ext+import Control.Lens+import Control.Applicative+import Data.Geometry+import Data.Geometry.Boundary+import Data.Geometry.Ipe+import Data.Proxy+import Test.Hspec++spec :: Spec+spec = testCases "test/Data/Geometry/pointInPolygon.ipe"+++testCases    :: FilePath -> Spec+testCases fp = runIO (readInputFromFile fp) >>= \case+    Left e    -> it "reading point in polygon file" $+                   expectationFailure $ "Failed to read ipe file " ++ show e+    Right tcs -> mapM_ toSpec tcs+++--   ipeF <- beforeAll $ readInputFromFile "tests/Data/Geometry/pointInPolygon.ipe"+--   describe "Point in Polygon tests" $ do+--     it "returns the first element of a list" $ do+--       head [23 ..] `shouldBe` (23 :: Int)+++data TestCase r = TestCase { _polygon    :: SimplePolygon () r+                           , _inside     :: [Point 2 r]+                           , _onBoundary :: [Point 2 r]+                           , _outside    :: [Point 2 r]+                           }+                  deriving (Show)+++toSingleSpec poly r q = it msg $ (q `inPolygon` poly) `shouldBe` r+  where+    msg = "Point in polygon test with " ++ show q+++toSpec (TestCase poly is bs os) = do+                                    describe "inside tests" $+                                      mapM_ (toSingleSpec poly Inside) is+                                    describe "on boundary tests" $+                                      mapM_ (toSingleSpec poly OnBoundary) bs+                                    describe "outside tests" $+                                      mapM_ (toSingleSpec poly Outside) os++readInputFromFile    :: FilePath -> IO (Either ConversionError [TestCase Rational])+readInputFromFile fp = fmap f <$> readSinglePageFile fp+  where+    f page = [ TestCase poly+                        [ s^.symbolPoint | s <- myPoints ats, isInsidePt  s ]+                        [ s^.symbolPoint | s <- myPoints ats, isBorderPt  s ]+                        [ s^.symbolPoint | s <- myPoints ats, isOutsidePt s ]+             | (poly :+ ats) <- polies+             ]+      where+        polies = page^..content.traverse._withAttrs _IpePath _asSimplePolygon+        syms   = page^..content.traverse._IpeUse+++        myPoints polyAts = [s | (s :+ ats) <- syms, belongsToPoly ats polyAts ]++        -- We test a point/polygon combination if they have the same color+        belongsToPoly symAts polyAts =+            lookupAttr colorP symAts == lookupAttr colorP polyAts++        -- A point i inside if it is a disk+        isInsidePt   :: IpeSymbol r -> Bool+        isInsidePt s = s^.symbolName == "mark/disk(sx)"++        -- Boxes are on the boundary+        isBorderPt s = s^.symbolName == "mark/box(sx)"++        -- crosses are outside the polygon+        isOutsidePt s = s^.symbolName == "mark/cross(sx)"++        colorP = Proxy :: Proxy Stroke+++++-- main = readInputFromFile "tests/Data/Geometry/pointInPolygon.ipe"
+ test/Data/Geometry/pointInPolygon.ipe view
@@ -0,0 +1,311 @@+<?xml version="1.0"?>+<!DOCTYPE ipe SYSTEM "ipe.dtd">+<ipe version="70107" creator="Ipe 7.1.7">+<info created="D:20150923215046" modified="D:20150924223742"/>+<ipestyle name="basic">+<symbol name="arrow/arc(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/farc(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/ptarc(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/fptarc(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="mark/circle(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+0.4 0 0 0.4 0 0 e+</path>+</symbol>+<symbol name="mark/disk(sx)" transformations="translations">+<path fill="sym-stroke">+0.6 0 0 0.6 0 0 e+</path>+</symbol>+<symbol name="mark/fdisk(sfx)" transformations="translations">+<group>+<path fill="sym-fill">+0.5 0 0 0.5 0 0 e+</path>+<path fill="sym-stroke" fillrule="eofill">+0.6 0 0 0.6 0 0 e+0.4 0 0 0.4 0 0 e+</path>+</group>+</symbol>+<symbol name="mark/box(sx)" transformations="translations">+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+-0.4 -0.4 m+0.4 -0.4 l+0.4 0.4 l+-0.4 0.4 l+h+</path>+</symbol>+<symbol name="mark/square(sx)" transformations="translations">+<path fill="sym-stroke">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+</path>+</symbol>+<symbol name="mark/fsquare(sfx)" transformations="translations">+<group>+<path fill="sym-fill">+-0.5 -0.5 m+0.5 -0.5 l+0.5 0.5 l+-0.5 0.5 l+h+</path>+<path fill="sym-stroke" fillrule="eofill">+-0.6 -0.6 m+0.6 -0.6 l+0.6 0.6 l+-0.6 0.6 l+h+-0.4 -0.4 m+0.4 -0.4 l+0.4 0.4 l+-0.4 0.4 l+h+</path>+</group>+</symbol>+<symbol name="mark/cross(sx)" transformations="translations">+<group>+<path fill="sym-stroke">+-0.43 -0.57 m+0.57 0.43 l+0.43 0.57 l+-0.57 -0.43 l+h+</path>+<path fill="sym-stroke">+-0.43 0.57 m+0.57 -0.43 l+0.43 -0.57 l+-0.57 0.43 l+h+</path>+</group>+</symbol>+<symbol name="arrow/fnormal(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/pointed(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/fpointed(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-0.8 0 l+-1 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/linear(spx)">+<path stroke="sym-stroke" pen="sym-pen">+-1 0.333 m+0 0 l+-1 -0.333 l+</path>+</symbol>+<symbol name="arrow/fdouble(spx)">+<path stroke="sym-stroke" fill="white" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+-1 0 m+-2 0.333 l+-2 -0.333 l+h+</path>+</symbol>+<symbol name="arrow/double(spx)">+<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">+0 0 m+-1 0.333 l+-1 -0.333 l+h+-1 0 m+-2 0.333 l+-2 -0.333 l+h+</path>+</symbol>+<pen name="heavier" value="0.8"/>+<pen name="fat" value="1.2"/>+<pen name="ultrafat" value="2"/>+<symbolsize name="large" value="5"/>+<symbolsize name="small" value="2"/>+<symbolsize name="tiny" value="1.1"/>+<arrowsize name="large" value="10"/>+<arrowsize name="small" value="5"/>+<arrowsize name="tiny" value="3"/>+<color name="red" value="1 0 0"/>+<color name="green" value="0 1 0"/>+<color name="blue" value="0 0 1"/>+<color name="yellow" value="1 1 0"/>+<color name="orange" value="1 0.647 0"/>+<color name="gold" value="1 0.843 0"/>+<color name="purple" value="0.627 0.125 0.941"/>+<color name="gray" value="0.745"/>+<color name="brown" value="0.647 0.165 0.165"/>+<color name="navy" value="0 0 0.502"/>+<color name="pink" value="1 0.753 0.796"/>+<color name="seagreen" value="0.18 0.545 0.341"/>+<color name="turquoise" value="0.251 0.878 0.816"/>+<color name="violet" value="0.933 0.51 0.933"/>+<color name="darkblue" value="0 0 0.545"/>+<color name="darkcyan" value="0 0.545 0.545"/>+<color name="darkgray" value="0.663"/>+<color name="darkgreen" value="0 0.392 0"/>+<color name="darkmagenta" value="0.545 0 0.545"/>+<color name="darkorange" value="1 0.549 0"/>+<color name="darkred" value="0.545 0 0"/>+<color name="lightblue" value="0.678 0.847 0.902"/>+<color name="lightcyan" value="0.878 1 1"/>+<color name="lightgray" value="0.827"/>+<color name="lightgreen" value="0.565 0.933 0.565"/>+<color name="lightyellow" value="1 1 0.878"/>+<dashstyle name="dashed" value="[4] 0"/>+<dashstyle name="dotted" value="[1 3] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<textsize name="large" value="\large"/>+<textsize name="Large" value="\Large"/>+<textsize name="LARGE" value="\LARGE"/>+<textsize name="huge" value="\huge"/>+<textsize name="Huge" value="\Huge"/>+<textsize name="small" value="\small"/>+<textsize name="footnote" value="\footnotesize"/>+<textsize name="tiny" value="\tiny"/>+<textstyle name="center" begin="\begin{center}" end="\end{center}"/>+<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>+<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>+<gridsize name="4 pts" value="4"/>+<gridsize name="8 pts (~3 mm)" value="8"/>+<gridsize name="16 pts (~6 mm)" value="16"/>+<gridsize name="32 pts (~12 mm)" value="32"/>+<gridsize name="10 pts (~3.5 mm)" value="10"/>+<gridsize name="20 pts (~7 mm)" value="20"/>+<gridsize name="14 pts (~5 mm)" value="14"/>+<gridsize name="28 pts (~10 mm)" value="28"/>+<gridsize name="56 pts (~20 mm)" value="56"/>+<anglesize name="90 deg" value="90"/>+<anglesize name="60 deg" value="60"/>+<anglesize name="45 deg" value="45"/>+<anglesize name="30 deg" value="30"/>+<anglesize name="22.5 deg" value="22.5"/>+<tiling name="falling" angle="-60" step="4" width="1"/>+<tiling name="rising" angle="30" step="4" width="1"/>+</ipestyle>+<ipestyle name="frank">+<arrowsize name="normal" value="5"/>+<arrowsize name="large" value="8"/>+<arrowsize name="huge" value="10"/>+<arrowsize name="small" value="3"/>+<arrowsize name="tiny" value="1"/>+<dashstyle name="dashed" value="[2 2] 0"/>+<dashstyle name="dotted" value="[0.5 1] 0"/>+<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>+<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>+<gridsize name="1 pts" value="1"/>+<gridsize name="2 pts" value="2"/>+<opacity name="10%" value="0.1"/>+<opacity name="20%" value="0.2"/>+<opacity name="30%" value="0.3"/>+<opacity name="40%" value="0.4"/>+<opacity name="50%" value="0.5"/>+<opacity name="60%" value="0.6"/>+<opacity name="70%" value="0.7"/>+<opacity name="80%" value="0.8"/>+<opacity name="90%" value="0.9"/>+</ipestyle>+<page>+<layer name="alpha"/>+<view layers="alpha" active="alpha"/>+<path layer="alpha" stroke="darkblue">+208 752 m+304 688 l+224 592 l+48 736 l+h+</path>+<use name="mark/disk(sx)" pos="128 704" size="normal" stroke="darkblue"/>+<use name="mark/disk(sx)" pos="192 672" size="normal" stroke="darkblue"/>+<use name="mark/disk(sx)" pos="192 720" size="normal" stroke="darkblue"/>+<use name="mark/box(sx)" pos="304 688" size="normal" stroke="black"/>+<use name="mark/cross(sx)" pos="352 736" size="normal" stroke="darkblue"/>+<use name="mark/cross(sx)" pos="352 704" size="normal" stroke="darkblue"/>+<path stroke="orange">+496 736 m+432 624 l+512 608 l+h+</path>+<use name="mark/box(sx)" pos="432 624" size="normal" stroke="orange"/>+<use name="mark/box(sx)" pos="512 608" size="normal" stroke="orange"/>+<use name="mark/box(sx)" pos="496 736" size="normal" stroke="orange"/>+<use name="mark/disk(sx)" pos="496 656" size="normal" stroke="orange"/>+<use name="mark/disk(sx)" pos="480 640" size="normal" stroke="orange"/>+<use name="mark/disk(sx)" pos="464 656" size="normal" stroke="orange"/>+<use name="mark/cross(sx)" pos="368 608" size="normal" stroke="orange"/>+<use name="mark/cross(sx)" pos="384 592" size="normal" stroke="orange"/>+<use name="mark/cross(sx)" pos="336 576" size="normal" stroke="orange"/>+<use name="mark/disk(sx)" pos="496 624" size="normal" stroke="orange"/>+<use name="mark/cross(sx)" pos="528 624" size="normal" stroke="orange"/>+<use name="mark/cross(sx)" pos="384 624" size="normal" stroke="orange"/>+<use name="mark/cross(sx)" pos="368 640" size="normal" stroke="orange"/>+<use name="mark/cross(sx)" pos="336 688" size="normal" stroke="darkblue"/>+<use name="mark/disk(sx)" pos="256 688" size="normal" stroke="darkblue"/>+<use name="mark/disk(sx)" pos="224 688" size="normal" stroke="darkblue"/>+</page>+</ipe>
+ test/Data/RangeSpec.hs view
@@ -0,0 +1,49 @@+module Data.RangeSpec where++import Data.Geometry.Properties+import Data.Range+import Frames.CoRec+import Test.Hspec+++spec :: Spec+spec = do+  describe "RangeRange Intersection" $ do+    -- it "openRange cap openrange" $ do+    --   ((OpenRange 1 (10 :: Int))  `intersect` (OpenRange 5 (10 :: Int)))+    --   `shouldBe` (coRec $ OpenRange 5 (10 :: Int))+    -- it "disjoint open ranges" $ do+    --   ((OpenRange 1 10) `intersect` (OpenRange 10 12))+    --   `shouldBe` (coRec NoIntersection)+    -- it "closed cap open, disjoint" $ do+    --   ((ClosedRange (1::Int) 10) `intersect` (OpenRange 50 (60 :: Int)))+    --   `shouldBe` (coRec NoIntersection)+    -- it "closed intersect open" $+    --   ((OpenRange 1 10) `intersect` (ClosedRange 10 12))+    --   `shouldBe` (coRec $ Range (Open 5) (Closed 10))++    -- it "open rage intersect closed " $+    -- (OpenRange 1 10) `intersect` (ClosedRange 10 12)+    -- `shouldBe` (coRec $ Range (Open 10) (Open 10))+  -- (Col Range {_lower = Closed 10, _upper = Open 10})+  -- >>> (OpenRange 1 10) `intersect` (ClosedRange 10 12)++    it "returns the first element of a list" $ do+      head [23 ..] `shouldBe` (23 :: Int)++    -- it "closed open " $ do+    --   ((ClosedRange 1 10) `intersect` (OpenRange 5 10))+    --   `shouldBe`+    --   (Col (Range (Open 5) (Closed 10)))+            -- encode "no-padding!!" `shouldBe` "bm8tcGFkZGluZyEh"++    -- |+  --+  -- >>>+  --+  -- >>>+  -- (Col NoIntersection)+  -- >>> (OpenRange 1 10) `intersect` (ClosedRange 10 12)+  -- (Col Range {_lower = Closed 10, _upper = Open 10})+  -- >>> (OpenRange 1 10) `intersect` (ClosedRange 10 12)+  -- FALSE
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Util.hs view
@@ -0,0 +1,14 @@+module Util where++import Data.Vinyl+import Data.Geometry.Ipe+import Data.Proxy+import Data.Ext+import Data.Function(on)+import qualified Data.List as L++byStrokeColour :: (Stroke ∈ AttributesOf g) => [IpeObject' g r] -> [[IpeObject' g r]]+byStrokeColour = map (map fst) . L.groupBy ((==) `on` snd) . L.sortOn snd+               . map (\x -> (x,lookup' x))+  where+    lookup' (_ :+ ats) = lookupAttr (Proxy :: Proxy Stroke) ats