partialord 0.0.3 → 0.1.0
raw patch · 3 files changed
+134/−24 lines, 3 files
Files
- README.md +2/−1
- partialord.cabal +1/−1
- src/Data/PartialOrd.hs +131/−22
README.md view
@@ -9,6 +9,7 @@ [partial-order](https://hackage.haskell.org/package/partial-order). Differences include: * PartialOrd has a comparison valued in Maybe Ordering; we use a fresh- type.+ type with four constructors. * Where types have several natural partial orderings, we provide newtypes rather than choosing one.+* We pay slightly more attention to algorithmic complexity.
partialord.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: partialord-version: 0.0.3+version: 0.1.0 synopsis: Data structure supporting partial orders description: Please see README.md category: Data structures
src/Data/PartialOrd.hs view
@@ -12,6 +12,10 @@ toMaybeOrd, fromMaybeOrd, fromLeqGeq,+ fromCompare,+ isLeq,+ isGeq,+ reversePartial, -- * Partial orderings PartialOrd(..), comparable,@@ -28,15 +32,24 @@ Prefix(..), Suffix(..), Subseq(..),+ -- * Partial orders on Either+ Join(..),+ Disjoint(..),+ -- * Partial orders on Map+ PointwisePositive(..), ) where import Data.IntSet (IntSet) import qualified Data.IntSet as IS import Data.List (isInfixOf, isPrefixOf, isSuffixOf, isSubsequenceOf)+import qualified Data.Map.Strict as M+import Data.Map.Internal (Map(..)) import Data.Monoid ()+import Data.Ord (Down(..)) import Data.Semigroup () import Data.Set (Set) import qualified Data.Set as S+import Data.Void (Void, absurd) -- | A data type representing relationships between two objects in a@@ -51,6 +64,10 @@ fromOrd LT = LT' fromOrd GT = GT' +-- | Lift a `compare` to a `compare'`+fromCompare :: Ord a => a -> a -> PartialOrdering+fromCompare x y = fromOrd $ compare x y+ -- | Convert a partial ordering to an ordering toMaybeOrd :: PartialOrdering -> Maybe Ordering toMaybeOrd EQ' = Just EQ@@ -72,7 +89,45 @@ fromLeqGeq False True = GT' fromLeqGeq False False = NT' +isLeq :: PartialOrdering -> Bool+isLeq EQ' = True+isLeq LT' = True+isLeq _ = False +isGeq :: PartialOrdering -> Bool+isGeq EQ' = True+isGeq GT' = True+isGeq _ = False++reversePartial :: PartialOrdering -> PartialOrdering+reversePartial EQ' = EQ'+reversePartial LT' = GT'+reversePartial GT' = LT'+reversePartial NT' = NT'+++-- | A typeclass expressing partially ordered types: any two elements+-- are related by a `PartialOrdering`.+--+-- In some cases `leq` can be quicker to run than `compare`. The+-- provided implementations such as `PartialOrd (a,b)` take advantage+-- of this.+class PartialOrd a where+ {-# MINIMAL compare' | leq #-}++ compare' :: a -> a -> PartialOrdering+ compare' a b = fromLeqGeq (a `leq` b) (a `geq` b)++ leq :: a -> a -> Bool+ a `leq` b = case compare' a b of+ LT' -> True+ EQ' -> True+ _ -> False++ geq :: a -> a -> Bool+ a `geq` b = b `leq` a++ -- | A helper type for constructing partial orderings from total -- orderings (using deriving via) newtype FullyOrd a = FullyOrd {@@ -109,23 +164,7 @@ instance Monoid PartialOrdering where mempty = EQ' --- | A typeclass expressing partially ordered types: any two elements--- are related by a `PartialOrdering`.-class PartialOrd a where- {-# MINIMAL compare' | leq #-} - compare' :: a -> a -> PartialOrdering- compare' a b = fromLeqGeq (a `leq` b) (a `geq` b)-- leq :: a -> a -> Bool- a `leq` b = case compare' a b of- LT' -> True- EQ' -> True- _ -> False-- geq :: a -> a -> Bool- a `geq` b = b `leq` a- -- | Are they LT', EQ', GT' comparable :: PartialOrd a => a -> a -> Bool comparable a b = case compare' a b of@@ -142,12 +181,16 @@ instance PartialOrd () where compare' _ _ = EQ' +instance PartialOrd Void where+ compare' = absurd++ -- | This is equivalent to -- -- > compare' (a,b) (c,d) = compare' a c <> compare' b d ----- but may be more efficient: if compare' a1 a2 is LT' or GT' we seek less--- information about b1 and b2 (and this can be faster).+-- but may be more efficient: if compare' a c is LT' or GT' we need less+-- information about b and d. instance (PartialOrd a, PartialOrd b) => PartialOrd (a,b) where compare' (a1,b1) (a2,b2) = case compare' a1 a2 of NT' -> NT'@@ -169,6 +212,31 @@ (a1,b1,c1,d1,e1) `leq` (a2,b2,c2,d2,e2) = a1 `leq` a2 && b1 `leq` b2 && c1 `leq` c2 && d1 `leq` d2 && e1 `leq` e2 ++-- | All elements on the left are less than all those on the right+newtype Join a b = Join {+ getJoin :: Either a b+}++instance (PartialOrd a, PartialOrd b) => PartialOrd (Join a b) where+ compare' (Join (Left _)) (Join (Right _)) = LT'+ compare' (Join (Right _)) (Join (Left _)) = GT'+ compare' (Join (Left x)) (Join (Left y)) = compare' x y+ compare' (Join (Right x)) (Join (Right y)) = compare' x y++-- | All elements on the left are incomparable with all those on the right+newtype Disjoint a b = Disjoint {+ getDisjoint :: Either a b+}++instance (PartialOrd a, PartialOrd b) => PartialOrd (Disjoint a b) where+ compare' (Disjoint (Left _)) (Disjoint (Right _)) = NT'+ compare' (Disjoint (Right _)) (Disjoint (Left _)) = NT'+ compare' (Disjoint (Left x)) (Disjoint (Left y)) = compare' x y+ compare' (Disjoint (Right x)) (Disjoint (Right y)) = compare' x y+++-- | Sets, with the subset partial order instance Ord a => PartialOrd (Set a) where leq = S.isSubsetOf @@ -177,6 +245,7 @@ GT -> if S.isSubsetOf v u then GT' else NT' EQ -> if u == v then EQ' else NT' +-- | Sets of integers, with the subset partial order instance PartialOrd IntSet where leq = IS.isSubsetOf @@ -194,6 +263,7 @@ instance Eq a => PartialOrd (Infix a) where Infix a `leq` Infix b = isInfixOf a b + -- | Lists partially ordered by prefix inclusion newtype Prefix a = Prefix { unPrefix :: [a]@@ -252,8 +322,8 @@ mappend = (<>) -- | Find the maxima of a list (passing it through the machinery above)-maxima :: (Ord a, PartialOrd a) => [a] -> [a]-maxima = S.toList . maxSet . mconcat . fmap (Maxima . S.singleton)+maxima :: (Foldable f, Ord a, PartialOrd a) => f a -> Set a+maxima = maxSet . foldMap (Maxima . S.singleton) -- | As above, but with minima@@ -273,5 +343,44 @@ mappend = (<>) -- | Find the minima of a list (passing it through the machinery above)-minima :: (Ord a, PartialOrd a) => [a] -> [a]-minima = S.toList . minSet . mconcat . fmap (Minima . S.singleton)+minima :: (Foldable f, Ord a, PartialOrd a) => f a -> Set a+minima = minSet . foldMap (Minima . S.singleton)+++-- | Maps partially ordered for pointwise comparison, where empty+-- values are considered minimal.+--+-- This is commonplace, but by no means the only conceivably ordering+-- on Map.+newtype PointwisePositive k v = PointwisePositive {+ getPointwisePositive :: Map k v+}++instance (Ord k, PartialOrd v) => PartialOrd (PointwisePositive k v) where++ -- We reimplement the merge because of the possibility of early exit+ -- (in the case where mv2 is Nothing).+ leq = let+ inner Tip _ = True+ inner (Bin _ k1 v1 l1 r1) m2 = case M.splitLookup k1 m2 of+ (l2, mv2, r2) -> case mv2 of+ Nothing -> False+ Just v2 -> inner l1 l2 && leq v1 v2 && inner r1 r2+ start (PointwisePositive m1) (PointwisePositive m2) = inner m1 m2+ in start++ -- We reimplement the merge because of the possibility for+ -- shortcutting (via the call to compare')+ compare' = let+ inner Tip Tip = EQ'+ inner Tip (Bin _ _ _ _ _) = LT'+ inner (Bin _ k1 v1 l1 r1) m2 = case M.splitLookup k1 m2 of+ (l2, mv2, r2) -> case mv2 of+ Nothing -> if geq (PointwisePositive l1) (PointwisePositive l2) && geq (PointwisePositive r1) (PointwisePositive r2) then GT' else NT'+ Just v2 -> compare' (PointwisePositive l1,v1,PointwisePositive r1) (PointwisePositive l2,v2,PointwisePositive r2)+ start (PointwisePositive m1) (PointwisePositive m2) = inner m1 m2+ in start+++instance PartialOrd a => PartialOrd (Down a) where+ compare' (Down x) (Down y) = compare' y x