diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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! diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -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" + ] diff --git a/examples/BAPC2012/Gunslinger.hs b/examples/BAPC2012/Gunslinger.hs new file mode 100644 --- /dev/null +++ b/examples/BAPC2012/Gunslinger.hs @@ -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 diff --git a/examples/BAPC2014/Armybase.lhs b/examples/BAPC2014/Armybase.lhs new file mode 100644 --- /dev/null +++ b/examples/BAPC2014/Armybase.lhs @@ -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$. + + +
+There is an maximum area quadrangle $Q^*$, such that $V(Q^*) \subseteq +V(\mathcal{CH}(P))$. +
+ +
+TODO +
+ + +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 + + +
+Left an Right chains are independent +
+ +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. + +
+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$. +
+ +
+TODO +
+ +
+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. +
+ +
+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. +
+ +
+Directly from previous lemma and observation. +
+ +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)] diff --git a/examples/Demo/Delaunay.hs b/examples/Demo/Delaunay.hs new file mode 100644 --- /dev/null +++ b/examples/Demo/Delaunay.hs @@ -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)) ] diff --git a/examples/Demo/DrawGPX.hs b/examples/Demo/DrawGPX.hs new file mode 100644 --- /dev/null +++ b/examples/Demo/DrawGPX.hs @@ -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 +-- 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 diff --git a/examples/Demo/GPXParser.hs b/examples/Demo/GPXParser.hs new file mode 100644 --- /dev/null +++ b/examples/Demo/GPXParser.hs @@ -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' diff --git a/examples/Demo/MinDisk.hs b/examples/Demo/MinDisk.hs new file mode 100644 --- /dev/null +++ b/examples/Demo/MinDisk.hs @@ -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) diff --git a/examples/Demo/WriteEnsemble.hs b/examples/Demo/WriteEnsemble.hs new file mode 100644 --- /dev/null +++ b/examples/Demo/WriteEnsemble.hs @@ -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 diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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 diff --git a/hgeometry.cabal b/hgeometry.cabal --- a/hgeometry.cabal +++ b/hgeometry.cabal @@ -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 diff --git a/resources/basic.isy b/resources/basic.isy new file mode 100644 --- /dev/null +++ b/resources/basic.isy @@ -0,0 +1,141 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e + + + +0.6 0 0 0.6 0 0 e + + + +0.5 0 0 0.5 0 0 e + +0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e + + + +-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 + + +-0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h + + +-0.5 -0.5 m 0.5 -0.5 l 0.5 0.5 l -0.5 0.5 l h + +-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 + + +-0.43 -0.57 m 0.57 0.43 l 0.43 0.57 l -0.57 -0.43 l h + +-0.43 0.57 m 0.57 -0.43 l 0.43 -0.57 l -0.57 0.43 l h + + + +0 0 m -1.0 0.333 l -1.0 -0.333 l h + + +0 0 m -1.0 0.333 l -1.0 -0.333 l h + + +0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h + + +0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h + + +0 0 m -1.0 0.333 l -1.0 -0.333 l h + + +0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h + + +0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h + + +-1.0 0.333 m 0 0 l -1.0 -0.333 l + + +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 + + + +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 + + + + + + + + diff --git a/src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs b/src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/ConvexHull/DivideAndConqueror.hs @@ -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) diff --git a/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs b/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs --- a/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs +++ b/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs @@ -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 diff --git a/src/Algorithms/Geometry/ConvexHull/Types.hs b/src/Algorithms/Geometry/ConvexHull/Types.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/ConvexHull/Types.hs @@ -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 diff --git a/src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConqueror.hs b/src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConqueror.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConqueror.hs @@ -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 diff --git a/src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs b/src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs @@ -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 diff --git a/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs b/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs @@ -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) diff --git a/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs b/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs @@ -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 diff --git a/src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs b/src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs @@ -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 diff --git a/src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs b/src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs @@ -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)) diff --git a/src/Algorithms/Geometry/SmallestEnclosingBall/RandomizedIncrementalConstruction.hs b/src/Algorithms/Geometry/SmallestEnclosingBall/RandomizedIncrementalConstruction.hs --- a/src/Algorithms/Geometry/SmallestEnclosingBall/RandomizedIncrementalConstruction.hs +++ b/src/Algorithms/Geometry/SmallestEnclosingBall/RandomizedIncrementalConstruction.hs @@ -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 diff --git a/src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs b/src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs @@ -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 diff --git a/src/Algorithms/Graph/DFS.hs b/src/Algorithms/Graph/DFS.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Graph/DFS.hs @@ -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) diff --git a/src/Algorithms/Graph/MST.hs b/src/Algorithms/Graph/MST.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Graph/MST.hs @@ -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..] diff --git a/src/Algorithms/Util.hs b/src/Algorithms/Util.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Util.hs @@ -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] diff --git a/src/Control/Monad/State/Persistent.hs b/src/Control/Monad/State/Persistent.hs --- a/src/Control/Monad/State/Persistent.hs +++ b/src/Control/Monad/State/Persistent.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} module Control.Monad.State.Persistent( PersistentStateT , PersistentState , store diff --git a/src/Data/BinaryTree.hs b/src/Data/BinaryTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/BinaryTree.hs @@ -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 diff --git a/src/Data/CircularList/Util.hs b/src/Data/CircularList/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/CircularList/Util.hs @@ -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 diff --git a/src/Data/CircularSeq.hs b/src/Data/CircularSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/CircularSeq.hs @@ -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 diff --git a/src/Data/Ext.hs b/src/Data/Ext.hs --- a/src/Data/Ext.hs +++ b/src/Data/Ext.hs @@ -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 :+ () diff --git a/src/Data/Geometry.hs b/src/Data/Geometry.hs --- a/src/Data/Geometry.hs +++ b/src/Data/Geometry.hs @@ -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 diff --git a/src/Data/Geometry/Ball.hs b/src/Data/Geometry/Ball.hs --- a/src/Data/Geometry/Ball.hs +++ b/src/Data/Geometry/Ball.hs @@ -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 diff --git a/src/Data/Geometry/Boundary.hs b/src/Data/Geometry/Boundary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Boundary.hs @@ -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) diff --git a/src/Data/Geometry/Box.hs b/src/Data/Geometry/Box.hs --- a/src/Data/Geometry/Box.hs +++ b/src/Data/Geometry/Box.hs @@ -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) diff --git a/src/Data/Geometry/Box/Internal.hs b/src/Data/Geometry/Box/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Box/Internal.hs @@ -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) diff --git a/src/Data/Geometry/Duality.hs b/src/Data/Geometry/Duality.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Duality.hs @@ -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 diff --git a/src/Data/Geometry/HalfLine.hs b/src/Data/Geometry/HalfLine.hs --- a/src/Data/Geometry/HalfLine.hs +++ b/src/Data/Geometry/HalfLine.hs @@ -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) diff --git a/src/Data/Geometry/Interval.hs b/src/Data/Geometry/Interval.hs --- a/src/Data/Geometry/Interval.hs +++ b/src/Data/Geometry/Interval.hs @@ -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) diff --git a/src/Data/Geometry/Ipe.hs b/src/Data/Geometry/Ipe.hs --- a/src/Data/Geometry/Ipe.hs +++ b/src/Data/Geometry/Ipe.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/Attributes.hs b/src/Data/Geometry/Ipe/Attributes.hs --- a/src/Data/Geometry/Ipe/Attributes.hs +++ b/src/Data/Geometry/Ipe/Attributes.hs @@ -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) + +-- diff --git a/src/Data/Geometry/Ipe/FromIpe.hs b/src/Data/Geometry/Ipe/FromIpe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/FromIpe.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/IpeOut.hs b/src/Data/Geometry/Ipe/IpeOut.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/IpeOut.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/Literal.hs b/src/Data/Geometry/Ipe/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ipe/Literal.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/ParserPrimitives.hs b/src/Data/Geometry/Ipe/ParserPrimitives.hs --- a/src/Data/Geometry/Ipe/ParserPrimitives.hs +++ b/src/Data/Geometry/Ipe/ParserPrimitives.hs @@ -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 () diff --git a/src/Data/Geometry/Ipe/PathParser.hs b/src/Data/Geometry/Ipe/PathParser.hs --- a/src/Data/Geometry/Ipe/PathParser.hs +++ b/src/Data/Geometry/Ipe/PathParser.hs @@ -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" diff --git a/src/Data/Geometry/Ipe/Reader.hs b/src/Data/Geometry/Ipe/Reader.hs --- a/src/Data/Geometry/Ipe/Reader.hs +++ b/src/Data/Geometry/Ipe/Reader.hs @@ -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 = "" + + + + +-- 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 = "\n128 656 m\n224 768 l\n304 624 l\n432 752 l\n" -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 + +-------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/Ipe/Types.hs b/src/Data/Geometry/Ipe/Types.hs --- a/src/Data/Geometry/Ipe/Types.hs +++ b/src/Data/Geometry/Ipe/Types.hs @@ -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 diff --git a/src/Data/Geometry/Ipe/Writer.hs b/src/Data/Geometry/Ipe/Writer.hs --- a/src/Data/Geometry/Ipe/Writer.hs +++ b/src/Data/Geometry/Ipe/Writer.hs @@ -1,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 +-- ) diff --git a/src/Data/Geometry/Line.hs b/src/Data/Geometry/Line.hs --- a/src/Data/Geometry/Line.hs +++ b/src/Data/Geometry/Line.hs @@ -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] diff --git a/src/Data/Geometry/Line/Internal.hs b/src/Data/Geometry/Line/Internal.hs --- a/src/Data/Geometry/Line/Internal.hs +++ b/src/Data/Geometry/Line/Internal.hs @@ -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) diff --git a/src/Data/Geometry/LineSegment.hs b/src/Data/Geometry/LineSegment.hs --- a/src/Data/Geometry/LineSegment.hs +++ b/src/Data/Geometry/LineSegment.hs @@ -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 diff --git a/src/Data/Geometry/Point.hs b/src/Data/Geometry/Point.hs --- a/src/Data/Geometry/Point.hs +++ b/src/Data/Geometry/Point.hs @@ -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 diff --git a/src/Data/Geometry/PolyLine.hs b/src/Data/Geometry/PolyLine.hs --- a/src/Data/Geometry/PolyLine.hs +++ b/src/Data/Geometry/PolyLine.hs @@ -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 diff --git a/src/Data/Geometry/Polygon.hs b/src/Data/Geometry/Polygon.hs --- a/src/Data/Geometry/Polygon.hs +++ b/src/Data/Geometry/Polygon.hs @@ -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) diff --git a/src/Data/Geometry/Polygon/Convex.hs b/src/Data/Geometry/Polygon/Convex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Polygon/Convex.hs @@ -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: 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 diff --git a/src/Data/Geometry/Properties.hs b/src/Data/Geometry/Properties.hs --- a/src/Data/Geometry/Properties.hs +++ b/src/Data/Geometry/Properties.hs @@ -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 diff --git a/src/Data/Geometry/Slab.hs b/src/Data/Geometry/Slab.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Slab.hs @@ -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 diff --git a/src/Data/Geometry/SubLine.hs b/src/Data/Geometry/SubLine.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/SubLine.hs @@ -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) diff --git a/src/Data/Geometry/Transformation.hs b/src/Data/Geometry/Transformation.hs --- a/src/Data/Geometry/Transformation.hs +++ b/src/Data/Geometry/Transformation.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/Triangle.hs b/src/Data/Geometry/Triangle.hs --- a/src/Data/Geometry/Triangle.hs +++ b/src/Data/Geometry/Triangle.hs @@ -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) diff --git a/src/Data/Geometry/Vector.hs b/src/Data/Geometry/Vector.hs --- a/src/Data/Geometry/Vector.hs +++ b/src/Data/Geometry/Vector.hs @@ -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 diff --git a/src/Data/Geometry/Vector/VectorFixed.hs b/src/Data/Geometry/Vector/VectorFixed.hs --- a/src/Data/Geometry/Vector/VectorFixed.hs +++ b/src/Data/Geometry/Vector/VectorFixed.hs @@ -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)) diff --git a/src/Data/Permutation.hs b/src/Data/Permutation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Permutation.hs @@ -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) diff --git a/src/Data/PlanarGraph.hs b/src/Data/PlanarGraph.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlanarGraph.hs @@ -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..] diff --git a/src/Data/PlaneGraph.hs b/src/Data/PlaneGraph.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlaneGraph.hs @@ -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 diff --git a/src/Data/Range.hs b/src/Data/Range.hs new file mode 100644 --- /dev/null +++ b/src/Data/Range.hs @@ -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) diff --git a/src/Data/Seq2.hs b/src/Data/Seq2.hs --- a/src/Data/Seq2.hs +++ b/src/Data/Seq2.hs @@ -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 diff --git a/src/Data/Sequence/Util.hs b/src/Data/Sequence/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sequence/Util.hs @@ -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 diff --git a/src/Data/UnBounded.hs b/src/Data/UnBounded.hs new file mode 100644 --- /dev/null +++ b/src/Data/UnBounded.hs @@ -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 diff --git a/test/Algorithms/Geometry/DelaunayTriangulation/DTSpec.hs b/test/Algorithms/Geometry/DelaunayTriangulation/DTSpec.hs new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/DelaunayTriangulation/DTSpec.hs @@ -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 + ] diff --git a/test/Algorithms/Geometry/SmallestEnclosingDisk/RISpec.hs b/test/Algorithms/Geometry/SmallestEnclosingDisk/RISpec.hs new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/SmallestEnclosingDisk/RISpec.hs @@ -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 diff --git a/test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe b/test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe new file mode 100644 --- /dev/null +++ b/test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe @@ -0,0 +1,369 @@ + + + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + +0.6 0 0 0.6 0 0 e + + + + + +0.5 0 0 0.5 0 0 e + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + + +-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 + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h + + + + + +-0.5 -0.5 m +0.5 -0.5 l +0.5 0.5 l +-0.5 0.5 l +h + + +-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 + + + + + + +-0.43 -0.57 m +0.57 0.43 l +0.43 0.57 l +-0.57 -0.43 l +h + + +-0.43 0.57 m +0.57 -0.43 l +0.43 -0.57 l +-0.57 0.43 l +h + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +-1 0.333 m +0 0 l +-1 -0.333 l + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +129.39 0 0 129.39 241.143 728 e + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +102.465 0 0 102.465 382.758 550.831 e + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/Data/Geometry/Ipe/ReaderSpec.hs b/test/Data/Geometry/Ipe/ReaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/Ipe/ReaderSpec.hs @@ -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' + -- "" +-- ) + -- `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 = "" + useSym = Symbol (point2 320 736) "mark/disk(sx)" +-- symAttrs = + + translatedUse = "" + + + + + ops = [ MoveTo $ point2 128 (656 :: Double) + , LineTo $ point2 224 768 + , LineTo $ point2 304 624 + , LineTo $ point2 432 752 + ] diff --git a/test/Data/Geometry/PointSpec.hs b/test/Data/Geometry/PointSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/PointSpec.hs @@ -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) + ]) diff --git a/test/Data/Geometry/Polygon/Convex/ConvexSpec.hs b/test/Data/Geometry/Polygon/Convex/ConvexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/Polygon/Convex/ConvexSpec.hs @@ -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 diff --git a/test/Data/Geometry/Polygon/Convex/convexTests.ipe b/test/Data/Geometry/Polygon/Convex/convexTests.ipe new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/Polygon/Convex/convexTests.ipe @@ -0,0 +1,308 @@ + + + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + +0.6 0 0 0.6 0 0 e + + + + + +0.5 0 0 0.5 0 0 e + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + + +-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 + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h + + + + + +-0.5 -0.5 m +0.5 -0.5 l +0.5 0.5 l +-0.5 0.5 l +h + + +-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 + + + + + + +-0.43 -0.57 m +0.57 0.43 l +0.43 0.57 l +-0.57 -0.43 l +h + + +-0.43 0.57 m +0.57 -0.43 l +0.43 -0.57 l +-0.57 0.43 l +h + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +-1 0.333 m +0 0 l +-1 -0.333 l + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +144 720 m +224 768 l +368 672 l +320 592 l +240 544 l +112 528 l +96 640 l +h + + +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 + + + diff --git a/test/Data/Geometry/PolygonSpec.hs b/test/Data/Geometry/PolygonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/PolygonSpec.hs @@ -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" diff --git a/test/Data/Geometry/pointInPolygon.ipe b/test/Data/Geometry/pointInPolygon.ipe new file mode 100644 --- /dev/null +++ b/test/Data/Geometry/pointInPolygon.ipe @@ -0,0 +1,311 @@ + + + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + +0.6 0 0 0.6 0 0 e + + + + + +0.5 0 0 0.5 0 0 e + + +0.6 0 0 0.6 0 0 e +0.4 0 0 0.4 0 0 e + + + + + +-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 + + + + +-0.6 -0.6 m +0.6 -0.6 l +0.6 0.6 l +-0.6 0.6 l +h + + + + + +-0.5 -0.5 m +0.5 -0.5 l +0.5 0.5 l +-0.5 0.5 l +h + + +-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 + + + + + + +-0.43 -0.57 m +0.57 0.43 l +0.43 0.57 l +-0.57 -0.43 l +h + + +-0.43 0.57 m +0.57 -0.43 l +0.43 -0.57 l +-0.57 0.43 l +h + + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-0.8 0 l +-1 -0.333 l +h + + + + +-1 0.333 m +0 0 l +-1 -0.333 l + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + +0 0 m +-1 0.333 l +-1 -0.333 l +h +-1 0 m +-2 0.333 l +-2 -0.333 l +h + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +208 752 m +304 688 l +224 592 l +48 736 l +h + + + + + + + + +496 736 m +432 624 l +512 608 l +h + + + + + + + + + + + + + + + + + + + diff --git a/test/Data/RangeSpec.hs b/test/Data/RangeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/RangeSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -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