diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Frank Staals + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Frank Staals nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +HGeometry-combinatorial +======================= + +The combinatorial types for the [HGeometry](https://hackage.haskell.org/package/hgeometry) package. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.org b/changelog.org new file mode 100644 --- /dev/null +++ b/changelog.org diff --git a/docs/Data/PlanarGraph/testG.png b/docs/Data/PlanarGraph/testG.png new file mode 100644 Binary files /dev/null and b/docs/Data/PlanarGraph/testG.png differ diff --git a/docs/Data/PlaneGraph/planegraph.png b/docs/Data/PlaneGraph/planegraph.png new file mode 100644 Binary files /dev/null and b/docs/Data/PlaneGraph/planegraph.png differ diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,66 @@ +import Test.DocTest + + +main :: IO () +main = doctest $ ["-isrc" ] ++ ghcExts ++ files + + +ghcExts :: [String] +ghcExts = map ("-X" ++) + [ "TypeFamilies" + , "GADTs" + , "KindSignatures" + , "DataKinds" + , "TypeOperators" + , "ConstraintKinds" + , "PolyKinds" + , "RankNTypes" + , "TypeApplications" + , "ScopedTypeVariables" + + , "PatternSynonyms" + , "ViewPatterns" + , "TupleSections" + , "MultiParamTypeClasses" + , "LambdaCase" + , "TupleSections" + + + , "StandaloneDeriving" + , "GeneralizedNewtypeDeriving" + , "DeriveFunctor" + , "DeriveFoldable" + , "DeriveTraversable" + , "AutoDeriveTypeable" + , "DeriveGeneric" + , "FlexibleInstances" + , "FlexibleContexts" + ] + +files :: [String] +files = map toFile modules + + +toFile :: String -> String +toFile = (\s -> "src/" <> s <> ".hs") . replace '.' '/' + +replace :: Eq a => a -> a -> [a] -> [a] +replace a b = go + where + go [] = [] + go (c:cs) | c == a = b:go cs + | otherwise = c:go cs + +modules :: [String] +modules = + [ "Data.Range" + , "Data.CircularList.Util" + , "Data.Permutation" + , "Data.CircularSeq" + , "Data.LSeq" + , "Data.PlanarGraph" + , "Data.PlanarGraph.Dart" + , "Data.PlanarGraph.Core" + , "Data.Tree.Util" + , "Data.Set.Util" + ] diff --git a/hgeometry-combinatorial.cabal b/hgeometry-combinatorial.cabal new file mode 100644 --- /dev/null +++ b/hgeometry-combinatorial.cabal @@ -0,0 +1,235 @@ +-- Initial hgeometry.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: hgeometry-combinatorial +version: 0.9.0.0 +synopsis: Data structures, and Data types. +description: + The Non-geometric data types and algorithms used in HGeometry. +homepage: https://fstaals.net/software/hgeometry +license: BSD3 +license-file: LICENSE +author: Frank Staals +maintainer: frank@fstaals.net +-- copyright: + +tested-with: GHC >= 8.4 + +category: Geometry +build-type: Simple + +data-files: test/Data/PlanarGraph/myGraph.yaml + -- in the future (cabal >=2.4) we can use + -- examples/**/*.in + -- examples/**/*.out + +extra-source-files: README.md + changelog.org + +Extra-doc-files: docs/Data/PlanarGraph/testG.png + docs/Data/PlaneGraph/planegraph.png + -- docs/**/*.png + +cabal-version: 2.0 +source-repository head + type: git + location: https://github.com/noinia/hgeometry + + +library + ghc-options: -O2 -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults + + exposed-modules: + -- * Graph Algorithms + Algorithms.Graph.DFS + Algorithms.Graph.MST + + + Algorithms.StringSearch.KMP + + -- * General Data Types + Data.UnBounded + Data.Intersection + Data.Range + Data.Ext + Data.LSeq + Data.CircularSeq + Data.Sequence.Util + Data.BinaryTree + Data.BinaryTree.Zipper + + Data.CircularList.Util + Data.BalBST + Data.OrdSeq + Data.SlowSeq + Data.Tree.Util + Data.Util + + Data.DynamicOrd + Data.Set.Util + + -- * Planar Graphs + Data.Permutation + Data.PlanarGraph + Data.PlanarGraph.AdjRep + Data.PlanarGraph.IO + Data.PlanarGraph.Dart + Data.PlanarGraph.Core + Data.PlanarGraph.Dual + Data.PlanarGraph.EdgeOracle + + -- * Other + System.Random.Shuffle + Control.Monad.State.Persistent + Data.Yaml.Util + + other-modules: + + -- other-extensions: + build-depends: + base >= 4.11 && < 5 + , bifunctors >= 4.1 + , bytestring >= 0.10 + , containers >= 0.5.9 + , dlist >= 0.7 + , lens >= 4.2 + , contravariant >= 1.5 + , semigroupoids >= 5 + , semigroups >= 0.18 + , singletons >= 2.0 + , vinyl >= 0.10 + , deepseq >= 1.1 + , fingertree >= 0.1 + , MonadRandom >= 0.5 + , QuickCheck >= 2.5 + , quickcheck-instances >= 0.3 + , reflection >= 2.1 + + , vector >= 0.11 + , data-clist >= 0.1.2.3 + , vector-builder >= 0.3.7 + + , aeson >= 1.0 + , yaml >= 0.8 + , text >= 1.1.1.0 + + , mtl + , template-haskell + + + + + hs-source-dirs: src + -- examples/demo + + default-language: Haskell2010 + + default-extensions: TypeFamilies + , GADTs + , KindSignatures + , DataKinds + , TypeOperators + , ConstraintKinds + , PolyKinds + , RankNTypes + , TypeApplications + , ScopedTypeVariables + + , PatternSynonyms + , TupleSections + , LambdaCase + , ViewPatterns + + , StandaloneDeriving + , GeneralizedNewtypeDeriving + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveGeneric + , AutoDeriveTypeable + + + , FlexibleInstances + , FlexibleContexts + , MultiParamTypeClasses + +test-suite doctests + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: doctests.hs + build-depends: base + , doctest >= 0.8 +-- , doctest-discover + + default-language: Haskell2010 + +test-suite hspec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + ghc-options: -fno-warn-unticked-promoted-constructors + -fno-warn-partial-type-signatures + -fno-warn-missing-signatures + + build-tool-depends: hspec-discover:hspec-discover + + other-modules: Algorithms.StringSearch.KMPSpec + Data.RangeSpec + Data.EdgeOracleSpec + Data.PlanarGraphSpec + Data.OrdSeqSpec + Data.CircularSeqSpec + + + build-depends: base + , hspec >= 2.1 + , QuickCheck >= 2.5 + , quickcheck-instances >= 0.3 + , approximate-equality >= 1.1.0.2 + , hgeometry-combinatorial + , lens + , data-clist + , linear + , bytestring + , vinyl + , semigroups + , vector + , containers + , random + , singletons + , filepath + , directory + , yaml + , MonadRandom + + default-extensions: TypeFamilies + , GADTs + , KindSignatures + , DataKinds + , TypeOperators + , ConstraintKinds + , PolyKinds + , RankNTypes + , TypeApplications + , ScopedTypeVariables + + + , PatternSynonyms + , ViewPatterns + , LambdaCase + , TupleSections + + + , StandaloneDeriving + , GeneralizedNewtypeDeriving + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + + , AutoDeriveTypeable + + , FlexibleInstances + , FlexibleContexts + , MultiParamTypeClasses + , OverloadedStrings 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 :: 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/StringSearch/KMP.hs b/src/Algorithms/StringSearch/KMP.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/StringSearch/KMP.hs @@ -0,0 +1,67 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.StringSearch.KMP +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Implementation of Knuth-Morris-Pratt String-searching +-- algorithm. The exposition is based on that of Goodrich and +-- Tamassia in "Data Structures and Algorithms in Java 2nd Edition". +-- +-------------------------------------------------------------------------------- +module Algorithms.StringSearch.KMP( isSubStringOf + , kmpMatch + , buildFailureFunction + ) where + +import Control.Monad.ST +import qualified Data.Vector as V +import Data.Vector.Generic ((!)) +import qualified Data.Vector.Unboxed as UV +import qualified Data.Vector.Unboxed.Mutable as UMV +import qualified VectorBuilder.Builder as Builder +import qualified VectorBuilder.Vector as Builder + + +-------------------------------------------------------------------------------- + +-- | Constructs the failure function. +-- +-- running time: \(O(m)\). +buildFailureFunction :: forall a. Eq a => V.Vector a -> UV.Vector Int +buildFailureFunction p = UV.create $ do + f <- UMV.new m + go f 1 0 + where + m = V.length p + go :: UMV.MVector s Int -> Int -> Int -> ST s (UMV.MVector s Int) + go f i j | i == m = pure f + | p ! j == p ! i = UMV.write f i (j+1) >> go f (i+1) (j+1) + | j > 0 = UMV.read f (j-1) >>= go f i + | otherwise = UMV.write f i 0 >> go f (i+1) 0 + +-- | Test if the first argument, the pattern p, occurs as a consecutive subsequence in t. +-- +-- running time: \(O(n+m)\), where p has length \(m\) and t has length \(n\). +isSubStringOf :: (Eq a, Foldable p, Foldable t) => p a -> t a -> Maybe Int +p `isSubStringOf` t = kmpMatch (Builder.build . Builder.foldable $ p) + (Builder.build . Builder.foldable $ t) + + +-- | Test if the first argument, the pattern p, occurs as a consecutive subsequence in t. +-- +-- running time: \(O(n+m)\), where p has length \(m\) and t has length \(n\). +kmpMatch :: Eq a => V.Vector a -> V.Vector a -> Maybe Int +kmpMatch p t | m == 0 = Just 0 + | otherwise = kmp 0 0 + where + m = V.length p + n = V.length t + f = buildFailureFunction p + + kmp i j | i == n = Nothing + | p ! j == t ! i = if j == m - 1 then Just (i - m + 1) + else kmp (i+1) (j+1) + | j > 0 = kmp i (f ! (j - 1)) + | otherwise = kmp (i+1) 0 -- j == 0 diff --git a/src/Control/Monad/State/Persistent.hs b/src/Control/Monad/State/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/State/Persistent.hs @@ -0,0 +1,48 @@ +module Control.Monad.State.Persistent( PersistentStateT + , PersistentState + , store + , runPersistentStateT + , runPersistentState + ) where + +import Control.Monad.State +import Control.Monad.Identity(Identity(..)) +import Data.List.NonEmpty(NonEmpty(..),(<|),toList) + +-------------------------------------------------------------------------------- + +-- | A State monad that can store earlier versions of the state. +newtype PersistentStateT s m a = + PersistentStateT (StateT (NonEmpty s) m a) + deriving (Functor,Applicative,Monad) + -- We store all the versions in reverse order + +-- | Create a snapshot of the current state and add it to the list of states +-- that we store. +store :: Monad m => PersistentStateT s m () +store = PersistentStateT $ do + ss@(s :| _) <- get + put (s <| ss) + + +instance Monad m => MonadState s (PersistentStateT s m) where + state f = PersistentStateT $ do + (s :| os) <- get + let (x,s') = f s + put (s' :| os) + return x + +-- | run a persistentStateT, returns a triplet with the value, the last state +-- and a list of all states (including the last one) in chronological order +runPersistentStateT :: Functor m => PersistentStateT s m a -> s -> m (a,s,[s]) +runPersistentStateT (PersistentStateT act) initS = f <$> runStateT act (initS :| []) + where + f (x,ss@(s :| _)) = (x, s, reverse $ toList ss) + + +-------------------------------------------------------------------------------- + +type PersistentState s = PersistentStateT s Identity + +runPersistentState :: PersistentState s a -> s -> (a,s,[s]) +runPersistentState act = runIdentity . runPersistentStateT act diff --git a/src/Data/BalBST.hs b/src/Data/BalBST.hs new file mode 100644 --- /dev/null +++ b/src/Data/BalBST.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE RecordWildCards #-} +module Data.BalBST where + +import Control.Applicative((<|>)) +import Data.Bifunctor +import Data.Function (on) +import Data.Functor.Contravariant +import qualified Data.List as L +import Data.Maybe +import qualified Data.Tree as T +import Prelude hiding (lookup,null) + +-------------------------------------------------------------------------------- + +-- | Describes how to search in a tree +data TreeNavigator k a = Nav { goLeft :: a -> k -> Bool + , extractKey :: a -> a -> k + } + +instance Contravariant (TreeNavigator k) where + contramap f (Nav gL eK) = Nav (\a k -> gL (f a) k) (\x y -> eK (f x) (f y)) + + +ordNav :: Ord a => TreeNavigator a a +ordNav = Nav (<=) min + + +ordNavBy :: Ord b => (a -> b) -> TreeNavigator b a +ordNavBy f = Nav (\x k -> f x <= k) (min `on` f) + + +-- instance Functor (TreeNavigator k) where +-- fmap f Nav{..} = Nav (\b k -> ) + + + +-- | A balanced binary search tree +data BalBST k a = BalBST { nav :: !(TreeNavigator k a) + , toTree :: !(Tree k a) + } + +instance (Show k, Show a) => Show (BalBST k a) where + show (BalBST _ t) = "BalBST (" ++ show t ++ ")" + + +data Color = Red | Black deriving (Show,Read,Eq,Ord) + +type Height = Int + +-- Red-Black tree with values in the leaves +data Tree k a = Empty + | Leaf !a + | Node !Color !Height (Tree k a) !k (Tree k a) deriving (Show,Eq) + +-------------------------------------------------------------------------------- + +-- | Creates an empty BST +empty :: TreeNavigator k a -> BalBST k a +empty n = BalBST n Empty + + +-- | \(O(n\log n)\) +fromList :: TreeNavigator k a -> [a] -> BalBST k a +fromList n = foldr insert (empty n) + +fromList' :: Ord a => [a] -> BalBST a a +fromList' = fromList ordNav + + +-- -- | \(O(n)\) +-- fromAscList :: TreeNavigator k a -> [a] -> BalBST k a +-- fromAscList = undefined + + +-------------------------------------------------------------------------------- + +-- | Check if the tree is empty +null :: BalBST k a -> Bool +null (BalBST _ Empty) = True +null _ = False + +-- | Test if an element occurs in the BST. +-- \(O(\log n)\) +lookup :: Eq a => a -> BalBST k a -> Maybe a +lookup x (BalBST Nav{..} t) = lookup' t + where + lookup' Empty = Nothing + lookup' (Leaf y) = if x == y then Just y else Nothing + lookup' (Node _ _ l k r) + | goLeft x k = lookup' l + | otherwise = lookup' r + +-- | \(O(\log n)\) +member :: Eq a => a -> BalBST k a -> Bool +member x = isJust . lookup x + +-- | Search for the Predecessor +-- \(O(\log n)\) +lookupLE :: Ord k => k -> BalBST k a -> Maybe a +lookupLE kx (BalBST n@Nav{..} t) = lookup' t + where + lookup' Empty = Nothing + lookup' (Leaf y) = if goLeft y kx then Just y else Nothing + lookup' (Node _ _ l k r) + | kx <= k = lookup' l + | otherwise = lookup' r <|> lookupMax (BalBST n l) + + +-- | Insert an element in the BST. +-- +-- \(O(\log n)\) +insert :: a -> BalBST k a -> BalBST k a +insert x (BalBST n@Nav{..} t) = BalBST n (blacken $ insert' t) + where + insert' Empty = Leaf x + insert' (Leaf y) = let k = extractKey x y + (l,r) = if goLeft x k then (x,y) else (y,x) + in red 2 (Leaf l) k (Leaf r) + insert' (Node c h l k r) + | goLeft x k = balance c h (insert' l) k r + | otherwise = balance c h l k (insert' r) + + + +-- delete = undefined + +-- | Delete (one occurance of) an element. +-- \(O(\log n)\) +delete :: Eq a => a -> BalBST k a -> BalBST k a +delete x t = let Split l _ r = split x t + n = nav t + in BalBST n $ joinWith n l r + + +-- (BalBST n@Nav{..} t) = delete' t +-- where +-- delete' Empty = Empty +-- delete' l@(Leaf y) = if x == y then Empty else l +-- delete' (Node c h l k r) +-- | goLeft x k = + + +-------------------------------------------------------------------------------- + + +-- | Extract the minimum from the tree +-- \(O(\log n)\) +minView :: BalBST k a -> Maybe (a, Tree k a) +minView (BalBST n t) = minView' t + where + minView' Empty = Nothing + minView' (Leaf x) = Just (x,Empty) + minView' (Node _ _ l _ r) = fmap (flip (joinWith n) r) <$> minView' l + +lookupMin :: BalBST k b -> Maybe b +lookupMin = fmap fst . maxView + +-- | Extract the maximum from the tree +-- \(O(\log n)\) +maxView :: BalBST k a -> Maybe (a, Tree k a) +maxView (BalBST n t) = maxView' t + where + maxView' Empty = Nothing + maxView' (Leaf x) = Just (x,Empty) + maxView' (Node _ _ l _ r) = fmap (joinWith n l) <$> maxView' r + +lookupMax :: BalBST k b -> Maybe b +lookupMax = fmap fst . maxView + + +-- | Joins two BSTs. Assumes that the ranges are disjoint. It takes the left Tree nav +-- +-- \(O(\log n)\) +join :: BalBST k a -> BalBST k a -> BalBST k a +join (BalBST n l) (BalBST _ r) = BalBST n $ joinWith n l r + +-- | Joins two BSTs' with a specific Tree Navigator +-- +-- \(O(\log n)\) +joinWith :: TreeNavigator k a -> Tree k a -> Tree k a -> Tree k a +joinWith Nav{..} tl tr + | lh >= rh = blacken $ joinL tl tr + | otherwise = blacken $ joinR tl tr + where + rh = height tr + lh = height tl + + joinL Empty _ = Empty + joinL l Empty = l + joinL l@(Leaf x) r@(Leaf y) = red 2 l (extractKey x y) r + joinL l@(Node c h ll k lr) r + | h == rh = let lm = unsafeMax lr + rm = unsafeMin r + in balance Red (h+1) l (extractKey lm rm) r + | otherwise = balance c h ll k (joinL lr r) + -- lh >= rh + joinL _ _ = error "joinL. absurd" + + + joinR _ Empty = Empty + joinR Empty r = r + + joinR l@(Leaf x) r@(Leaf y) = red 2 l (extractKey x y) r + joinR l r@(Node c h rl k rr) + | h == lh = let lm = unsafeMax l + rm = unsafeMin rl + in balance Red (h+1) l (extractKey lm rm) r + | otherwise = balance c h (joinR l rl) k rr + -- lh >= rh + joinR _ _ = error "joinR absurd" + + +-------------------------------------------------------------------------------- +-- | Splitting and extracting + +-- | A pair that is strict in its first argument and lazy in the second. +data Pair a b = Pair { fst' :: !a + , snd' :: b + } deriving (Show,Eq,Functor,Foldable,Traversable) + + +collect :: b -> [Pair a b] -> Pair [a] b +collect def [] = Pair [] def +collect _ xs = Pair (map fst' xs) (snd' $ last xs) + + +-- | Extract a prefix from the tree, i.e. a repeated 'minView' +-- +-- \(O(\log n +k)\), where \(k\) is the size of the extracted part +extractPrefix :: BalBST k a -> [Pair a (Tree k a)] +extractPrefix (BalBST n@Nav{..} t) = extractPrefix' t + where + extractPrefix' Empty = [] + extractPrefix' (Leaf x) = [Pair x Empty] + extractPrefix' (Node _ _ l _ r) = ls ++ extractPrefix' r + where + ls = map (fmap $ flip (joinWith n) r) $ extractPrefix' l + +-- | Extract a suffix from the tree, i.e. a repeated 'minView' +-- +-- \(O(\log n +k)\), where \(k\) is the size of the extracted part +extractSuffix :: BalBST k a -> [Pair a (Tree k a)] +extractSuffix (BalBST n@Nav{..} t) = extract t + where + extract Empty = [] + extract (Leaf x) = [Pair x Empty] + extract (Node _ _ l _ r) = rs ++ extract l + where + rs = map (fmap $ joinWith n l) $ extract r + +-- | Result of splititng a tree +data Split a b = Split a !b a deriving (Show,Eq) + +-- | Splits the tree at x. Note that if x occurs more often, no guarantees are +-- given which one is found. +-- +-- \(O(\log n)\) +split :: Eq a => a -> BalBST k a -> Split (Tree k a) (Maybe a) +split x (BalBST n@Nav{..} t) = split' t + where + split' Empty = Split Empty Nothing Empty + split' l@(Leaf y) + | x == y = Split Empty (Just y) Empty + | goLeft x (extractKey x y) = Split l Nothing Empty + | otherwise = Split Empty Nothing l + split' (Node _ _ l k r) + | goLeft x k = let Split l' mx r' = split' l + in Split l' mx (joinWith n r' r) + | otherwise = let Split l' mx r' = split' r + in Split (joinWith n l l') mx r' + +-- | split based on a monotonic predicate +-- +-- \(O(\log n)\) +splitMonotone :: (a -> Bool) -> BalBST k a + -> (BalBST k a, BalBST k a) +splitMonotone p (BalBST n@Nav{..} t) = bimap (BalBST n) (BalBST n) $ split' t + where + split' Empty = (Empty,Empty) + split' l@(Leaf y) + | p y = (Empty,l) + | otherwise = (l,Empty) + split' (Node _ _ l _ r) + | p (unsafeMin r) = let (l',m) = split' l in (l',joinWith n m r) + | otherwise = let (m,r') = split' r in (joinWith n l m, r') + + +-- | Splits at a given monotone predicate p, and then selects everything that +-- satisfies the predicate sel. +splitExtract :: (a -> Bool) -> (a -> Bool) -> BalBST k a + -> Split (BalBST k a) ([a],[a]) +splitExtract p sel bst = Split (BalBST n before) (reverse mid1,mid2) (BalBST n after) + where + n = nav bst + (before',after') = splitMonotone p bst + + extract def = collect def . L.takeWhile (sel . fst') + + Pair mid1 before = extract (toTree before') $ extractSuffix before' + Pair mid2 after = extract (toTree after') $ extractPrefix after' + + +-------------------------------------------------------------------------------- + + +data T k a = Internal !Color !Height !k | Val !a deriving (Show,Eq,Ord) + +toRoseTree :: Tree k a -> Maybe (T.Tree (T k a)) +toRoseTree Empty = Nothing +toRoseTree (Leaf x) = Just $ T.Node (Val x) [] +toRoseTree (Node c h l k r) = Just $ T.Node (Internal c h k) (mapMaybe toRoseTree [l,r]) + + +showTree :: (Show k, Show a) => BalBST k a -> String +showTree = maybe "Empty" T.drawTree . fmap (fmap show) . toRoseTree . toTree + +-- | Get the minimum in the tree. Errors when the tree is empty +-- +-- \(O(\log n)\) +unsafeMin :: Tree k a -> a +unsafeMin (Leaf x) = x +unsafeMin (Node _ _ l _ _) = unsafeMin l +unsafeMin _ = error "unsafeMin: Empty" + +-- | Get the maximum in the tree. Errors when the tree is empty +-- +-- \(O(\log n)\) +unsafeMax :: Tree k a -> a +unsafeMax (Leaf x) = x +unsafeMax (Node _ _ _ _ r) = unsafeMax r +unsafeMax _ = error "unsafeMax: Empty" + +-- | Extract all elements in the tree +-- +-- \(O(n)\) +toList :: BalBST k a -> [a] +toList = toList' . toTree + +-- | Extract all elements in the tree +-- +-- \(O(n)\) +toList' :: Tree k a -> [a] +toList' Empty = [] +toList' (Leaf x) = [x] +toList' (Node _ _ l _ r) = toList' l ++ toList' r + + +-------------------------------------------------------------------------------- +-- * Helper stuff + +black :: Height -> Tree k a -> k -> Tree k a -> Tree k a +black = Node Black + +red :: Height -> Tree k a -> k -> Tree k a -> Tree k a +red = Node Red + + +blacken :: Tree k a -> Tree k a +blacken (Node Red h l k r) = Node Black h l k r +blacken t = t + +-- | rebalance the tree +balance :: Color -> Height -> Tree k a -> k -> Tree k a -> Tree k a +balance Black h (Node Red _ (Node Red _ a x b) y c) z d = mkNode h a x b y c z d +balance Black h (Node Red _ a x (Node Red _ b y c)) z d = mkNode h a x b y c z d +balance Black h a x (Node Red _ (Node Red _ b y c) z d) = mkNode h a x b y c z d +balance Black h a x (Node Red _ b y (Node Red _ c z d)) = mkNode h a x b y c z d +balance co h a x b = Node co h a x b + +mkNode :: Height + -> Tree k a -> k -> Tree k a -> k -> Tree k a -> k -> Tree k a + -> Tree k a +mkNode h a x b y c z d = red h (black h a x b) y (black h c z d) + +height :: Tree k a -> Height +height Empty = 0 +height (Leaf _) = 1 +height (Node _ h _ _ _) = h 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,222 @@ +{-# Language DeriveFunctor#-} +{-# Language FunctionalDependencies #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.BinaryTree +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Several types of Binary trees. +-- +-------------------------------------------------------------------------------- +module Data.BinaryTree where + +import Control.DeepSeq +import Data.Bifunctor.Apply +import Data.List.NonEmpty (NonEmpty(..),(<|)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (mapMaybe) +import Data.Semigroup.Foldable +import qualified Data.Tree as Tree +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Test.QuickCheck + +-------------------------------------------------------------------------------- + +-- | Binary tree that stores its values (of type a) in the leaves. Internal +-- nodes store something of type v. +data BinLeafTree v a = Leaf !a + | Node (BinLeafTree v a) !v (BinLeafTree v a) + deriving (Show,Read,Eq,Ord,Functor,Generic) + +instance (NFData v, NFData a) => NFData (BinLeafTree v a) + +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 Bifunctor BinLeafTree where + bimap f g = \case + Leaf x -> Leaf $ g x + Node l k r -> Node (bimap f g l) (f k) (bimap f g 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 + +instance (Arbitrary a, Arbitrary v) => Arbitrary (BinLeafTree v a) where + arbitrary = sized f + where f n | n <= 0 = Leaf <$> arbitrary + | otherwise = do + l <- choose (0,n-1) + Node <$> f l <*> arbitrary <*> f (n-l-1) + +-- | Create a balanced tree, i.e. a tree of height \(O(\log n)\) with the +-- elements in the leaves. +-- +-- \(O(n)\) time. +asBalancedBinLeafTree :: NonEmpty a -> BinLeafTree Size (Elem a) +asBalancedBinLeafTree = repeatedly merge . fmap (Leaf . Elem) + where + repeatedly _ (t :| []) = t + repeatedly f ts = repeatedly f $ f ts + + merge ts@(_ :| []) = ts + merge (l :| r : []) = node l r :| [] + merge (l :| r : ts) = node l r <| (merge $ NonEmpty.fromList ts) +-- -- the implementation below produces slightly less high trees, but runs in +-- -- \(O(n \log n)\) time, as on every level it traverses the list passed down. +-- 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) + +-- | Given a function to combine internal nodes into b's and leafs into b's, +-- traverse the tree bottom up, and combine everything into one b. +foldUp :: (b -> v -> b -> b) -> (a -> b) -> BinLeafTree v a -> b +foldUp _ g (Leaf x) = g x +foldUp f g (Node l x r) = f (foldUp f g l) x (foldUp f g r) + + +-- | Traverses the tree bottom up, recomputing the assocated values. +foldUpData :: (w -> v -> w -> w) -> (a -> w) -> BinLeafTree v a -> BinLeafTree w a +foldUpData f g = foldUp f' Leaf + where + f' l v r = Node l (f (access' l) v (access' r)) r + + access' (Leaf x) = g x + access' (Node _ v _) = v + +-- | Takes two trees, that have the same structure, and uses the provided +-- functions to "zip" them together +zipExactWith :: (u -> v -> w) + -> (a -> b -> c) + -> BinLeafTree u a + -> BinLeafTree v b + -> BinLeafTree w c +zipExactWith _ g (Leaf x) (Leaf y) = Leaf (x `g` y) +zipExactWith f g (Node l m r) (Node l' m' r') = Node (zipExactWith f g l l') + (m `f` m') + (zipExactWith f g r r') +zipExactWith _ _ _ _ = + error "zipExactWith: tree structures not the same " + +newtype Size = Size Int deriving (Show,Read,Eq,Num,Integral,Enum,Real,Ord,Generic,NFData) + +instance Semigroup Size where + x <> y = x + y + +instance Monoid Size where + mempty = Size 0 + mappend = (<>) + +newtype Elem a = Elem { _unElem :: a } + deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable) + +instance Measured Size (Elem a) where + measure _ = 1 + + +data Sized a = Sized !Size a + deriving (Show,Eq,Ord,Functor,Foldable,Traversable,Generic) +instance NFData a => NFData (Sized a) + +instance Semigroup a => Semigroup (Sized a) where + (Sized i a) <> (Sized j b) = Sized (i <> j) (a <> b) + +instance Monoid a => Monoid (Sized a) where + mempty = Sized mempty mempty + (Sized i a) `mappend` (Sized j b) = Sized (i <> j) (a `mappend` b) + +-- instance Semigroup a => Measured Size (Sized a) where +-- measure (Sized i _) = i + + +-------------------------------------------------------------------------------- +-- * Converting into a Data.Tree + +data RoseElem v a = InternalNode v | LeafNode a deriving (Show,Eq,Functor) + +toRoseTree :: BinLeafTree v a -> Tree.Tree (RoseElem v a) +toRoseTree (Leaf x) = Tree.Node (LeafNode x) [] +toRoseTree (Node l v r) = Tree.Node (InternalNode v) (map toRoseTree [l,r]) + + +drawTree :: (Show v, Show a) => BinLeafTree v a -> String +drawTree = Tree.drawTree . fmap show . toRoseTree + + +-------------------------------------------------------------------------------- +-- * Internal Node Tree + +-- | Binary tree in which we store the values of type a in internal nodes. +data BinaryTree a = Nil + | Internal (BinaryTree a) !a (BinaryTree a) + deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable,Generic) +instance NFData a => NFData (BinaryTree a) + +instance Arbitrary a => Arbitrary (BinaryTree a) where + arbitrary = sized f + where f n | n <= 0 = pure Nil + | otherwise = do + l <- choose (0,n-1) + Internal <$> f l <*> arbitrary <*> f (n-l-1) + +-- | Get the element stored at the root, if it exists +access :: BinaryTree a -> Maybe a +access Nil = Nothing +access (Internal _ x _) = Just x + +-- | Create a balanced binary tree. +-- +-- running time: \(O(n)\) +asBalancedBinTree :: [a] -> BinaryTree a +asBalancedBinTree = mkTree . V.fromList + where + mkTree v = let n = V.length v + h = n `div` 2 + x = v V.! h + in if n == 0 then Nil + else Internal (mkTree $ V.slice 0 h v) x + (mkTree $ V.slice (h+1) (n - h -1) v) + +-- | Fold function for folding over a binary tree. +foldBinaryUp :: b -> (a -> b -> b -> b) + -> BinaryTree a -> BinaryTree (a,b) +foldBinaryUp _ _ Nil = Nil +foldBinaryUp e f (Internal l x r) = let l' = foldBinaryUp e f l + r' = foldBinaryUp e f r + g = maybe e snd . access + b = f x (g l') (g r') + in Internal l' (x,b) r' + +-- | Convert a @BinaryTree@ into a RoseTree +toRoseTree' :: BinaryTree a -> Maybe (Tree.Tree a) +toRoseTree' Nil = Nothing +toRoseTree' (Internal l v r) = Just $ Tree.Node v $ mapMaybe toRoseTree' [l,r] + +-- | Draw a binary tree. +drawTree' :: Show a => BinaryTree a -> String +drawTree' = maybe "Nil" (Tree.drawTree . fmap show) . toRoseTree' diff --git a/src/Data/BinaryTree/Zipper.hs b/src/Data/BinaryTree/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Data/BinaryTree/Zipper.hs @@ -0,0 +1,64 @@ +module Data.BinaryTree.Zipper where + +import Data.BinaryTree + +-------------------------------------------------------------------------------- + +data Ctx a = Top | L (Ctx a) a (BinaryTree a) | R (BinaryTree a) a (Ctx a) + deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable) + +data BinaryTreeZipper a = Loc (BinaryTree a) (Ctx a) + deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable) + +-- | Focus on the root +top :: BinaryTree a -> BinaryTreeZipper a +top t = Loc t Top + +-- | Go to the left child +left :: BinaryTreeZipper a -> Maybe (BinaryTreeZipper a) +left (Loc (Internal l x r) ctx) = Just $ Loc l (L ctx x r) +left (Loc Nil _) = Nothing + +-- | Go to the right child +right :: BinaryTreeZipper a -> Maybe (BinaryTreeZipper a) +right (Loc (Internal l x r) ctx) = Just $ Loc r (R l x ctx) +right (Loc Nil _) = Nothing + +-- | Move to the parent +up :: BinaryTreeZipper a -> Maybe (BinaryTreeZipper a) +up (Loc _ Top) = Nothing +up (Loc l (L ctx x r)) = Just $ Loc (Internal l x r) ctx +up (Loc r (R l x ctx)) = Just $ Loc (Internal l x r) ctx + +-- | Navigate to the root +toRoot :: BinaryTreeZipper a -> BinaryTreeZipper a +toRoot z = toRoot' z (Just z) + where + toRoot' z' Nothing = z' + toRoot' _ (Just z') = toRoot' z' (up z') + + +-- | Returns a list of zippers; one focussed on each node in the tree +visitAll :: BinaryTree a -> [BinaryTreeZipper a] +visitAll t = visitAll' (top t) + where + f = maybe [] visitAll' + visitAll' z = z : f (left z) <> f (right z) + +-- | Get the value stored at the current node +accessZ :: BinaryTreeZipper a -> Maybe a +accessZ (Loc t _) = access t + + +-- | Returns all subtrees; i.e. every node with all its decendents +subTrees :: BinaryTree a -> [BinaryTree a] +subTrees t = Nil : subTrees' t + where + subTrees' Nil = [] + subTrees' tt@(Internal l _ r) = tt : subTrees' l <> subTrees' r + + +-- | Splits the tree here, returns a pair (innerTree,outerTree) +splitTree :: BinaryTreeZipper a -> (BinaryTree a, BinaryTree a) +splitTree (Loc t ctx) = let (Loc r _) = toRoot $ Loc Nil ctx + in (t, r) 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,67 @@ +module Data.CircularList.Util where + +import Control.Lens +import Data.Tuple +import qualified Data.CircularList as C +import qualified Data.List as L + + +-------------------------------------------------------------------------------- + +-- $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 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,384 @@ +module Data.CircularSeq( CSeq + , cseq + , singleton + , fromNonEmpty + , fromList + + , focus + , index, adjust + , item + + , rotateL + , rotateR + , rotateNL, rotateNR + + , rightElements + , leftElements + , asSeq + + , reverseDirection + , allRotations + + , findRotateTo + , rotateTo + + , zipLWith, zipL + , zip3LWith + + + , insertOrd, insertOrdBy + , isShiftOf + ) where + +import Algorithms.StringSearch.KMP (isSubStringOf) +import Control.DeepSeq +import Control.Lens (lens, Lens', bimap) +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (listToMaybe, isJust) +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) +import GHC.Generics (Generic) +import Test.QuickCheck(Arbitrary(..)) +import Test.QuickCheck.Instances () + +-------------------------------------------------------------------------------- + +-- $setup +-- >>> let ordList = fromList [5,6,10,20,30,1,2,3] + + +-- | Nonempty circular sequence +data CSeq a = CSeq !(Seq a) !a !(Seq a) + deriving (Generic) + -- we keep the seq balanced, i.e. size left >= size right + +instance NFData a => NFData (CSeq a) + +instance Eq a => Eq (CSeq a) where + a == b = asSeq a == asSeq b + +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 + +instance Arbitrary a => Arbitrary (CSeq a) where + arbitrary = CSeq <$> arbitrary <*> arbitrary <*> arbitrary + +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 + +-- smart constructor that automatically balances the sequence. +-- pre: at least one of the two seq's is NonEmpty +-- +cseq' :: Seq a -> Seq a -> CSeq a +cseq' l r = case S.viewl r of + (x :< r') -> cseq l x r' + EmptyL -> let (x :< l') = S.viewl l in cseq l' x r + +-- | 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 = uncurry cseq' . S.splitAt i . rightElements + +-- | 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 + in case S.viewr l' of + l :> y -> cseq l y r + S.EmptyR -> let (y :< r') = S.viewl r 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 + +-- | "Left zip": zip the two CLists, pairing up every element in the *left* +-- list with its corresponding element in the right list. If there are more +-- items in the right clist they are discarded. +zipLWith :: (a -> b -> c) -> CSeq a -> CSeq b -> CSeq c +zipLWith f as bs = fromList $ zipWith f (F.toList as) (F.toList bs) + +-- | see 'zipLWith +zipL :: CSeq a -> CSeq b -> CSeq (a, b) +zipL = zipLWith (,) + + +-- | same as zipLWith but with three items +zip3LWith :: (a -> b -> c -> d) -> CSeq a -> CSeq b -> CSeq c -> CSeq d +zip3LWith f as bs cs = fromList $ zipWith3 f (F.toList as) (F.toList bs) (F.toList cs) + + + + +-- | Given a circular seq, whose elements are in increasing order, insert the +-- new element into the Circular seq in its sorted order. +-- +-- >>> insertOrd 1 $ fromList [2] +-- CSeq [2,1] +-- >>> insertOrd 2 $ fromList [1,3] +-- CSeq [1,2,3] +-- >>> insertOrd 31 ordList +-- CSeq [5,6,10,20,30,31,1,2,3] +-- >>> insertOrd 1 ordList +-- CSeq [5,6,10,20,30,1,1,2,3] +-- >>> insertOrd 4 ordList +-- CSeq [5,6,10,20,30,1,2,3,4] +-- >>> insertOrd 11 ordList +-- CSeq [5,6,10,11,20,30,1,2,3] +-- +-- running time: \(O(n)\) +insertOrd :: Ord a => a -> CSeq a -> CSeq a +insertOrd = insertOrdBy compare + +-- | Insert an element into an increasingly ordered circular list, with +-- specified compare operator. +-- +-- running time: \(O(n)\) +insertOrdBy :: (a -> a -> Ordering) -> a -> CSeq a -> CSeq a +insertOrdBy cmp x = fromList . insertOrdBy' cmp x . F.toList . 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. We have that +-- +-- prop> (xs `isShiftOf` ys) == (xs `elem` allRotations (ys :: CSeq Int)) +-- +-- Running time: \(O(n+m)\), where \(n\) and \(m\) are the sizes of +-- the lists. +isShiftOf :: Eq a => CSeq a -> CSeq a -> Bool +xs `isShiftOf` ys = let twice zs = let zs' = leftElements zs in zs' <> zs' + once = leftElements + check as bs = isJust $ once as `isSubStringOf` twice bs + in length xs == length ys && check xs ys diff --git a/src/Data/DynamicOrd.hs b/src/Data/DynamicOrd.hs new file mode 100644 --- /dev/null +++ b/src/Data/DynamicOrd.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.DynamicOrd where + +import Data.Proxy +import Data.Reflection +import Unsafe.Coerce + +-------------------------------------------------------------------------------- + +-- Implementation from +-- https://www.schoolofhaskell.com/user/thoughtpolice/using-reflection + +-- | Values of type 'a' in our dynamically constructed 'Ord' instance +newtype O (s :: *) (a :: *) = O { runO :: a } deriving (Show) + +-- | An Ord Dictionary +newtype OrdDict a = OrdDict { compare_ :: a -> a -> Ordering } + +instance Reifies s (OrdDict a) => Eq (O s a) where + (O l) == (O r) = let cmp = compare_ $ reflect (Proxy :: Proxy s) + in case l `cmp` r of + EQ -> True + _ -> False + +instance (Eq (O s a), Reifies s (OrdDict a)) => Ord (O s a) where + (O l) `compare` (O r) = let cmp = compare_ $ reflect (Proxy :: Proxy s) + in l `cmp` r + +-- | Run a computation with a given ordering +withOrd :: (a -> a -> Ordering) -> (forall s. Reifies s (OrdDict a) => O s b) -> b +withOrd cmp v = reify (OrdDict cmp) (runO . asProxyOf v) + where + asProxyOf :: f s a -> Proxy s -> f s a + asProxyOf v' _ = v' + +-------------------------------------------------------------------------------- +-- * Introducing and removing the dynamic order type +-- Note that all of these may be unsafe if used incorrectly + +-- | Lifts a container f whose values (of type a) depend on 's' into a +-- more general computation in that produces a 'f a' (depending on s). +-- +-- running time: \(O(1)\) +extractOrd1 :: f (O s a) -> O s (f a) +extractOrd1 = unsafeCoerce + + +-- | Introduce dynamic order in a container 'f'. +-- +-- running time: \(O(1)\) +introOrd1 :: f a -> f (O s a) +introOrd1 = unsafeCoerce + +-- | Lifts a function that works on a container 'f' of +-- orderable-things into one that works on dynamically ordered ones. +liftOrd1 :: (f (O s a) -> f (O s a)) + -> f a -> O s (f a) +liftOrd1 f = extractOrd1 . f . introOrd1 + + +-- | Lifts a container f whose keys (of type k) depend on 's' into a +-- more general computation in that produces a 'f k v' (depending on s). +-- +-- running time: \(O(1)\) +extractOrd2 :: f (O s k) v -> O s (f k v) +extractOrd2 = unsafeCoerce + +-- | Introduce dynamic order in a container 'f' that has keys of type +-- k. +-- +-- running time: \(O(1)\) +introOrd2 :: f k v -> f (O s k) v +introOrd2 = unsafeCoerce diff --git a/src/Data/Ext.hs b/src/Data/Ext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ext.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Ext +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- A pair-like data type to represent a 'core' type that has extra information +-- as well. +-- +-------------------------------------------------------------------------------- +module Data.Ext where + +import Control.DeepSeq +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Aeson.Types (typeMismatch) +import Data.Biapplicative +import Data.Bifoldable +import Data.Bifunctor.Apply +import Data.Bitraversable +import Data.Functor.Apply (liftF2) +import Data.Semigroup.Bifoldable +import Data.Semigroup.Bitraversable +import GHC.Generics (Generic) +import Test.QuickCheck + +-------------------------------------------------------------------------------- + +-- | Our Ext type that represents the core datatype core extended with extra +-- information of type 'extra'. +data core :+ extra = core :+ extra deriving (Show,Read,Eq,Ord,Bounded,Generic,NFData) +infixr 1 :+ + + +instance Bifunctor (:+) where + bimap f g (c :+ e) = f c :+ g e + +instance Biapply (:+) where + (f :+ g) <<.>> (c :+ e) = f c :+ g e + +instance Biapplicative (:+) where + bipure = (:+) + (f :+ g) <<*>> (c :+ e) = f c :+ g e + +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' + + +instance (ToJSON core, ToJSON extra) => ToJSON (core :+ extra) where + -- toJSON (c :+ e) = toJSON (c,e) + -- toEncoding (c :+ e) = toEncoding (c,e) + toJSON (c :+ e) = object ["core" .= c, "extra" .= e] + toEncoding (c :+ e) = pairs ("core" .= c <> "extra" .= e) + +instance (FromJSON core, FromJSON extra) => FromJSON (core :+ extra) where + -- parseJSON = fmap (\(c,e) -> c :+ e) . parseJSON + parseJSON (Object v) = (:+) <$> v .: "core" <*> v .: "extra" + parseJSON invalid = typeMismatch "Ext (:+)" invalid + +instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where + arbitrary = (:+) <$> arbitrary <*> arbitrary + +_core :: (core :+ extra) -> core +_core (c :+ _) = c + +_extra :: (core :+ extra) -> extra +_extra (_ :+ e) = e + +core :: Lens (core :+ extra) (core' :+ extra) core core' +core = lens _core (\(_ :+ e) c -> (c :+ e)) + +extra :: Lens (core :+ extra) (core :+ extra') extra extra' +extra = lens _extra (\(c :+ _) e -> (c :+ e)) + +ext :: a -> a :+ () +ext x = x :+ () diff --git a/src/Data/Intersection.hs b/src/Data/Intersection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Intersection.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE DefaultSignatures #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Intersection +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Defines a data type for representing intersections. Mostly useful +-- for the more geometric types. +-- +-------------------------------------------------------------------------------- +module Data.Intersection where + +import Data.Maybe (isNothing) +import Data.Vinyl.CoRec +import Data.Vinyl.Core +import Data.Vinyl.Functor +import Data.Vinyl.Lens + +------------------------------------------------------------------------------- + +-- | 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 = CoRec . Identity + +class IsIntersectableWith g h where + intersect :: g -> h -> Intersection g h + + -- | g `intersects` h <=> The intersection of g and h is non-empty. + -- + -- The default implementation computes the intersection of g and h, + -- and uses nonEmptyIntersection to determine if the intersection is + -- non-empty. + intersects :: g -> h -> Bool + g `intersects` h = nonEmptyIntersection (Identity g) (Identity h) $ g `intersect` h + + -- | Helper to implement `intersects`. + 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 result is *not* a NoIntersection +defaultNonEmptyIntersection :: forall g h proxy. + ( NoIntersection ∈ IntersectionOf g h + , RecApplicative (IntersectionOf g h) + ) + => proxy g -> proxy h -> Intersection g h -> Bool +defaultNonEmptyIntersection _ _ = isNothing . asA @NoIntersection diff --git a/src/Data/LSeq.hs b/src/Data/LSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/LSeq.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.LSeq +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- Description : Wrapper around Data.Sequence with type level length annotation. +-- +-------------------------------------------------------------------------------- +module Data.LSeq( LSeq + , toSeq + , empty + , fromList + , fromNonEmpty + , fromSeq + + , (<|), (|>) + , (><) + , eval + + , index + , adjust + , partition + , mapWithIndex + , take + , drop + , unstableSort, unstableSortBy + , head, last + , append + + , ViewL(..) + , viewl + , pattern (:<|) + + , pattern (:<<) + , pattern EmptyL + + , ViewR(..) + , viewr + , pattern (:|>) + + + , promise + , forceLSeq + ) where + +import Control.DeepSeq +import Control.Lens ((%~), (&), (<&>), (^?), bimap) +import Control.Lens.At (Ixed(..), Index, IxValue) +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromJust) +import Data.Proxy +import Data.Semigroup.Foldable +import qualified Data.Sequence as S +import qualified Data.Traversable as Tr +import GHC.Generics (Generic) +import GHC.TypeLits +import Prelude hiding (drop,take,head,last) +import Test.QuickCheck(Arbitrary(..),vector) + +-------------------------------------------------------------------------------- + +-- $setup +-- >>> :{ +-- import Data.Proxy +-- :} + + + +-- | LSeq n a certifies that the sequence has *at least* n items +newtype LSeq (n :: Nat) a = LSeq (S.Seq a) + deriving (Show,Read,Eq,Ord,Foldable,Functor,Traversable + ,Generic,NFData) + +toSeq :: LSeq n a -> S.Seq a +toSeq (LSeq s) = s + +instance Semigroup (LSeq n a) where + (LSeq s) <> (LSeq s') = LSeq (s <> s') + +instance Monoid (LSeq 0 a) where + mempty = empty + mappend = (<>) + +instance (KnownNat n, Arbitrary a) => Arbitrary (LSeq n a) where + arbitrary = (\s s' -> promise . fromList $ s <> s') + <$> vector (fromInteger . natVal $ (Proxy :: Proxy n)) + <*> arbitrary + + +type instance Index (LSeq n a) = Int +type instance IxValue (LSeq n a) = a +instance Ixed (LSeq n a) where + ix i f s@(LSeq xs) + | 0 <= i && i < S.length xs = f (S.index xs i) <&> \x -> LSeq $ S.update i x xs + | otherwise = pure s + +instance (1 <= n) => Foldable1 (LSeq n) + +empty :: LSeq 0 a +empty = LSeq S.empty + +(<|) :: a -> LSeq n a -> LSeq (1 + n) a +x <| xs = LSeq (x S.<| toSeq xs) + +(|>) :: LSeq n a -> a -> LSeq (1 + n) a +xs |> x = LSeq (toSeq xs S.|> x) + +infixr 5 <| +infixl 5 |> + +(><) :: LSeq n a -> LSeq m a -> LSeq (n + m) a +xs >< ys = LSeq (toSeq xs <> toSeq ys) + +infix 5 >< + + +eval :: forall proxy n m a. KnownNat n => proxy n -> LSeq m a -> Maybe (LSeq n a) +eval n (LSeq xs) + | toInteger (S.length xs) >= natVal n = Just $ LSeq xs + | otherwise = Nothing + + + + + +-- | Promises that the length of this LSeq is actually n. This is not +-- checked. +-- +-- This function should be a noop +promise :: LSeq m a -> LSeq n a +promise = LSeq . toSeq + + +-- | Forces the first n elements of the LSeq +forceLSeq :: KnownNat n => proxy n -> LSeq m a -> LSeq n a +forceLSeq n = promise . go (fromInteger $ natVal n) + where + -- forces the Lseq for n' positions + go :: Int -> LSeq m a -> LSeq m a + go n' s | n' <= l = s + | otherwise = error msg + where + l = S.length . S.take n' . toSeq $ s + msg = "forceLSeq: too few elements. expected " <> show n' <> " but found " <> show l + + +-- | appends two sequences. +-- +append :: LSeq n a -> LSeq m a -> LSeq (n + m) a +sa `append` sb = LSeq $ (toSeq sa) <> toSeq sb + +-------------------------------------------------------------------------------- + +-- | get the element with index i, counting from the left and starting at 0. +-- O(log(min(i,n-i))) +index :: LSeq n a -> Int -> a +index s i = fromJust $ s^?ix i + +adjust :: (a -> a) -> Int -> LSeq n a -> LSeq n a +adjust f i s = s&ix i %~ f + + +partition :: (a -> Bool) -> LSeq n a -> (LSeq 0 a, LSeq 0 a) +partition p = bimap LSeq LSeq . S.partition p . toSeq + +mapWithIndex :: (Int -> a -> b) -> LSeq n a -> LSeq n b +mapWithIndex f = wrapUnsafe (S.mapWithIndex f) + +take :: Int -> LSeq n a -> LSeq 0 a +take i = wrapUnsafe (S.take i) + +drop :: Int -> LSeq n a -> LSeq 0 a +drop i = wrapUnsafe (S.drop i) + + +unstableSortBy :: (a -> a -> Ordering) -> LSeq n a -> LSeq n a +unstableSortBy f = wrapUnsafe (S.unstableSortBy f) + +unstableSort :: Ord a => LSeq n a -> LSeq n a +unstableSort = wrapUnsafe (S.unstableSort) + + +wrapUnsafe :: (S.Seq a -> S.Seq b) -> LSeq n a -> LSeq m b +wrapUnsafe f = LSeq . f . toSeq + +-------------------------------------------------------------------------------- + +fromSeq :: S.Seq a -> LSeq 0 a +fromSeq = LSeq + +fromList :: Foldable f => f a -> LSeq 0 a +fromList = LSeq . S.fromList . F.toList + +fromNonEmpty :: NonEmpty.NonEmpty a -> LSeq 1 a +fromNonEmpty = LSeq . S.fromList . F.toList + + +-------------------------------------------------------------------------------- + +data ViewL n a where + (:<) :: a -> LSeq n a -> ViewL (1 + n) a + +infixr 5 :< + +instance Semigroup (ViewL n a) where + (x :< xs) <> (y :< ys) = x :< LSeq (toSeq xs <> (y S.<| toSeq ys)) + +deriving instance Show a => Show (ViewL n a) +instance Functor (ViewL n) where + fmap = Tr.fmapDefault +instance Foldable (ViewL n) where + foldMap = Tr.foldMapDefault +instance Traversable (ViewL n) where + traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs +instance Eq a => Eq (ViewL n a) where + s == s' = F.toList s == F.toList s' +instance Ord a => Ord (ViewL n a) where + s `compare` s' = F.toList s `compare` F.toList s' + + +viewl :: LSeq (1 + n) a -> ViewL (1 + n) a +viewl xs = let ~(x S.:< ys) = S.viewl $ toSeq xs in x :< LSeq ys + +viewl' :: LSeq (1 + n) a -> (a, LSeq n a) +viewl' xs = let ~(x S.:< ys) = S.viewl $ toSeq xs in (x,LSeq ys) + +infixr 5 :<| + +pattern (:<|) :: a -> LSeq n a -> LSeq (1 + n) a +pattern x :<| xs <- (viewl' -> (x,xs)) -- we need the coerce unfortunately + where + x :<| xs = x <| xs +{-# COMPLETE (:<|) #-} + + + +infixr 5 :<< + +pattern (:<<) :: a -> LSeq 0 a -> LSeq n a +pattern x :<< xs <- (viewLSeq -> Just (x,xs)) + +pattern EmptyL :: LSeq n a +pattern EmptyL <- (viewLSeq -> Nothing) + +viewLSeq :: LSeq n a -> Maybe (a,LSeq 0 a) +viewLSeq (LSeq s) = case S.viewl s of + S.EmptyL -> Nothing + (x S.:< xs) -> Just (x,LSeq xs) + + +-------------------------------------------------------------------------------- + +data ViewR n a where + (:>) :: LSeq n a -> a -> ViewR (1 + n) a + +infixl 5 :> + +instance Semigroup (ViewR n a) where + (xs :> x) <> (ys :> y) = LSeq ((toSeq xs S.|> x) <> toSeq ys) :> y + +deriving instance Show a => Show (ViewR n a) +instance Functor (ViewR n) where + fmap = Tr.fmapDefault +instance Foldable (ViewR n) where + foldMap = Tr.foldMapDefault +instance Traversable (ViewR n) where + traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x +instance Eq a => Eq (ViewR n a) where + s == s' = F.toList s == F.toList s' +instance Ord a => Ord (ViewR n a) where + s `compare` s' = F.toList s `compare` F.toList s' + +viewr :: LSeq (1 + n) a -> ViewR (1 + n) a +viewr xs = let ~(ys S.:> x) = S.viewr $ toSeq xs in LSeq ys :> x + +viewr' :: LSeq (1 + n) a -> (LSeq n a, a) +viewr' xs = let ~(ys S.:> x) = S.viewr $ toSeq xs in (LSeq ys, x) + +infixl 5 :|> + +pattern (:|>) :: forall n a. LSeq n a -> a -> LSeq (1 + n) a +pattern xs :|> x <- (viewr' -> (xs,x)) + where + xs :|> x = xs |> x +{-# COMPLETE (:|>) #-} + +-------------------------------------------------------------------------------- + +-- | Gets the first element of the LSeq +-- +-- >>> head $ forceLSeq (Proxy :: Proxy 3) $ fromList [1,2,3] +-- 1 +head :: LSeq (1 + n) a -> a +head (x :<| _) = x + +-- s = let (x :< _) = viewl s in x + +-- | Get the last element of the LSeq +-- +-- >>> last $ forceLSeq (Proxy :: Proxy 3) $ fromList [1,2,3] +-- 3 +last :: LSeq (1 + n) a -> a +last (_ :|> x) = x + +-- testL = (eval (Proxy :: Proxy 2) $ fromList [1..5]) + +-- testL' :: LSeq 2 Integer +-- testL' = fromJust testL + +-- test :: Show a => LSeq (1 + n) a -> String +-- test (x :<| xs) = show x ++ show xs diff --git a/src/Data/OrdSeq.hs b/src/Data/OrdSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrdSeq.hs @@ -0,0 +1,193 @@ +module Data.OrdSeq where + + +import Control.Lens (bimap) +import qualified Data.FingerTree as FT +import Data.FingerTree hiding (null, viewl, viewr) +import qualified Data.Foldable as F +import Data.Maybe +import Test.QuickCheck + +-------------------------------------------------------------------------------- + +data Key a = NoKey | Key { getKey :: !a } deriving (Show,Eq,Ord) + +instance Semigroup (Key a) where + k <> NoKey = k + _ <> k = k + +instance Monoid (Key a) where + mempty = NoKey + k `mappend` k' = k <> k' + +liftCmp :: (a -> a -> Ordering) -> Key a -> Key a -> Ordering +liftCmp _ NoKey NoKey = EQ +liftCmp _ NoKey (Key _) = LT +liftCmp _ (Key _) NoKey = GT +liftCmp cmp (Key x) (Key y) = x `cmp` y + + + +newtype Elem a = Elem { getElem :: a } deriving (Eq,Ord,Traversable,Foldable,Functor) + +instance Show a => Show (Elem a) where + show (Elem x) = "Elem " <> show x + + +newtype OrdSeq a = OrdSeq { _asFingerTree :: FingerTree (Key a) (Elem a) } + deriving (Show,Eq) + +instance Semigroup (OrdSeq a) where + (OrdSeq s) <> (OrdSeq t) = OrdSeq $ s `mappend` t + +instance Monoid (OrdSeq a) where + mempty = OrdSeq mempty + mappend = (<>) + +instance Foldable OrdSeq where + foldMap f = foldMap (foldMap f) . _asFingerTree + null = null . _asFingerTree + length = length . _asFingerTree + minimum = fromJust . lookupMin + maximum = fromJust . lookupMax + +instance (Arbitrary a, Ord a) => Arbitrary (OrdSeq a) where + arbitrary = fromListByOrd <$> arbitrary + +instance Measured (Key a) (Elem a) where + measure (Elem x) = Key x + + +type Compare a = a -> a -> Ordering + +-- | Insert into a monotone OrdSeq. +-- +-- pre: the comparator maintains monotonicity +-- +-- \(O(\log n)\) +insertBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +insertBy cmp x (OrdSeq s) = OrdSeq $ l `mappend` (Elem x <| r) + where + (l,r) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ, GT]) s + +-- | Insert into a sorted OrdSeq +-- +-- \(O(\log n)\) +insert :: Ord a => a -> OrdSeq a -> OrdSeq a +insert = insertBy compare + +deleteAllBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +deleteAllBy cmp x s = l <> r + where + (l,_,r) = splitBy cmp x s + + -- (l,m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s + -- (_,r) = split (\v -> liftCmp cmp v (Key x) == GT) m + + +-- | \(O(\log n)\) +splitBy :: Compare a -> a -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitBy cmp x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s + (m',r) = split (\v -> liftCmp cmp v (Key x) == GT) m + + +-- | Given a monotonic function f that maps a to b, split the sequence s +-- depending on the b values. I.e. the result (l,m,r) is such that +-- * all (< x) . fmap f $ l +-- * all (== x) . fmap f $ m +-- * all (> x) . fmap f $ r +-- +-- >>> splitOn id 3 $ fromAscList' [1..5] +-- (OrdSeq {_asFingerTree = fromList [Elem 1,Elem 2]},OrdSeq {_asFingerTree = fromList [Elem 3]},OrdSeq {_asFingerTree = fromList [Elem 4,Elem 5]}) +-- >>> splitOn fst 2 $ fromAscList' [(0,"-"),(1,"A"),(2,"B"),(2,"C"),(3,"D"),(4,"E")] +-- (OrdSeq {_asFingerTree = fromList [Elem (0,"-"),Elem (1,"A")]},OrdSeq {_asFingerTree = fromList [Elem (2,"B"),Elem (2,"C")]},OrdSeq {_asFingerTree = fromList [Elem (3,"D"),Elem (4,"E")]}) +-- +-- \(O(\log n)\) +splitOn :: Ord b => (a -> b) -> b -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitOn f x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\(Key v) -> compare (f v) x `elem` [EQ,GT]) s + (m',r) = split (\(Key v) -> compare (f v) x == GT) m + +-- | Given a monotonic predicate p, splits the sequence s into two sequences +-- (as,bs) such that all (not p) as and all p bs +-- +-- \(O(\log n)\) +splitMonotonic :: (a -> Bool) -> OrdSeq a -> (OrdSeq a, OrdSeq a) +splitMonotonic p = bimap OrdSeq OrdSeq . split (p . getKey) . _asFingerTree + + +-- Deletes all elements from the OrdDeq +-- +-- \(O(n\log n)\) +deleteAll :: Ord a => a -> OrdSeq a -> OrdSeq a +deleteAll = deleteAllBy compare + + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListBy :: Compare a -> [a] -> OrdSeq a +fromListBy cmp = foldr (insertBy cmp) mempty + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListByOrd :: Ord a => [a] -> OrdSeq a +fromListByOrd = fromListBy compare + +-- | O(n) +fromAscList' :: [a] -> OrdSeq a +fromAscList' = OrdSeq . fromList . fmap Elem + + +-- | \(O(\log n)\) +lookupBy :: Compare a -> a -> OrdSeq a -> Maybe a +lookupBy cmp x s = let (_,m,_) = splitBy cmp x s in listToMaybe . F.toList $ m + +memberBy :: Compare a -> a -> OrdSeq a -> Bool +memberBy cmp x = isJust . lookupBy cmp x + + +-- | Fmap, assumes the order does not change +-- O(n) +mapMonotonic :: (a -> b) -> OrdSeq a -> OrdSeq b +mapMonotonic f = fromAscList' . map f . F.toList + + +-- | Gets the first element from the sequence +-- \(O(1)\) +viewl :: OrdSeq a -> ViewL OrdSeq a +viewl = f . FT.viewl . _asFingerTree + where + f EmptyL = EmptyL + f (Elem x :< s) = x :< OrdSeq s + +-- Last element +-- \(O(1)\) +viewr :: OrdSeq a -> ViewR OrdSeq a +viewr = f . FT.viewr . _asFingerTree + where + f EmptyR = EmptyR + f (s :> Elem x) = OrdSeq s :> x + + +-- \(O(1)\) +minView :: OrdSeq a -> Maybe (a, OrdSeq a) +minView s = case viewl s of + EmptyL -> Nothing + (x :< t) -> Just (x,t) + +-- \(O(1)\) +lookupMin :: OrdSeq a -> Maybe a +lookupMin = fmap fst . minView + +-- \(O(1)\) +maxView :: OrdSeq a -> Maybe (a, OrdSeq a) +maxView s = case viewr s of + EmptyR -> Nothing + (t :> x) -> Just (x,t) + +-- \(O(1)\) +lookupMax :: OrdSeq a -> Maybe a +lookupMax = fmap fst . maxView 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,124 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Permutation +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing a Permutation +-- +-------------------------------------------------------------------------------- +module Data.Permutation where + +import Control.DeepSeq +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 +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- + +-- | 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,Generic) +makeLenses ''Permutation + +instance NFData a => NFData (Permutation a) + +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) + +-- | Previous item in a cyclic permutation +previous :: GV.Vector v a => v a -> Int -> a +previous 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. +-- +-- runnign time: \(O(1)\) +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 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,157 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlanarGraph +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing connected planar graphs +-------------------------------------------------------------------------------- +module Data.PlanarGraph( -- $setup + -- * The Planar Graph type + PlanarGraph + , embedding, vertexData, dartData, faceData, rawDartData + , edgeData + + , World(..) + , DualOf + + -- * Representing edges: Arcs and Darts + , Arc(..) + , Direction(..), rev + + , Dart(..), arc, direction + , twin, isPositive + + -- * Vertices + + , VertexId(..), VertexId' + + -- * Building a planar graph + + , planarGraph, planarGraph', fromAdjacencyLists + , toAdjacencyLists + , fromAdjRep, toAdjRep + + -- , buildFromJSON + + -- * Quering a planar graph + + , numVertices, numDarts, numEdges, numFaces + , darts', darts, edges', edges, vertices', vertices, faces', faces + , traverseVertices, traverseDarts, traverseFaces + + , tailOf, headOf, endPoints + , incidentEdges, incomingEdges, outgoingEdges, neighboursOf + , nextIncidentEdge, prevIncidentEdge + + -- * Associated Data + + , HasDataOf(..), endPointDataOf, endPointData + + , dual + + -- * Faces + + , FaceId(..), FaceId' + , leftFace, rightFace + , boundaryDart, boundary, boundary', boundaryVertices + , nextEdge, prevEdge + + ) where + + +import Data.PlanarGraph.Core +import Data.PlanarGraph.Dart +import Data.PlanarGraph.Dual +import Data.PlanarGraph.IO + +-------------------------------------------------------------------------------- +-- $setup +-- >>> :{ +-- let dart i s = Dart (Arc i) (read s) +-- (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..] +-- myGraph :: PlanarGraph () 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-") +-- ] +-- ] +-- :} +-- +-- +-- This represents the following graph. Note that the graph is undirected, the +-- arrows are just to indicate what the Positive direction of the darts is. +-- +-- ![myGraph](docs/Data/PlanarGraph/testG.png) + + + + +-------------------------------------------------------------------------------- +-- 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/PlanarGraph/AdjRep.hs b/src/Data/PlanarGraph/AdjRep.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlanarGraph/AdjRep.hs @@ -0,0 +1,63 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlanarGraph.AdjRep +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data types that to represent a planar graph as Adjacency Lists. The main +-- purpose is to help encode/decode a PlanarGraph as a JSON/YAML file. +-- +-------------------------------------------------------------------------------- +module Data.PlanarGraph.AdjRep where + +import Data.Aeson +import GHC.Generics (Generic) +import Control.Lens(Bifunctor(..)) + +-------------------------------------------------------------------------------- + +-- | Data type representing the graph in its JSON/Yaml format +data Gr v f = Gr { ajacencies :: [v] + , faces :: [f] + } deriving (Generic) + +instance Bifunctor Gr where + bimap f g (Gr vs fs) = Gr (map f vs) (map g fs) + +instance (ToJSON v, ToJSON f) => ToJSON (Gr v f) where + toEncoding = genericToEncoding defaultOptions +instance (FromJSON v, FromJSON f) => FromJSON (Gr v f) + +---------------------------------------- + +-- | A vertex, represented by an id, its adjacencies, and its data. +data Vtx v e = Vtx { id :: Int + , adj :: [(Int,e)] -- ^ adjacent vertices + data on the + -- edge. Adjacencies are given in + -- arbitrary order + , vData :: v + } deriving (Generic) + +instance Bifunctor Vtx where + bimap f g (Vtx i as x) = Vtx i (map (\(j,y) -> (j,g y)) as) (f x) + +instance (ToJSON v, ToJSON e) => ToJSON (Vtx v e) where + toEncoding = genericToEncoding defaultOptions +instance (FromJSON v, FromJSON e) => FromJSON (Vtx v e) + +---------------------------------------- + +-- | Faces +data Face f = Face { incidentEdge :: (Int,Int) -- ^ an edge (u,v) s.t. the face + -- is right from (u,v) + , fData :: f + } deriving (Generic,Functor) + +instance ToJSON f => ToJSON (Face f) where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON f => FromJSON (Face f) + + +-------------------------------------------------------------------------------- diff --git a/src/Data/PlanarGraph/Core.hs b/src/Data/PlanarGraph/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlanarGraph/Core.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlanarGraph.Core +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing connected planar graphs +-------------------------------------------------------------------------------- +module Data.PlanarGraph.Core where + + +import Control.DeepSeq +import Control.Lens hiding ((.=)) +import Control.Monad.State.Strict +import Data.Aeson +import qualified Data.Foldable as F +import Data.Permutation +import Data.PlanarGraph.Dart +import Data.Type.Equality (gcastWith, (:~:)(..)) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import GHC.Generics (Generic) +import Unsafe.Coerce (unsafeCoerce) + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- $setup +-- >>> :{ +-- let dart i s = Dart (Arc i) (read s) +-- (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..] +-- myGraph :: PlanarGraph () 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-") +-- ] +-- ] +-- :} +-- +-- +-- This represents the following graph. Note that the graph is undirected, the +-- arrows are just to indicate what the Positive direction of the darts is. +-- +-- ![myGraph](docs/Data/PlanarGraph/testG.png) + +-------------------------------------------------------------------------------- +-- * Representing The World + +-- | The world in which the graph lives +data World = Primal | Dual deriving (Show,Eq) + +-- | We can take the dual of a world. For the Primal this gives us the Dual, +-- for the Dual this gives us the Primal. +type family DualOf (sp :: World) where + DualOf Primal = Dual + DualOf Dual = Primal + +-- | The Dual of the Dual is the Primal. +dualDualIdentity :: forall w. DualOf (DualOf w) :~: w +dualDualIdentity = unsafeCoerce Refl + -- manual proof: + -- DualOf (DualOf Primal) = Primal + -- DualOf (DualOf Dual) = Dual + + +-------------------------------------------------------------------------------- +-- * VertexId's + +-- | 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,ToJSON,FromJSON,Generic,NFData) +-- VertexId's are in the range 0...|orbits|-1 + +-- | Shorthand for vertices in the primal. +type VertexId' s = VertexId s Primal + +unVertexId :: Getter (VertexId s w) Int +unVertexId = to _unVertexId + +instance Show (VertexId s w) where + show (VertexId i) = "VertexId " ++ show i + +-------------------------------------------------------------------------------- +-- * FaceId's + +-- | The type to reprsent FaceId's +newtype FaceId s w = FaceId { _unFaceId :: VertexId s (DualOf w) } + deriving (Eq,Ord,Enum,ToJSON,FromJSON) + +-- | Shorthand for FaceId's in the primal. +type FaceId' s = FaceId s Primal + +instance Show (FaceId s w) where + show (FaceId (VertexId i)) = "FaceId " ++ 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. Therefore, every dart directly bounds the face to its right. +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 + , _dual :: PlanarGraph s (DualOf w) f e v + } deriving (Generic) + +instance (Show v, Show e, Show f) => Show (PlanarGraph s w v e f) where + show (PlanarGraph e v r f _) = unwords [ "PlanarGraph" + , "embedding =", show e + , ", vertexData =", show v + , ", rawDartData =", show r + , ", faceData =", show f + ] + +instance (Eq v, Eq e, Eq f) => Eq (PlanarGraph s w v e f) where + (PlanarGraph e v r f _) == (PlanarGraph e' v' r' f' _) = e == e' && v == v' + && r == r' && f == f' + + + +-- ** lenses and getters + +-- | Get the embedding, reprsented as a permutation of the darts, of this +-- graph. +embedding :: Getter (PlanarGraph s w v e f) (Permutation (Dart s)) +embedding = to _embedding + +vertexData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v' e f) + (V.Vector v) (V.Vector v') +vertexData = lens _vertexData (\g vD -> updateData (const vD) id id g) + +rawDartData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e' f) + (V.Vector e) (V.Vector e') +rawDartData = lens _rawDartData (\g dD -> updateData id (const dD) id g) + +faceData :: Lens (PlanarGraph s w v e f) (PlanarGraph s w v e f') + (V.Vector f) (V.Vector f') +faceData = lens _faceData (\g fD -> updateData id id (const fD) g) + +-- | Get the dual graph of this graph. +dual :: Getter (PlanarGraph s w v e f) (PlanarGraph s (DualOf w) f e v) +dual = to _dual + + +-- FIXME: So I guess the two darts associated with an edge can store different +-- data. This is useful. Make sure that works as expected. + +-- | 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 dD -> updateData id (const $ reorderEdgeData dD) id g) + +-- | 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 + +-- | Helper function to update the data in a planar graph. Takes care to update +-- both the data in the original graph as well as in the dual. +updateData :: forall s w v e f v' e' f' + . (V.Vector v -> V.Vector v') + -> (V.Vector e -> V.Vector e') + -> (V.Vector f -> V.Vector f') + -> PlanarGraph s w v e f + -> PlanarGraph s w v' e' f' +updateData = gcastWith proof updateData' + where + proof :: DualOf (DualOf w) :~: w + proof = dualDualIdentity + +-- | The function that does the actual work for 'updateData' +updateData' :: (DualOf (DualOf w) ~ w) + => (V.Vector v -> V.Vector v') + -> (V.Vector e -> V.Vector e') + -> (V.Vector f -> V.Vector f') + -> PlanarGraph s w v e f + -> PlanarGraph s w v' e' f' +updateData' fv fe ff (PlanarGraph em vtxData dData fData dg) = g' + where + vtxData' = fv vtxData + dData' = fe dData + fData' = ff fData + + g' = PlanarGraph em vtxData' dData' fData' dg' + dg' = PlanarGraph (dg^.embedding) fData' dData' vtxData' g' + + +-- | 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 + +-- | Traverse the vertices +-- +-- (^.vertexData) <$> traverseVertices (\i x -> Just (i,x)) myGraph +-- Just [(VertexId 0,()),(VertexId 1,()),(VertexId 2,()),(VertexId 3,())] +-- >>> traverseVertices (\i x -> print (i,x)) myGraph >> pure () +-- (VertexId 0,()) +-- (VertexId 1,()) +-- (VertexId 2,()) +-- (VertexId 3,()) +traverseVertices :: Applicative m + => (VertexId s w -> v -> m v') + -> PlanarGraph s w v e f + -> m (PlanarGraph s w v' e f) +traverseVertices f = itraverseOf (vertexData.itraversed) (\i -> f (VertexId i)) + +-- | Traverses the darts +-- +-- >>> traverseDarts (\d x -> print (d,x)) myGraph >> pure () +-- (Dart (Arc 0) +1,"a+") +-- (Dart (Arc 0) -1,"a-") +-- (Dart (Arc 1) +1,"b+") +-- (Dart (Arc 1) -1,"b-") +-- (Dart (Arc 2) +1,"c+") +-- (Dart (Arc 2) -1,"c-") +-- (Dart (Arc 3) +1,"d+") +-- (Dart (Arc 3) -1,"d-") +-- (Dart (Arc 4) +1,"e+") +-- (Dart (Arc 4) -1,"e-") +-- (Dart (Arc 5) +1,"g+") +-- (Dart (Arc 5) -1,"g-") +traverseDarts :: Applicative m + => (Dart s -> e -> m e') + -> PlanarGraph s w v e f + -> m (PlanarGraph s w v e' f) +traverseDarts f = itraverseOf (rawDartData.itraversed) (\i -> f (toEnum i)) + +-- | Traverses the faces +-- +-- >>> traverseFaces (\i x -> print (i,x)) myGraph >> pure () +-- (FaceId 0,()) +-- (FaceId 1,()) +-- (FaceId 2,()) +-- (FaceId 3,()) +traverseFaces :: Applicative m + => (FaceId s w -> f -> m f') + -> PlanarGraph s w v e f + -> m (PlanarGraph s w v e f') +traverseFaces f = itraverseOf (faceData.itraversed) (\i -> f (FaceId $ VertexId i)) + +-------------------------------------------------------------------------------- +-- ** Constructing a Planar graph + +-- | Construct a planar graph +-- +-- running time: \(O(n)\). +planarGraph' :: Permutation (Dart s) -> PlanarGraph s w () () () +planarGraph' perm = pg + where + pg = PlanarGraph perm vData eData fData (computeDual pg) + -- note the lazy calculation of computeDual that refers to pg itself + 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, given the darts in cyclic order around each +-- vertex. +-- +-- running time: \(O(n)\). +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 + + + + +-- | Produces the adjacencylists for all vertices in the graph. For every vertex, the +-- adjacent vertices are given in counter clockwise order. +-- +-- Note that in case a vertex u as a self loop, we have that this vertexId occurs +-- twice in the list of neighbours, i.e.: u : [...,u,..,u,...]. Similarly, if there are +-- multiple darts between a pair of edges they occur multiple times. +-- +-- running time: \(O(n)\) +toAdjacencyLists :: PlanarGraph s w v e f -> [(VertexId s w, V.Vector (VertexId s w))] +toAdjacencyLists pg = map (\u -> (u,neighboursOf u pg)) . V.toList . vertices' $ pg +-- TODO: something weird happens when we have self-loops here. + + +-------------------------------------------------------------------------------- +-- ** Convenience functions + +-- | 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^.dataOf 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 +-- +-- running time: \(O(1)\) +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 +-- +-- running time: \(O(1)\) +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) +-- +-- running time: \(O(1)\) +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. +-- +-- running time: \(O(k)\), where \(k\) is the output size +incidentEdges :: VertexId s w -> PlanarGraph s w v e f + -> V.Vector (Dart s) +incidentEdges (VertexId v) g = g^?!embedding.orbits.ix v + -- TODO: The Delaunay triang. stuff seems to produce these in clockwise order instead + +-- | 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. +-- +-- running time: \(O(k)\), where \(k\) is the output size +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 + +-- | Given a dart d that points into some vertex v, report the next dart in the +-- cyclic order around v. +-- +-- running time: \(O(1)\) +nextIncidentEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +nextIncidentEdge d g = let perm = g^.embedding + (i,j) = lookupIdx perm d + in next (perm^?!orbits.ix i) j + + +-- | Given a dart d that points into some vertex v, report the next dart in the +-- cyclic order around v. +-- +-- running time: \(O(1)\) +prevIncidentEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +prevIncidentEdge d g = let perm = g^.embedding + (i,j) = lookupIdx perm d + in previous (perm^?!orbits.ix i) j + + +-------------------------------------------------------------------------------- +-- * Access data + + +class HasDataOf g i where + type DataOf g i + -- | get the data associated with the value i. + -- + -- running time: \(O(1)\) to read the data, \(O(n)\) to write it. + dataOf :: i -> Lens' g (DataOf g i) + +instance HasDataOf (PlanarGraph s w v e f) (VertexId s w) where + type DataOf (PlanarGraph s w v e f) (VertexId s w) = v + dataOf (VertexId i) = vertexData.singular (ix i) + +instance HasDataOf (PlanarGraph s w v e f) (Dart s) where + type DataOf (PlanarGraph s w v e f) (Dart s) = e + dataOf d = rawDartData.singular (ix $ fromEnum d) + +instance HasDataOf (PlanarGraph s w v e f) (FaceId s w) where + type DataOf (PlanarGraph s w v e f) (FaceId s w) = f + dataOf (FaceId (VertexId i)) = faceData.singular (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 +-- +-- running time: \(O(1)\) +endPointData :: Dart s -> PlanarGraph s w v e f -> (v,v) +endPointData d g = let (u,v) = endPoints d g in (g^.dataOf u, g^.dataOf 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 (computeDual myGraph)^.embedding.orbits == answer +-- :} +-- True +-- +-- running time: \(O(n)\). +computeDual :: forall s w v e f. PlanarGraph s w v e f -> PlanarGraph s (DualOf w) f e v +computeDual = gcastWith proof computeDual' + where + proof :: DualOf (DualOf w) :~: w + proof = dualDualIdentity + +-- | Does the actual work for dualGraph +computeDual' :: (DualOf (DualOf w) ~ w) + => PlanarGraph s w v e f -> PlanarGraph s (DualOf w) f e v +computeDual' g = dualG + where + perm = g^.embedding + dualG = PlanarGraph (cycleRep (elems perm) (apply perm . twin)) + (g^.faceData) + (g^.rawDartData) + (g^.vertexData) + g diff --git a/src/Data/PlanarGraph/Dart.hs b/src/Data/PlanarGraph/Dart.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlanarGraph/Dart.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlanarGraph.Dart +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing Darts (edges) in a planar graph. +-------------------------------------------------------------------------------- +module Data.PlanarGraph.Dart where + +import Control.DeepSeq +import Control.Lens hiding ((.=)) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary(..),suchThat) + +-- $setup +-- >>> :{ +-- let dart i s = Dart (Arc i) (read s) +-- :} + +-------------------------------------------------------------------------------- + +-- | 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,Generic,NFData) + +instance Show (Arc s) where + show (Arc i) = "Arc " ++ show i + +instance Arbitrary (Arc s) where + arbitrary = Arc <$> (arbitrary `suchThat` (>= 0)) + + +-- | Darts have a direction which is either Positive or Negative (shown as +1 +-- or -1, respectively). +data Direction = Negative | Positive deriving (Eq,Ord,Bounded,Enum,Generic) + +instance NFData Direction + +instance Show Direction where + show Positive = "+1" + show Negative = "-1" + +instance Read Direction where + readsPrec _ "-1" = [(Negative,"")] + readsPrec _ "+1" = [(Positive,"")] + readsPrec _ _ = [] + +instance Arbitrary Direction where + arbitrary = (\b -> if b then Positive else Negative) <$> arbitrary + +-- | 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,Generic) +makeLenses ''Dart + +instance NFData (Dart s) + +instance Show (Dart s) where + show (Dart a d) = "Dart (" ++ show a ++ ") " ++ show d + +instance Arbitrary (Dart s) where + arbitrary = Dart <$> arbitrary <*> arbitrary + +-- | 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) Negative + -- get the back edge by adding one + + fromEnum (Dart (Arc i) d) = case d of + Positive -> 2*i + Negative -> 2*i + 1 + + +-- | Enumerates all darts such that +-- allDarts !! i = d <=> i == fromEnum d +allDarts :: [Dart s] +allDarts = concatMap (\a -> [Dart a Positive, Dart a Negative]) [Arc 0..] diff --git a/src/Data/PlanarGraph/Dual.hs b/src/Data/PlanarGraph/Dual.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlanarGraph/Dual.hs @@ -0,0 +1,145 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlanarGraph +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing connected planar graphs. This module contains +-- everything that has to do with the dual graph (i.e. computing it/ operations +-- on faces etc.) +-------------------------------------------------------------------------------- +module Data.PlanarGraph.Dual where + +import Control.Lens hiding ((.=)) +import Data.PlanarGraph.Core +import Data.PlanarGraph.Dart +import qualified Data.Vector as V +import Data.Maybe (fromMaybe) + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- $setup +-- >>> :{ +-- let dart i s = Dart (Arc i) (read s) +-- (aA:aB:aC:aD:aE:aG:_) = take 6 [Arc 0..] +-- myGraph :: PlanarGraph () 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-") +-- ] +-- ] +-- :} +-- +-- +-- This represents the following graph. Note that the graph is undirected, the +-- arrows are just to indicate what the Positive direction of the darts is. +-- +-- ![myGraph](docs/Data/PlanarGraph/testG.png) + + +-- | 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 +-- +-- running time: \(O(1)\). +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 +-- +-- running time: \(O(1)\). +rightFace :: Dart s -> PlanarGraph s w v e f -> FaceId s w +rightFace d g = FaceId . tailOf d $ _dual g + + +-- | Get the next edge along the face +-- +-- running time: \(O(1)\). +nextEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +nextEdge d = nextIncidentEdge d . _dual + +-- | Get the previous edge along the face +-- +-- running time: \(O(1)\). +prevEdge :: Dart s -> PlanarGraph s w v e f -> Dart s +prevEdge d = prevIncidentEdge d . _dual + + +-- | Gets a dart bounding this face. I.e. a dart d such that the face lies to +-- the right of the dart. +boundaryDart :: FaceId s w -> PlanarGraph s w v e f -> Dart s +boundaryDart f = V.head . boundary f +-- TODO: make sure that this is indeed to the right. + +-- | The darts bounding this face, for internal faces in clockwise order, for +-- the outer face in counter clockwise order. +-- +-- +-- running time: \(O(k)\), where \(k\) is the output size. +boundary :: FaceId s w -> PlanarGraph s w v e f -> V.Vector (Dart s) +boundary (FaceId v) g = incidentEdges v $ _dual g + + +-- | Generates the darts incident to a face, starting with the given dart. +-- +-- +-- \(O(k)\), where \(k\) is the number of darts reported +boundary' :: Dart s -> PlanarGraph s w v e f -> V.Vector (Dart s) +boundary' d g = fromMaybe (error "boundary'") . rotateTo d $ boundary (rightFace d g) g + where + rotateTo :: Eq a => a -> V.Vector a -> Maybe (V.Vector a) + rotateTo x v = f <$> V.elemIndex x v + where + f i = let (a,b) = V.splitAt i v in b <> a + + +-- | The vertices bounding this face, for internal faces in clockwise order, for +-- the outer face in counter clockwise order. +-- +-- +-- running time: \(O(k)\), where \(k\) is the output size. +boundaryVertices :: FaceId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w) +boundaryVertices f g = fmap (flip tailOf g) $ boundary f g + +-- -- | Gets the next dart along the face +-- nextDart :: Dart s -> PlanarGraph s w v e f -> Dart s +-- nextDart d g = f rightFace e diff --git a/src/Data/PlanarGraph/EdgeOracle.hs b/src/Data/PlanarGraph/EdgeOracle.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlanarGraph/EdgeOracle.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlanarGraph.EdgeOracle +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data structure to represent a planar graph with which we can test in +-- \(O(1)\) time if an edge between a pair of vertices exists. +-------------------------------------------------------------------------------- +module Data.PlanarGraph.EdgeOracle where + +import Control.Applicative (Alternative(..)) +import Control.Lens hiding ((.=)) +import Control.Monad.ST (ST) +import Control.Monad.State.Strict +import Data.Bitraversable +import Data.Ext +import qualified Data.Foldable as F +import Data.Maybe (catMaybes, isJust) +import Data.PlanarGraph.Core +import Data.PlanarGraph.Dart +import Data.Traversable (fmapDefault,foldMapDefault) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as GV +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as UV +import qualified Data.Vector.Unboxed.Mutable as UMV + +-------------------------------------------------------------------------------- + +-- | Edge Oracle: +-- +-- main idea: store adjacency lists in such a way that we store an edge (u,v) +-- either in u's adjacency list or in v's. This can be done s.t. all adjacency +-- lists have length at most 6. +-- +-- note: Every edge is stored exactly once (i.e. either at u or at v, but not both) +newtype EdgeOracle s w a = + EdgeOracle { _unEdgeOracle :: V.Vector (V.Vector (VertexId s w :+ a)) } + deriving (Show,Eq) + +instance Functor (EdgeOracle s w) where + fmap = fmapDefault + +instance Foldable (EdgeOracle s w) where + foldMap = foldMapDefault + +instance Traversable (EdgeOracle s w) where + traverse f (EdgeOracle v) = EdgeOracle <$> traverse g v + where + -- g :: V.Vector (VertexId :+ a) -> f (V.Vector (VertexId :+ b)) + g = traverse (bitraverse pure f) + + +-- | Given a planar graph, construct an edge oracle. Given a pair of vertices +-- this allows us to efficiently find the dart representing this edge in the +-- graph. +-- +-- pre: No self-loops and no multi-edges!!! +-- +-- running time: \(O(n)\) +edgeOracle :: PlanarGraph s w v e f -> EdgeOracle s w (Dart s) +edgeOracle g = buildEdgeOracle [ (v, mkAdjacency v <$> incidentEdges v g) + | v <- F.toList $ vertices' g + ] + where + mkAdjacency v d = otherVtx v d :+ d + otherVtx v d = let u = tailOf d g in if u == v then headOf d g else u + + + +-- | Builds an edge oracle that can be used to efficiently test if two vertices +-- are connected by an edge. +-- +-- running time: \(O(n)\) +buildEdgeOracle :: forall f s w e. (Foldable f) + => [(VertexId s w, f (VertexId s w :+ e))] -> EdgeOracle s w e +buildEdgeOracle inAdj' = EdgeOracle $ V.create $ do + counts <- UV.thaw initCounts + marks <- UMV.replicate (UMV.length counts) False + outV <- MV.new (UMV.length counts) + build counts marks outV initQ + pure outV + -- main idea: maintain a vector with counts; i.e. how many unprocessed + -- vertices are adjacent to u, and a bit vector with marks to keep track if + -- a vertex has been processed yet. When we process a vertex, we keep only + -- the adjacencies of unprocessed verticese. + where + -- Convert to a vector representation + inAdj = V.create $ do + mv <- MV.new (length inAdj') + forM_ inAdj' $ \(VertexId i,adjI) -> + MV.write mv i (V.fromList . F.toList $ adjI) + pure mv + + initCounts = V.convert . fmap GV.length $ inAdj + -- initial vertices available for processing + initQ = GV.ifoldr (\i k q -> if k <= 6 then i : q else q) [] initCounts + + -- | Construct the adjacencylist for vertex i. I.e. by retaining only adjacent + -- vertices that have not been processed yet. + extractAdj :: UMV.MVector s' Bool -> Int + -> ST s' (V.Vector (VertexId s w :+ e)) + extractAdj marks i = let p = fmap not . UMV.read marks . (^.core.unVertexId) + in GV.filterM p $ inAdj V.! i + + -- | Decreases the number of adjacencies that vertex j has + -- if it has <= 6 adjacencies left it has become available for processing + decrease :: UMV.MVector s' Int -> (VertexId s w :+ e') + -> ST s' (Maybe Int) + decrease counts (VertexId j :+ _) = do k <- UMV.read counts j + let k' = k - 1 + UMV.write counts j k' + pure $ if k' <= 6 then Just j else Nothing + + -- The actual algorithm that builds the items + build :: UMV.MVector s' Int -> UMV.MVector s' Bool + -> MV.MVector s' (V.Vector (VertexId s w :+ e)) -> [Int] -> ST s' () + build _ _ _ [] = pure () + build counts marks outV (i:q) = do + b <- UMV.read marks i + nq <- if b then pure [] + else do + adjI <- extractAdj marks i + MV.write outV i adjI + UMV.write marks i True + V.toList <$> mapM (decrease counts) adjI + build counts marks outV (catMaybes nq <> q) + + + +-- | Test if u and v are connected by an edge. +-- +-- running time: \(O(1)\) +hasEdge :: VertexId s w -> VertexId s w -> EdgeOracle s w a -> Bool +hasEdge u v = isJust . findEdge u v + + +-- | Find the edge data corresponding to edge (u,v) if such an edge exists +-- +-- running time: \(O(1)\) +findEdge :: VertexId s w -> VertexId s w -> EdgeOracle s w a -> Maybe a +findEdge (VertexId u) (VertexId v) (EdgeOracle os) = find' u v <|> find' v u + where + find' j i = fmap (^.extra) . F.find (\(VertexId k :+ _) -> j == k) $ os V.! i + +-- | Given a pair of vertices (u,v) returns the dart, oriented from u to v, +-- corresponding to these vertices. +-- +-- running time: \(O(1)\) +findDart :: VertexId s w -> VertexId s w -> EdgeOracle s w (Dart s) -> Maybe (Dart s) +findDart (VertexId u) (VertexId v) (EdgeOracle os) = find' twin u v <|> find' id v u + where + -- looks up j in the adjacencylist of i and applies f to the result + find' f j i = fmap (f . (^.extra)) . F.find (\(VertexId k :+ _) -> j == k) $ os V.! i diff --git a/src/Data/PlanarGraph/IO.hs b/src/Data/PlanarGraph/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/PlanarGraph/IO.hs @@ -0,0 +1,156 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.PlanarGraph.IO +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Converting from/to our JSON/Yaml representation of the plane graph +-- +-------------------------------------------------------------------------------- +module Data.PlanarGraph.IO where + +import Control.Lens +import Control.Monad (forM_) +import Control.Monad.State.Strict +import Data.Aeson +import Data.Bifunctor +import Data.Ext +import qualified Data.Foldable as F +import Data.Maybe (fromJust) +import Data.Permutation +import Data.PlanarGraph.AdjRep (Face(Face), Vtx(Vtx),Gr(Gr)) +import Data.PlanarGraph.Core +import Data.PlanarGraph.Dart +import Data.PlanarGraph.Dual +import Data.PlanarGraph.EdgeOracle +import Data.Proxy +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV + +-------------------------------------------------------------------------------- + +instance (ToJSON v, ToJSON e, ToJSON f) => ToJSON (PlanarGraph s w v e f) where + toEncoding = toEncoding . toAdjRep + toJSON = toJSON . toAdjRep + +instance (FromJSON v, FromJSON e, FromJSON f) => FromJSON (PlanarGraph s Primal v e f) where + parseJSON v = fromAdjRep (Proxy :: Proxy s) <$> parseJSON v + +-------------------------------------------------------------------------------- + + +-- | Transforms the planar graph into a format taht can be easily converted +-- into JSON format. For every vertex, the adjacent vertices are given in +-- counter clockwise order. +-- +-- See 'toAdjacencyLists' for notes on how we handle self-loops. +-- +-- running time: \(O(n)\) +toAdjRep :: PlanarGraph s w v e f -> Gr (Vtx v e) (Face f) +toAdjRep g = Gr vs fs + where + vs = [ Vtx ui (map (mkEdge u) $ F.toList us) (g^.dataOf u) + | (u@(VertexId ui),us) <- toAdjacencyLists g + ] + fs = [ Face (outerComponentEdge f) x + | (f,x) <- F.toList $ faces g + ] + + outerComponentEdge f = bimap (^.unVertexId) (^.unVertexId) + $ endPoints (boundaryDart f g) g + + eo = edgeOracle g + + findData u v = (\d -> g^.dataOf d) <$> findDart u v eo + mkEdge u v@(VertexId vi) = (vi,fromJust $ findData u v) + + +-- | Read a planar graph, given in JSON format into a planar graph. The adjacencylists +-- should be in counter clockwise order. +-- +-- running time: \(O(n)\) +fromAdjRep :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s Primal v e f +fromAdjRep px gr@(Gr as fs) = g&vertexData .~ reorder vs' _unVertexId + &dartData .~ ds + &faceData .~ reorder fs' (_unVertexId._unFaceId) + where + -- build the actual graph using the adjacencies + g = buildGraph px gr + -- build an edge oracle so that we can quickly lookup the dart corresponding to a + -- pair of vertices. + oracle = edgeOracle g + -- function to lookup a given dart + findEdge' u v = fromJust $ findDart u v oracle + -- faces are right of oriented darts + findFace ui vi = let d = findEdge' (VertexId ui) (VertexId vi) in rightFace d g + + vs' = V.fromList [ VertexId vi :+ v | Vtx vi _ v <- as ] + fs' = V.fromList [ findFace ui vi :+ f | Face (ui,vi) f <- fs ] + + ds = V.fromList $ concatMap (\(Vtx vi us _) -> + [(findEdge' (VertexId vi) (VertexId ui), x) | (ui,x) <- us] + ) as + + -- TODO: Properly handle graphs with self-loops + +-- | Builds the graph from the adjacency lists (but ignores all associated data) +buildGraph :: proxy s -> Gr (Vtx v e) (Face f) -> PlanarGraph s Primal () () () +buildGraph _ (Gr as' _) = fromAdjacencyLists as + where + as = [ (VertexId vi, V.fromList [VertexId ui | (ui,_) <- us]) + | Vtx vi us _ <- as' + ] + +-- make sure we order the data values appropriately +reorder :: V.Vector (i :+ a) -> (i -> Int) -> V.Vector a +reorder v f = V.create $ do + v' <- MV.new (V.length v) + forM_ v $ \(i :+ x) -> + MV.write v' (f i) x + pure v' + +-------------------------------------------------------------------------------- + +-- | Construct a planar graph from a adjacency matrix. For every vertex, all +-- vertices should be given in counter clockwise order. +-- +-- pre: No self-loops, and no multi-edges +-- +-- running time: \(O(n)\). +fromAdjacencyLists :: forall s w h. (Foldable h, Functor h) + => [(VertexId s w, h (VertexId s w))] + -> PlanarGraph s w () () () +fromAdjacencyLists adjM = planarGraph' . toCycleRep n $ perm + where + n = sum . fmap length $ perm + perm = map toOrbit $ adjM' + + adjM' = fmap (second F.toList) adjM + + -- -- | Assign Arcs + -- adjM' = (^._1) . foldr assignArcs (SP [] 0) $ adjM + + -- Build an edgeOracle, so that we can query the arcId assigned to + -- an edge in O(1) time. + oracle :: EdgeOracle s w Int + oracle = fmap (^.core) . assignArcs . buildEdgeOracle + . map (second $ map ext) $ adjM' + + toOrbit (u,adjU) = concatMap (toDart u) adjU + + -- if u = v we have a self-loop, so we add both a positive and a negative dart + toDart u v = let Just a = findEdge u v oracle + in case u `compare` v of + LT -> [Dart (Arc a) Positive] + EQ -> [Dart (Arc a) Positive, Dart (Arc a) Negative] + GT -> [Dart (Arc a) Negative] + + +assignArcs :: EdgeOracle s w e -> EdgeOracle s w (Int :+ e) +assignArcs o = evalState (traverse f o) 0 + where + f :: e -> State Int (Int :+ e) + f e = do i <- get ; put (i+1) ; pure (i :+ e) 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,283 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Range +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data type for representing Generic Ranges (Intervals) and functions that +-- work with them. +-- +-------------------------------------------------------------------------------- +module Data.Range( EndPoint(..) + , isOpen, isClosed + , unEndPoint + , Range(..) + , prettyShow + , lower, upper + , pattern OpenRange, pattern ClosedRange, pattern Range' + , inRange, width, clipLower, clipUpper, midPoint, clampTo + , isValid, covers + + , shiftLeft, shiftRight + ) where + +import Control.DeepSeq +import Control.Lens +import Data.Intersection +import Data.Vinyl.CoRec +import GHC.Generics (Generic) +import Test.QuickCheck +import Text.Printf (printf) + +-------------------------------------------------------------------------------- +-- * Representing Endpoints of a Range + +-- | Endpoints of a range may either be open or closed. +data EndPoint a = Open !a + | Closed !a + deriving (Show,Read,Eq,Functor,Foldable,Traversable,Generic,NFData) + +instance Ord a => Ord (EndPoint a) where + -- | order on the actual value, and Open before Closed + a `compare` b = f a `compare` f b + where + f (Open x) = (x,False) + f (Closed x) = (x,True) + +instance Arbitrary r => Arbitrary (EndPoint r) where + arbitrary = frequency [ (1, Open <$> arbitrary) + , (9, Closed <$> arbitrary) + ] + +_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 +{-# INLINE unEndPoint #-} + +isOpen :: EndPoint a -> Bool +isOpen (Open _) = True +isOpen _ = False + +isClosed :: EndPoint a -> Bool +isClosed = not . isOpen + + +-------------------------------------------------------------------------------- +-- * The Range Data type + +-- | Data type for representing ranges. +data Range a = Range { _lower :: !(EndPoint a) + , _upper :: !(EndPoint a) + } + deriving (Eq,Functor,Foldable,Traversable,Generic,NFData) +makeLenses ''Range + +instance Show a => Show (Range a) where + show (Range l u) = printf "Range (%s) (%s)" (show l) (show u) + + +pattern OpenRange :: a -> a -> Range a +pattern OpenRange l u = Range (Open l) (Open u) + +pattern ClosedRange :: a -> a -> Range a +pattern ClosedRange l u = Range (Closed l) (Closed u) + +-- | A range from l to u, ignoring/forgetting the type of the endpoints +pattern Range' :: a -> a -> Range a +pattern Range' l u <- ((\r -> (r^.lower.unEndPoint,r^.upper.unEndPoint) -> (l,u))) +{-# COMPLETE Range' #-} + +instance (Arbitrary r, Ord r) => Arbitrary (Range r) where + arbitrary = do + l <- arbitrary + r <- suchThat arbitrary (p l) + return $ Range l r + where + p (Open l) r = l < r^.unEndPoint + p (Closed l) r = l <= r^.unEndPoint + + +-- | Helper function to show a range in mathematical notation. +-- +-- >>> prettyShow $ OpenRange 0 2 +-- "(0,2)" +-- >>> prettyShow $ ClosedRange 0 2 +-- "[0,2]" +-- >>> prettyShow $ Range (Open 0) (Closed 5) +-- "(0,5]" +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 +-- +-- This one is kind of weird +-- +-- >>> 0 `inRange` Range (Closed 0) (Open 0) +-- 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) + +-- | Clamps a value to a range. I.e. if the value lies outside the range we +-- report the closest value "in the range". Note that if an endpoint of the +-- range is open we report that value anyway, so we return a value that is +-- truely inside the range only if that side of the range is closed. +-- +-- >>> clampTo (ClosedRange 0 10) 20 +-- 10 +-- >>> clampTo (ClosedRange 0 10) (-20) +-- 0 +-- >>> clampTo (ClosedRange 0 10) 5 +-- 5 +-- >>> clampTo (OpenRange 0 10) 20 +-- 10 +-- >>> clampTo (OpenRange 0 10) (-20) +-- 0 +-- >>> clampTo (OpenRange 0 10) 5 +-- 5 +clampTo :: Ord r => Range r -> r -> r +clampTo (Range' l u) x = (x `max` l) `min` u + + +-------------------------------------------------------------------------------- +-- * 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 + +-- | Wether or not the first range completely covers the second one +covers :: forall a. Ord a => Range a -> Range a -> Bool +x `covers` y = maybe False (== y) . asA @(Range a) $ x `intersect` y + + +-- | 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/Sequence/Util.hs b/src/Data/Sequence/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sequence/Util.hs @@ -0,0 +1,76 @@ +module Data.Sequence.Util where + +import Data.Sequence(Seq, ViewL(..),ViewR(..)) +import qualified Data.Sequence as S +import qualified Data.Vector.Generic as V + +-------------------------------------------------------------------------------- + +-- | Given a monotonic predicate, 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 + +-- | Given a monotonic predicate, 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(T*\log n)\), where \(T\) is the time to execute the +-- predicate. +binarySearchVec :: V.Vector v a + => (a -> Bool) -> v a -> Maybe Int +binarySearchVec p' v | V.null v = Nothing + | not $ p n' = Nothing + | otherwise = Just $ if p 0 then 0 + else binarySearch p 0 n' + where + n' = V.length v - 1 + p = p' . (v V.!) + + +-- | 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 #-} +{-# SPECIALIZE binarySearch :: (Word -> Bool) -> Word -> Word -> Word #-} +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/Set/Util.hs b/src/Data/Set/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Util.hs @@ -0,0 +1,80 @@ +module Data.Set.Util where + +import Data.DynamicOrd +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Set.Internal as Internal + + +-- import Data.Ord(comparing) + +-- data S = S String deriving Show +-- cmpS :: S -> S -> Ordering +-- cmpS = comparing (\(S s) -> length s) + + +-- $setup +-- >>> import Data.Ord(comparing) +-- >>> data S = S String deriving Show +-- >>> cmpS = comparing (\(S s) -> length s) +-- + +-- | Given a monotonic function f that maps a to b, split the sequence s +-- depending on the b values. I.e. the result (l,m,r) is such that +-- * all (< x) . fmap f $ l +-- * all (== x) . fmap f $ m +-- * all (> x) . fmap f $ r +-- +-- running time: \(O(\log n)\) +splitOn :: Ord b => (a -> b) -> b -> Set a -> (Set a, Set a, Set a) +splitOn f x s = let (l,s') = Set.spanAntitone (g LT . f) s + (m,r) = Set.spanAntitone (g EQ . f) s' + g c y = y `compare` x == c + in (l,m,r) + +-- | Constructs a Set using the given Order. +-- +-- Note that this is dangerous as the resulting set may not abide the +-- ordering expected of such sets. +-- +-- running time: \(O(n\log n)\) +fromListBy :: (a -> a -> Ordering) -> [a] -> Set a +fromListBy cmp xs = withOrd cmp (extractOrd1 . Set.fromList . map O $ xs) + +-- | Given two sets l and r, such that all elements of l occur before +-- r, join the two sets into a combined set. +-- +-- running time: \(O(\log n)\) +join :: Set a -> Set a -> Set a +join = Internal.merge + + +-- | Inserts an element into the set, assuming that the set is ordered +-- by the given order. +-- +-- >>> insertBy cmpS (S "ccc") $ fromListBy cmpS [S "a" , S "bb" , S "dddd"] +-- fromList [S "a",S "bb",S "ccc",S "dddd"] +-- +-- When trying to insert an element that equals an element already in +-- the set (according to the given comparator), this function replaces +-- the old element by the new one: +-- +-- >>> insertBy cmpS (S "cc") $ fromListBy cmpS [S "a" , S "bb" , S "dddd"] +-- fromList [S "a",S "cc",S "dddd"] +-- +-- running time: \(O(\log n)\) +insertBy :: (a -> a -> Ordering) -> a -> Set a -> Set a +insertBy cmp x s = withOrd cmp $ liftOrd1 (Set.insert $ O x) s + + +-- | Deletes an element from the set, assuming the set is ordered by +-- the given ordering. +-- +-- >>> deleteAllBy cmpS (S "bb") $ fromListBy cmpS [S "a" , S "bb" , S "dddd"] +-- fromList [S "a",S "dddd"] +-- >>> deleteAllBy cmpS (S "bb") $ fromListBy cmpS [S "a" , S "bb" , S "cc", S "dd", S "ee", S "ff", S "dddd"] +-- fromList [S "a",S "dddd"] +-- +-- running time: \(O(\log n)\) +deleteAllBy :: (a -> a -> Ordering) -> a -> Set a -> Set a +deleteAllBy cmp x s = withOrd cmp $ liftOrd1 (Set.delete $ O x) s diff --git a/src/Data/SlowSeq.hs b/src/Data/SlowSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/SlowSeq.hs @@ -0,0 +1,205 @@ +module Data.SlowSeq where + + +import Control.Lens (bimap) +-- import qualified Data.FingerTree as FT +-- import Data.FingerTree hiding (null, viewl, viewr) +import Data.FingerTree(ViewL(..),ViewR(..)) +import qualified Data.Foldable as F +import Data.Maybe +import qualified Data.Sequence as S +import qualified Data.Sequence.Util as SU + + + +-------------------------------------------------------------------------------- + +data Key a = NoKey | Key { getKey :: a } deriving (Show,Eq,Ord) + +instance Semigroup (Key a) where + k <> NoKey = k + _ <> k = k + +instance Monoid (Key a) where + mempty = NoKey + k `mappend` k' = k <> k' + +liftCmp :: (a -> a -> Ordering) -> Key a -> Key a -> Ordering +liftCmp _ NoKey NoKey = EQ +liftCmp _ NoKey (Key _) = LT +liftCmp _ (Key _) NoKey = GT +liftCmp cmp (Key x) (Key y) = x `cmp` y + + + +-- newtype Elem a = Elem { getElem :: a } deriving (Eq,Ord,Traversable,Foldable,Functor) + +-- instance Show a => Show (Elem a) where +-- show (Elem x) = "Elem " <> show x + + +newtype OrdSeq a = OrdSeq { _asSeq :: S.Seq a } + deriving (Show,Eq) + +instance Semigroup (OrdSeq a) where + (OrdSeq s) <> (OrdSeq t) = OrdSeq $ s `mappend` t + +instance Monoid (OrdSeq a) where + mempty = OrdSeq mempty + mappend = (<>) + +instance Foldable OrdSeq where + foldMap f = foldMap f . _asSeq + null = null . _asSeq + length = length . _asSeq + minimum = fromJust . lookupMin + maximum = fromJust . lookupMax + +-- instance Measured (Key a) (Elem a) where +-- measure (Elem x) = Key x + + +type Compare a = a -> a -> Ordering + +-- | Insert into a monotone OrdSeq. +-- +-- pre: the comparator maintains monotonicity +-- +-- \(O(\log^2 n)\) +insertBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +insertBy cmp x (OrdSeq s) = OrdSeq $ l `mappend` (x S.<| r) + where + (l,r) = split (\v -> cmp v x `elem` [EQ, GT]) s + + + + + + +-- | Insert into a sorted OrdSeq +-- +-- \(O(\log^2 n)\) +insert :: Ord a => a -> OrdSeq a -> OrdSeq a +insert = insertBy compare + +deleteAllBy :: Compare a -> a -> OrdSeq a -> OrdSeq a +deleteAllBy cmp x s = l <> r + where + (l,_,r) = splitBy cmp x s + + -- (l,m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s + -- (_,r) = split (\v -> liftCmp cmp v (Key x) == GT) m + + +-- | \(O(\log^2 n)\) +splitBy :: Compare a -> a -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitBy cmp x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\v -> cmp v x `elem` [EQ,GT]) s + (m',r) = split (\v -> cmp v x == GT) m + + +-- | Given a monotonic function f that maps a to b, split the sequence s +-- depending on the b values. I.e. the result (l,m,r) is such that +-- * all (< x) . fmap f $ l +-- * all (== x) . fmap f $ m +-- * all (> x) . fmap f $ r +-- +-- >>> splitOn id 3 $ fromAscList' [1..5] +-- (OrdSeq {_asSeq = fromList [Elem 1,Elem 2]},OrdSeq {_asSeq = fromList [Elem 3]},OrdSeq {_asSeq = fromList [Elem 4,Elem 5]}) +-- >>> splitOn fst 2 $ fromAscList' [(0,"-"),(1,"A"),(2,"B"),(2,"C"),(3,"D"),(4,"E")] +-- (OrdSeq {_asSeq = fromList [Elem (0,"-"),Elem (1,"A")]},OrdSeq {_asSeq = fromList [Elem (2,"B"),Elem (2,"C")]},OrdSeq {_asSeq = fromList [Elem (3,"D"),Elem (4,"E")]}) +-- +-- \(O(\log^2 n)\) +splitOn :: Ord b => (a -> b) -> b -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a) +splitOn f x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r) + where + (l, m) = split (\v -> compare (f v) x `elem` [EQ,GT]) s + (m',r) = split (\v -> compare (f v) x == GT) m + +-- | Given a monotonic predicate p, splits the sequence s into two sequences +-- (as,bs) such that all (not p) as and all p bs +-- +-- \(O(\log^2 n)\) +splitMonotonic :: (a -> Bool) -> OrdSeq a -> (OrdSeq a, OrdSeq a) +splitMonotonic p = bimap OrdSeq OrdSeq . split p . _asSeq + + +-- monotonic split for Sequences +-- +-- \(O(\log^2 n)\) +split :: (a -> Bool) -> S.Seq a -> (S.Seq a, S.Seq a) +split = SU.splitMonotone + +-- Deletes all elements from the OrdDeq +-- +-- \(O(\log^2 n)\) +deleteAll :: Ord a => a -> OrdSeq a -> OrdSeq a +deleteAll = deleteAllBy compare + + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListBy :: Compare a -> [a] -> OrdSeq a +fromListBy cmp = foldr (insertBy cmp) mempty + +-- | inserts all eleements in order +-- \(O(n\log n)\) +fromListByOrd :: Ord a => [a] -> OrdSeq a +fromListByOrd = fromListBy compare + +-- | O(n) +fromAscList' :: [a] -> OrdSeq a +fromAscList' = OrdSeq . S.fromList + + +-- | \(O(\log^2 n)\) +lookupBy :: Compare a -> a -> OrdSeq a -> Maybe a +lookupBy cmp x s = let (_,m,_) = splitBy cmp x s in listToMaybe . F.toList $ m + +memberBy :: Compare a -> a -> OrdSeq a -> Bool +memberBy cmp x = isJust . lookupBy cmp x + + +-- | Fmap, assumes the order does not change +-- \(O(n)\) +mapMonotonic :: (a -> b) -> OrdSeq a -> OrdSeq b +mapMonotonic f = fromAscList' . map f . F.toList + + +-- | Gets the first element from the sequence +-- \(O(1)\) +viewl :: OrdSeq a -> ViewL OrdSeq a +viewl = f . S.viewl . _asSeq + where + f S.EmptyL = EmptyL + f (x S.:< s) = x :< OrdSeq s + +-- Last element +-- \(O(1)\) +viewr :: OrdSeq a -> ViewR OrdSeq a +viewr = f . S.viewr . _asSeq + where + f S.EmptyR = EmptyR + f (s S.:> x) = OrdSeq s :> x + + +-- \(O(1)\) +minView :: OrdSeq a -> Maybe (a, OrdSeq a) +minView s = case viewl s of + EmptyL -> Nothing + (x :< t) -> Just (x,t) + +-- \(O(1)\) +lookupMin :: OrdSeq a -> Maybe a +lookupMin = fmap fst . minView + +-- \(O(1)\) +maxView :: OrdSeq a -> Maybe (a, OrdSeq a) +maxView s = case viewr s of + EmptyR -> Nothing + (t :> x) -> Just (x,t) + +-- \(O(1)\) +lookupMax :: OrdSeq a -> Maybe a +lookupMax = fmap fst . maxView diff --git a/src/Data/Tree/Util.hs b/src/Data/Tree/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Util.hs @@ -0,0 +1,154 @@ +module Data.Tree.Util where + +import Data.Maybe(listToMaybe,maybeToList) +import Control.Lens +import Control.Monad((>=>)) +import Data.Tree +import qualified Data.List as List + +-------------------------------------------------------------------------------- + +-- $setup +-- >>> :{ +-- let myTree = Node 0 [ Node 1 [] +-- , Node 2 [] +-- , Node 3 [ Node 4 [] ] +-- ] +-- :} + +-------------------------------------------------------------------------------- +-- * Zipper on rose trees + +-- | Zipper for rose trees +data Zipper a = Zipper { focus :: Tree a + , ancestors :: [([Tree a], a, [Tree a])] -- left siblings in reverse order + } + deriving (Show,Eq) + +-- | Create a new zipper focussiong on the root. +root :: Tree a -> Zipper a +root = flip Zipper [] + +-- | Move the focus to the parent of this node. +up :: Zipper a -> Maybe (Zipper a) +up (Zipper t as) = case as of + [] -> Nothing + ((ls,p,rs):as') -> Just $ Zipper (Node p (reverse ls <> [t] <> rs)) as' + +-- | Move the focus to the first child of this node. +-- +-- >>> firstChild $ root myTree +-- Just (Zipper {focus = Node {rootLabel = 1, subForest = []}, ancestors = [([],0,[Node {rootLabel = 2, subForest = []},Node {rootLabel = 3, subForest = [Node {rootLabel = 4, subForest = []}]}])]}) +firstChild :: Zipper a -> Maybe (Zipper a) +firstChild (Zipper (Node x chs) as) = case chs of + [] -> Nothing + (c:chs') -> Just $ Zipper c (([],x,chs'):as) + +-- | Move the focus to the next sibling of this node +-- +-- >>> (firstChild $ root myTree) >>= nextSibling +-- Just (Zipper {focus = Node {rootLabel = 2, subForest = []}, ancestors = [([Node {rootLabel = 1, subForest = []}],0,[Node {rootLabel = 3, subForest = [Node {rootLabel = 4, subForest = []}]}])]}) +nextSibling :: Zipper a -> Maybe (Zipper a) +nextSibling (Zipper t as) = case as of + [] -> Nothing -- no parent + ((_,_,[]):_) -> Nothing -- no next sibling + ((ls,p,(r:rs)):as') -> Just $ Zipper r ((t:ls,p,rs):as') + +-- | Move the focus to the next sibling of this node +prevSibling :: Zipper a -> Maybe (Zipper a) +prevSibling (Zipper t as) = case as of + [] -> Nothing -- no parent + (([],_,_):_) -> Nothing -- no prev sibling + (((l:ls),p,rs):as') -> Just $ Zipper l ((ls,p,t:rs):as') + +-- | Given a zipper that focussses on some subtree t, construct a list with +-- zippers that focus on each child. +allChildren :: Zipper a -> [Zipper a] +allChildren = List.unfoldr ((\ch -> (ch, nextSibling ch)) <$>) . firstChild + +-- | Given a zipper that focussses on some subtree t, construct a list with +-- zippers that focus on each of the nodes in the subtree of t. +allTrees :: Zipper a -> [Zipper a] +allTrees r = r : concatMap allTrees (allChildren r) + +-- | Creates a new tree from the zipper that thas the current node as root. The +-- ancestorTree (if there is any) forms the first child in this new root. +unZipperLocal :: Zipper a -> Tree a +unZipperLocal (Zipper (Node x chs) as) = Node x (maybeToList (constructTree as) <> chs) + +-- | Constructs a tree from the list of ancestors (if there are any) +constructTree :: [([Tree a],a,[Tree a])] -> Maybe (Tree a) +constructTree = listToMaybe + . foldr (\(ls,p,rs) tas -> [Node p (tas <> reverse ls <> rs)]) [] + + +-------------------------------------------------------------------------------- + +-- | Given a predicate on an element, find a node that matches the predicate, and turn that +-- node into the root of the tree. +-- +-- running time: \(O(nT)\) where \(n\) is the size of the tree, and \(T\) is +-- the time to evaluate a predicate. +-- +-- >>> findEvert (== 4) myTree +-- Just (Node {rootLabel = 4, subForest = [Node {rootLabel = 3, subForest = [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = []},Node {rootLabel = 2, subForest = []}]}]}]}) +-- >>> findEvert (== 5) myTree +-- Nothing +findEvert :: (a -> Bool) -> Tree a -> Maybe (Tree a) +findEvert p = findEvert' (p . rootLabel) + +-- | Given a predicate matching on a subtree, find a node that matches the predicate, and turn that +-- node into the root of the tree. +-- +-- running time: \(O(nT(n))\) where \(n\) is the size of the tree, and \(T(m)\) is +-- the time to evaluate a predicate on a subtree of size \(m\). +findEvert' :: (Tree a -> Bool) -> Tree a -> Maybe (Tree a) +findEvert' p = fmap unZipperLocal . listToMaybe . filter (p . focus) . allTrees . root + +-- | Function to extract a path between a start node and an end node (if such a +--path exists). If there are multiple paths, no guarantees are given about +--which one is returned. +-- +-- running time: \(O(n(T_p+T_s)\), where \(n\) is the size of the tree, and +-- \(T_p\) and \(T_s\) are the times it takes to evaluate the 'isStartingNode' +-- and 'isEndingNode' predicates. +-- +-- +-- >>> findPath (== 1) (==4) myTree +-- Just [1,0,3,4] +-- >>> findPath (== 1) (==2) myTree +-- Just [1,0,2] +-- >>> findPath (== 1) (==1) myTree +-- Just [1] +-- >>> findPath (== 1) (==2) myTree +-- Just [1,0,2] +-- >>> findPath (== 4) (==2) myTree +-- Just [4,3,0,2] +findPath :: (a -> Bool) -- ^ is this node a starting node + -> (a -> Bool) -- ^ is this node an ending node + -> Tree a -> Maybe [a] +findPath isStart isEnd = findEvert isStart >=> findNode isEnd + +-- | Given a predicate on a, find (the path to) a node that satisfies the predicate. +-- +-- >>> findNode (== 4) myTree +-- Just [0,3,4] +findNode :: (a -> Bool) -> Tree a -> Maybe [a] +findNode p = listToMaybe . findNodes (p . rootLabel) + +-- | Find all paths to nodes that satisfy the predicate +-- +-- running time: \(O(nT(n))\) where \(n\) is the size of the tree, and \(T(m)\) is +-- the time to evaluate a predicate on a subtree of size \(m\). +-- +-- >>> findNodes ((< 4) . rootLabel) myTree +-- [[0],[0,1],[0,2],[0,3]] +-- >>> findNodes (even . rootLabel) myTree +-- [[0],[0,2],[0,3,4]] +-- >>> let size = length in findNodes ((> 1) . size) myTree +-- [[0],[0,3]] +findNodes :: (Tree a -> Bool) -> Tree a -> [[a]] +findNodes p = go + where + go t = let mh = if p t then [[]] else [] + in map (rootLabel t:) $ mh <> concatMap go (children t) 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,127 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.UnBounded( Top, topToMaybe + , pattern ValT, pattern Top + + , Bottom, bottomToMaybe + , pattern Bottom, pattern ValB + + , UnBounded(..) + , unUnBounded + , unBoundedToMaybe + ) where + +import Control.Lens +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.Functor.Classes + +-------------------------------------------------------------------------------- +-- * 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,Eq1) + +pattern ValT :: a -> Top a +pattern ValT x = GTop (Just x) + +pattern Top :: Top a +pattern Top = GTop Nothing + +{-# COMPLETE ValT, Top #-} + + +instance Ord1 Top where + liftCompare _ Top Top = EQ + liftCompare _ _ Top = LT + liftCompare _ Top _ = GT + liftCompare cmp ~(ValT x) ~(ValT y) = x `cmp` y + +instance Ord a => Ord (Top a) where + compare = compare1 + +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 = Bottom | ValB a +newtype Bottom a = GBottom { bottomToMaybe :: Maybe a } + deriving (Eq,Ord,Functor,F.Foldable,T.Traversable,Applicative,Monad,Eq1,Ord1) + +pattern Bottom :: Bottom a +pattern Bottom = GBottom Nothing + +pattern ValB :: a -> Bottom a +pattern ValB x = GBottom (Just x) + +{-# COMPLETE Bottom, ValB #-} + +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/src/Data/Util.hs b/src/Data/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Util.hs @@ -0,0 +1,96 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Util +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Some basic types, mostly strict triples and pairs. +-- +-------------------------------------------------------------------------------- +module Data.Util where + +import Control.DeepSeq +import Control.Lens +import GHC.Generics (Generic) +import qualified Data.List as List + +-------------------------------------------------------------------------------- +-- * Strict Triples + +-- | strict triple +data STR a b c = STR { fst' :: !a, snd' :: !b , trd' :: !c} + deriving (Show,Eq,Ord,Functor,Generic) + +instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (STR a b c) where + (STR a b c) <> (STR d e f) = STR (a <> d) (b <> e) (c <> f) + +instance (Semigroup a, Semigroup b, Semigroup c + , Monoid a, Monoid b, Monoid c) => Monoid (STR a b c) where + mempty = STR mempty mempty mempty + mappend = (<>) + +instance (NFData a, NFData b, NFData c) => NFData (STR a b c) + +instance Field1 (STR a b c) (STR d b c) a d where + _1 = lens fst' (\(STR _ b c) d -> STR d b c) + +instance Field2 (STR a b c) (STR a d c) b d where + _2 = lens snd' (\(STR a _ c) d -> STR a d c) + +instance Field3 (STR a b c) (STR a b d) c d where + _3 = lens trd' (\(STR a b _) d -> STR a b d) + +-- | Generate All unique unordered triplets. +-- +uniqueTriplets :: [a] -> [STR a a a] +uniqueTriplets xs = [ STR x y z | (x:ys) <- nonEmptyTails xs, SP y z <- uniquePairs ys] + + +-------------------------------------------------------------------------------- +-- * Strict Pairs + + +-- | Strict pair +data SP a b = SP !a !b deriving (Show,Eq,Ord,Functor,Generic) + +instance (Semigroup a, Semigroup b) => Semigroup (SP a b) where + (SP a b) <> (SP c d) = SP (a <> c) (b <> d) + +instance (Semigroup a, Semigroup b, Monoid a, Monoid b) => Monoid (SP a b) where + mempty = SP mempty mempty + mappend = (<>) + +instance (NFData a, NFData b) => NFData (SP a b) + + +instance Field1 (SP a b) (SP c b) a c where + _1 = lens (\(SP a _) -> a) (\(SP _ b) c -> SP c b) + +instance Field2 (SP a b) (SP a c) b c where + _2 = lens (\(SP _ b) -> b) (\(SP a _) c -> SP a c) + +instance Bifunctor SP where + bimap f g (SP a b) = SP (f a) (g b) + +-------------------------------------------------------------------------------- +-- | * Strict pair whose elements are of the same type. + +-- | Strict pair with both items the same +type Two a = SP a a + +pattern Two :: a -> a -> Two a +pattern Two a b = SP a b +{-# COMPLETE Two #-} + +-- | Given a list xs, generate all unique (unordered) pairs. +-- +-- +uniquePairs :: [a] -> [Two a] +uniquePairs xs = [ Two x y | (x:ys) <- nonEmptyTails xs, y <- ys ] + +-------------------------------------------------------------------------------- + +-- | A version of List.tails in which we remove the emptylist +nonEmptyTails :: [a] -> [[a]] +nonEmptyTails = List.init . List.tails diff --git a/src/Data/Yaml/Util.hs b/src/Data/Yaml/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Util.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Yaml.Util +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- Description : Helper functions for working with yaml +-- +-------------------------------------------------------------------------------- +module Data.Yaml.Util( encodeYaml, encodeYamlFile + , decodeYaml, decodeYamlFile + , printYaml + , parseVersioned + , Versioned(Versioned), unversioned + ) where + +import Control.Applicative +import Data.Aeson +import Data.Aeson.Types (typeMismatch) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import Data.Version +import Data.Yaml +import qualified Data.Yaml.Pretty as YamlP +import GHC.Generics (Generic) +import Text.ParserCombinators.ReadP (readP_to_S) + +-------------------------------------------------------------------------------- + +-- | Write the output to yaml +encodeYaml :: ToJSON a => a -> ByteString +encodeYaml = YamlP.encodePretty YamlP.defConfig + +-- | Prints the yaml +printYaml :: ToJSON a => a -> IO () +printYaml = B.putStrLn . encodeYaml + +-- | alias for decodeEither' from the Yaml Package +decodeYaml :: FromJSON a => ByteString -> Either ParseException a +decodeYaml = decodeEither' + +-- | alias for reading a yaml file +decodeYamlFile :: FromJSON a => FilePath -> IO (Either ParseException a) +decodeYamlFile = decodeFileEither + +-- | Encode a yaml file +encodeYamlFile :: ToJSON a => FilePath -> a -> IO () +encodeYamlFile fp = B.writeFile fp . encodeYaml + + +-- | Data type for things that have a version +data Versioned a = Versioned { version :: Version + , content :: a + } deriving (Show,Read,Generic,Eq,Functor,Foldable,Traversable) + +unversioned :: Versioned a -> a +unversioned = content + +instance ToJSON a => ToJSON (Versioned a) where + toJSON (Versioned v x) = object [ "version" .= showVersion v, "content" .= x] + toEncoding (Versioned v x) = pairs ("version" .= showVersion v <> "content" .= x) + + +-- | Given a list of candidate parsers, select the right one +parseVersioned :: [(Version -> Bool,Value -> Parser a)] + -> Value -> Parser (Versioned a) +parseVersioned ps (Object o) = do V v <- o .: "version" + co <- o .: "content" + let ps' = map (\(_,p) -> Versioned v <$> p co) + . filter (($ v) . fst) $ ps + err = fail $ "no matching version found for version " + <> showVersion v + foldr (<|>) err ps' +parseVersioned _ invalid = typeMismatch "Versioned" invalid + +-- instance (FromJSON a) => FromJSON (Versioned a) where +-- parseJSON (Object v) = Versioned <$> (unV <$> v .: "version") +-- <*> v .: "content" +-- parseJSON invalid = typeMismatch "Versioned" invalid + +newtype V = V Version + +instance FromJSON V where + parseJSON (String t) = case filter (null . snd) (readP_to_S parseVersion $ T.unpack t) of + ((v,""):_) -> pure $ V v + _ -> fail $ "parsing " <> show t <> " into a version failed" + parseJSON invalid = typeMismatch "Version" invalid diff --git a/src/System/Random/Shuffle.hs b/src/System/Random/Shuffle.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/Shuffle.hs @@ -0,0 +1,36 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : System.Random.Shuffle +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Implements Fishyer-Yates shuffle. +-- +-------------------------------------------------------------------------------- +module System.Random.Shuffle(shuffle) where + +import Control.Monad +import Control.Monad.Random.Class +import qualified Data.Foldable as F +import Data.Util +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV + +-------------------------------------------------------------------------------- + +-- | Fisher–Yates shuffle, which shuffles a list/foldable uniformly at random. +-- +-- running time: \(O(n)\). +shuffle :: (Foldable f, MonadRandom m) => f a -> m (V.Vector a) +shuffle = withLength . V.fromList . F.toList + where + withLength v = let n = V.length v in flip withRands v <$> rands (n - 1) + withRands rs = V.modify $ \v -> + forM_ rs $ \(SP i j) -> MV.swap v i j + + +-- | Generate a list of indices in decreasing order, coupled with a random +-- value in the range [0,i]. +rands :: MonadRandom m => Int -> m [SP Int Int] +rands n = mapM (\i -> SP i <$> getRandomR (0,i)) [n,(n-1)..1] diff --git a/test/Algorithms/StringSearch/KMPSpec.hs b/test/Algorithms/StringSearch/KMPSpec.hs new file mode 100644 --- /dev/null +++ b/test/Algorithms/StringSearch/KMPSpec.hs @@ -0,0 +1,27 @@ +module Algorithms.StringSearch.KMPSpec where + +import Algorithms.StringSearch.KMP +import qualified Data.Foldable as F +import qualified Data.List as List +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as UV +import Test.QuickCheck.Instances () +import Test.Hspec +import Test.QuickCheck + +-------------------------------------------------------------------------------- + +patternFound :: String -> String -> Maybe Int -> Bool +patternFound p t = \case + Nothing -> True + Just i -> List.isPrefixOf p . List.drop i $ t + +spec :: Spec +spec = do + describe "KMP tests" $ do + it "failure-function manual example" $ + buildFailureFunction (V.fromList "abacab") + `shouldBe` (UV.fromList [0,0,1,0,1,2]) + it "manual example" $ + [4,1,2,3] `isSubStringOf` [1,4,5,4,1,2,3,6] + `shouldBe` (Just 3) diff --git a/test/Data/CircularSeqSpec.hs b/test/Data/CircularSeqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/CircularSeqSpec.hs @@ -0,0 +1,53 @@ +module Data.CircularSeqSpec where + +import Data.CircularSeq +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances() +import Data.List.NonEmpty(NonEmpty) + +spec :: Spec +spec = do + describe "CircularCeq tests" $ do + it "isShiftOf" $ do + let c1 :: CSeq Int + c1 = fromList [1, 2, 1, 3] + c2 = rotateNL 2 c1 + (c1 `isShiftOf` c2) `shouldBe` True + (c2 `isShiftOf` c1) `shouldBe` True + it "is not a shift of " $ do + let c1 :: CSeq Int + c1 = fromList [1, 2, 3, 4] + c2 = fromList [3, 2] + (c1 `isShiftOf` c2) `shouldBe` False + (c2 `isShiftOf` c1) `shouldBe` False + it "multiple copies is not a shift" $ do + let c1 = fromList [1] + c2 = fromList [1,1] + c3 = fromList [1,1,1] + (c1 `isShiftOf` c2) `shouldBe` False + (c2 `isShiftOf` c1) `shouldBe` False + (c1 `isShiftOf` c3) `shouldBe` False + (c3 `isShiftOf` c1) `shouldBe` False + it "cyclic shift tests" $ + property $ \(xs :: NonEmpty Int) i -> do + let cs = fromNonEmpty xs + cs' = rotateNR i cs + (cs `isShiftOf` cs') `shouldBe` True + (cs `isShiftOf` cs') `shouldBe` (isShiftOfNaive cs cs') + -- property $ \(xs :: NonEmpty Int) i -> + -- let cs = fromNonEmpty xs + -- cs' = rotateNR i cs + -- in + + + + -- it "cyclic shift is symmetric" $ + -- property $ \(xs :: NonEmpty Int) i -> + -- let cs = fromNonEmpty xs + -- cs' = rotateNR i cs + -- in (cs `isShiftOf` cs') `shouldBe` (cs' `isShiftOf` cs) + + +isShiftOfNaive :: Eq a => CSeq a -> CSeq a -> Bool +isShiftOfNaive xs ys = xs `elem` allRotations ys diff --git a/test/Data/EdgeOracleSpec.hs b/test/Data/EdgeOracleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/EdgeOracleSpec.hs @@ -0,0 +1,64 @@ +module Data.EdgeOracleSpec where + +import Control.Arrow +import Data.Ext +import Data.PlanarGraph.EdgeOracle +import Data.PlanarGraph.Core +import Data.Semigroup +import qualified Data.Set as S +import Test.Hspec + +-------------------------------------------------------------------------------- + +data TestG + +type Vertex = VertexId TestG Primal + + +testEdges :: [(Vertex,[Vertex])] +testEdges = map (\(i,vs) -> (VertexId i, map VertexId vs)) + [ (0, [1]) + , (1, [0,1,2,4]) + , (2, [1,3,4]) + , (3, [2,5]) + , (4, [1,2,5]) + , (5, [3,4]) + ] + +buildEdgeOracle' :: [(Vertex,[Vertex])] -> EdgeOracle TestG Primal () +buildEdgeOracle' = buildEdgeOracle . map (second $ fmap ext) + +-- | Flattens an adjacencylist representation into a set of edges +flattenEdges :: [(t, [a])] -> [(t, a)] +flattenEdges = concatMap (\(i,vs) -> map (i,) vs) + +-- | Given a set of edges, generates all non-edges, i.e. all pairs of vertices +-- that do not form an edge +nonEdges :: [(VertexId s w, [VertexId s w])] -> [(VertexId s w, VertexId s w)] +nonEdges es = flattenEdges . map (second $ f . S.fromList) $ es + where + f vs = filter (`S.notMember` vs) allVs + allVs = map fst es + +-- | Retains only the edges in the graph +hasEdges :: EdgeOracle s w a -> [(VertexId s w, VertexId s w)] + -> [(VertexId s w, VertexId s w)] +oracle `hasEdges` es = filter (\(u,v) -> hasEdge u v oracle) es + + +-- | Tests all edges es +edgeOracleSpec :: String -> [(Vertex, [Vertex])] -> Spec +edgeOracleSpec s es = do + let oracle = buildEdgeOracle' es + describe ("EdgeOracle on " <> s) $ do + it "test postitive edges" $ + (oracle `hasEdges` flattenEdges es) `shouldBe` flattenEdges es + it "test negative edges " $ + (oracle `hasEdges` nonEdges es) `shouldBe` [] + + -- it "test maximum adjacency-list lengths" $ + -- (filter (\v -> length v > 6) . _unEdgeOracle $ oracle) `shouldBe` [] + +spec :: Spec +spec = do + edgeOracleSpec "testEdges" testEdges diff --git a/test/Data/OrdSeqSpec.hs b/test/Data/OrdSeqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/OrdSeqSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.OrdSeqSpec where + +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.OrdSeq (OrdSeq) +import qualified Data.OrdSeq as OrdSeq +import Test.Hspec +import Test.QuickCheck + +spec :: Spec +spec = do + describe "OrdSeq tests" $ do + it "fromListBy" $ + property $ \(xs :: [Int]) -> + F.toList (OrdSeq.fromListBy compare xs) `shouldBe` List.sort xs + it "splitOn, <" $ + property $ \x (xs :: OrdSeq Int) -> + let (l,_,_) = OrdSeq.splitOn id x xs + in all (< x) l + it "splitOn, ==" $ + property $ \x (xs :: OrdSeq Int) -> + let (_,m,_) = OrdSeq.splitOn id x xs + in all (== x) m + it "splitOn, >=" $ + property $ \x (xs :: OrdSeq Int) -> + let (_,_,r) = OrdSeq.splitOn id x xs + in all (> x) r + it "join" $ + property $ \x (xs :: [Int]) -> let (ys,zs) = List.partition (<= x) $ xs in + (F.toList $ OrdSeq.fromListByOrd ys <> OrdSeq.fromListByOrd zs) + `shouldBe` + List.sort (ys <> zs) + it "positive member" $ + property $ \(xs :: OrdSeq Int) -> + all (\x -> OrdSeq.memberBy compare x xs) xs + it "member" $ + property $ \x (xs :: OrdSeq Int) -> + OrdSeq.memberBy compare x xs + `shouldBe` + F.elem x (F.toList xs) + it "lookupMin" $ + property $ \(xs :: OrdSeq Int) -> + OrdSeq.lookupMin xs + `shouldBe` + (safe minimum $ F.toList xs) + it "lookupMax" $ + property $ \(xs :: OrdSeq Int) -> + OrdSeq.lookupMax xs + `shouldBe` + (safe maximum $ F.toList xs) + + +safe :: ([t] -> a) -> [t] -> Maybe a +safe _ [] = Nothing +safe f xs = Just . f $ xs diff --git a/test/Data/PlanarGraph/myGraph.yaml b/test/Data/PlanarGraph/myGraph.yaml new file mode 100644 --- /dev/null +++ b/test/Data/PlanarGraph/myGraph.yaml @@ -0,0 +1,60 @@ +faces: +- incidentEdge: + - 0 + - 1 + fData: [] +- incidentEdge: + - 1 + - 4 + fData: [] +- incidentEdge: + - 2 + - 4 + fData: [] +ajacencies: +- adj: + - - 1 + - [] + id: 0 + vData: [] +- adj: + - - 0 + - [] + - - 2 + - [] + - - 4 + - [] + id: 1 + vData: [] +- adj: + - - 1 + - [] + - - 3 + - [] + - - 4 + - [] + id: 2 + vData: [] +- adj: + - - 2 + - [] + - - 5 + - [] + id: 3 + vData: [] +- adj: + - - 1 + - [] + - - 2 + - [] + - - 5 + - [] + id: 4 + vData: [] +- adj: + - - 3 + - [] + - - 4 + - [] + id: 5 + vData: [] diff --git a/test/Data/PlanarGraphSpec.hs b/test/Data/PlanarGraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/PlanarGraphSpec.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.PlanarGraphSpec where + + +import Data.Bifunctor +import qualified Data.ByteString.Char8 as B +import qualified Data.Foldable as F +import qualified Data.Map.Strict as SM +import Data.Permutation (toCycleRep) +import Data.PlanarGraph +import qualified Data.PlanarGraph as PlanarGraph +import Data.PlanarGraph.IO +import qualified Data.Set as S +import Data.Util +import qualified Data.Vector as V +import Data.Yaml (prettyPrintParseException) +import Data.Yaml.Util +import Test.Hspec +import Test.QuickCheck + +-------------------------------------------------------------------------------- +data TestG + +type Vertex = VertexId TestG Primal + +-- | Report all adjacnecies from g missing in h +missingAdjacencies :: PlanarGraph s w v e f -> PlanarGraph s w v e f + -> [(VertexId s w, VertexId s w)] +missingAdjacencies g h = concatMap f . vertices' $ g + where + f u = let adjUh = S.fromList . F.toList $ neighboursOf u h + in F.toList . fmap (u,) . V.filter (`S.notMember` adjUh) $ neighboursOf u g + + +sameGraphs s g h = do + describe ("Same Adjacencies " <> s) $ do + it "Missing edges from g in h" $ + (missingAdjacencies g h) `shouldBe` [] + it "Missing edges from h in g" $ + (missingAdjacencies h g) `shouldBe` [] + +spec :: Spec +spec = do + describe "PlanarGraph spec" $ do + sameGraphs "testEdges" (fromAdjacencyLists testEdges) (fromAdjacencyListsOld testEdges) + it "quickheck Dart: (toEnum (fromEnum d)) = d" $ + property $ \(d :: Dart TestG) -> toEnum (fromEnum d) `shouldBe` d + it "quickheck Dart: fromEnum (toEnum i) = i" $ + property $ \(NonNegative i) -> fromEnum ((toEnum i) :: Dart TestG) `shouldBe` i + it "encode yaml test" $ do + b <- B.readFile "test/Data/PlanarGraph/myGraph.yaml" + encodeYaml (fromAdjacencyLists testEdges) `shouldBe` b + it "decode yaml test" $ do + (first prettyPrintParseException <$> decodeYamlFile "test/Data/PlanarGraph/myGraph.yaml") + `shouldReturn` + (Right $ fromAdjacencyLists testEdges) + + +testEdges :: [(Vertex,[Vertex])] +testEdges = map (\(i,vs) -> (VertexId i, map VertexId vs)) + [ (0, [1]) + , (1, [0,2,4]) + , (2, [1,3,4]) + , (3, [2,5]) + , (4, [1,2,5]) + , (5, [3,4]) + ] + +-- testGraph = fromAdjacencyLists testEdges + +-- enccode = let g = +-- in encodeYamlFile + +-------------------------------------------------------------------------------- + + +-- - 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 STR' s b = STR (SM.Map (VertexId s Primal,VertexId s Primal) Int) Int b + +-- | Construct a planar graph from a adjacency matrix. For every vertex, all +-- vertices should be given in counter clockwise order. +-- +-- running time: $O(n \log n)$. +fromAdjacencyListsOld :: forall s f.(Foldable f, Functor f) + => [(VertexId s Primal, f (VertexId s Primal))] + -> PlanarGraph s Primal () () () +fromAdjacencyListsOld adjM = planarGraph' . toCycleRep n $ perm + where + n = sum . fmap length $ perm + perm = trd' . foldr toOrbit (STR mempty 0 mempty) $ adjM + + + -- | Given a vertex with its adjacent vertices (u,vs) (in CCW order) convert this + -- vertex with its adjacent vertices into an Orbit + toOrbit :: Foldable f + => (VertexId s Primal, f (VertexId s Primal)) + -> STR' s [[Dart s]] + -> STR' s [[Dart s]] + toOrbit (u,vs) (STR m a dss) = + let (STR m' a' ds') = foldr (toDart . (u,)) (STR m a mempty) . F.toList $ vs + in STR 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 s Primal,VertexId s Primal) + -> STR' s [Dart s] + -> STR' s [Dart s] + toDart (u,v) (STR m a ds) = let dir = if u < v then PlanarGraph.Positive else PlanarGraph.Negative + t' = (min u v, max u v) + in case SM.lookup t' m of + Just a' -> STR m a (Dart (Arc a') dir : ds) + Nothing -> STR (SM.insert t' a m) (a+1) (Dart (Arc a) dir : ds) 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,47 @@ +module Data.RangeSpec where + +import Data.Intersection +import Data.Range +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 :: Int)) `intersect` (OpenRange 10 (12 :: Int))) + `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 :: Int)) `intersect` (ClosedRange 10 (12 :: Int))) + -- `shouldBe` (coRec NoIntersection) + + -- it "open rage intersect closed " $ do + -- ((OpenRange 1 (10 :: Int)) `intersect` (ClosedRange 10 (12 :: Int))) + -- `shouldBe` (coRec $ Range (Open 10) (Open (10 :: Int))) + -- (Col Range {_lower = Closed 10, _upper = Open 10}) + -- >>> (OpenRange 1 10) `intersect` (ClosedRange 10 12) + + + -- 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 #-}