hgeometry-combinatorial (empty) → 0.9.0.0

raw patch · 47 files changed

+5528/−0 lines, 47 filesdep +MonadRandomdep +QuickCheckdep +aesonsetup-changedbinary-added

Dependencies added: MonadRandom, QuickCheck, aeson, approximate-equality, base, bifunctors, bytestring, containers, contravariant, data-clist, deepseq, directory, dlist, doctest, filepath, fingertree, hgeometry-combinatorial, hspec, lens, linear, mtl, quickcheck-instances, random, reflection, semigroupoids, semigroups, singletons, template-haskell, text, vector, vector-builder, vinyl, yaml

Files

• LICENSE +30/−0
• README.md +4/−0
• Setup.hs +2/−0
• changelog.org +0/−0
• docs/Data/PlanarGraph/testG.png binary
• docs/Data/PlaneGraph/planegraph.png binary
• doctests.hs +66/−0
• hgeometry-combinatorial.cabal +235/−0
• src/Algorithms/Graph/DFS.hs +53/−0
• src/Algorithms/Graph/MST.hs +152/−0
• src/Algorithms/StringSearch/KMP.hs +67/−0
• src/Control/Monad/State/Persistent.hs +48/−0
• src/Data/BalBST.hs +378/−0
• src/Data/BinaryTree.hs +222/−0
• src/Data/BinaryTree/Zipper.hs +64/−0
• src/Data/CircularList/Util.hs +67/−0
• src/Data/CircularSeq.hs +384/−0
• src/Data/DynamicOrd.hs +73/−0
• src/Data/Ext.hs +90/−0
• src/Data/Intersection.hs +71/−0
• src/Data/LSeq.hs +314/−0
• src/Data/OrdSeq.hs +193/−0
• src/Data/Permutation.hs +124/−0
• src/Data/PlanarGraph.hs +157/−0
• src/Data/PlanarGraph/AdjRep.hs +63/−0
• src/Data/PlanarGraph/Core.hs +540/−0
• src/Data/PlanarGraph/Dart.hs +103/−0
• src/Data/PlanarGraph/Dual.hs +145/−0
• src/Data/PlanarGraph/EdgeOracle.hs +157/−0
• src/Data/PlanarGraph/IO.hs +156/−0
• src/Data/Range.hs +283/−0
• src/Data/Sequence/Util.hs +76/−0
• src/Data/Set/Util.hs +80/−0
• src/Data/SlowSeq.hs +205/−0
• src/Data/Tree/Util.hs +154/−0
• src/Data/UnBounded.hs +127/−0
• src/Data/Util.hs +96/−0
• src/Data/Yaml/Util.hs +89/−0
• src/System/Random/Shuffle.hs +36/−0
• test/Algorithms/StringSearch/KMPSpec.hs +27/−0
• test/Data/CircularSeqSpec.hs +53/−0
• test/Data/EdgeOracleSpec.hs +64/−0
• test/Data/OrdSeqSpec.hs +56/−0
• test/Data/PlanarGraph/myGraph.yaml +60/−0
• test/Data/PlanarGraphSpec.hs +116/−0
• test/Data/RangeSpec.hs +47/−0
• test/Spec.hs +1/−0

@@ -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.

@@ -0,0 +1,4 @@+HGeometry-combinatorial+=======================++The combinatorial types for the [HGeometry](https://hackage.haskell.org/package/hgeometry) package.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

binary file changed (absent → 38819 bytes)

binary file changed (absent → 108198 bytes)

@@ -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"+  ]

@@ -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

@@ -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)

@@ -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..]

@@ -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

@@ -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

@@ -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

@@ -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'

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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 :+ ()

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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..]+++++++--------------------------------------------------------------------------------

@@ -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)+++--------------------------------------------------------------------------------

@@ -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

@@ -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..]

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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: []

@@ -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)

@@ -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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}