packages feed

lattices 1.4.1 → 1.5.0

raw patch · 9 files changed

+479/−25 lines, 9 filesdep ~base

Dependency ranges changed: base

Files

Algebra/Lattice.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} #if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 709 {-# OPTIONS_GHC -fno-warn-amp #-} #endif@@ -30,6 +31,7 @@     -- * Bounded lattices     BoundedJoinSemiLattice(..), BoundedMeetSemiLattice(..), BoundedLattice,     joins, meets,+    fromBool,      -- * Monoid wrappers     Meet(..), Join(..),@@ -41,28 +43,36 @@  import qualified Algebra.PartialOrd as PO -import           Data.Universe.Class+import           Data.Universe.Class (Universe(..), Finite(..))  #if MIN_VERSION_base(4,8,0) #else-import           Data.Foldable (Foldable, foldMap)+import           Control.Applicative (Applicative(..))+import           Data.Foldable       (Foldable, foldMap)+import           Data.Monoid         (Monoid(..)) #endif -import           Data.Proxy-import           Data.Semigroup-import           Data.Tagged-import           Data.Void+import           Control.Monad.Zip (MonadZip(..))+import           Data.Data         (Data, Typeable)+import           Data.Hashable     (Hashable(..))+import           Data.Proxy        (Proxy(..))+import           Data.Semigroup    (Semigroup(..), Endo(..), Any(..), All(..))+import           Data.Tagged       (Tagged(..))+import           Data.Void         (Void)+import           GHC.Generics      (Generic)  import qualified Data.IntMap as IM import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.Set as S -import           Data.Hashable import qualified Data.HashSet as HS import qualified Data.HashMap.Lazy as HM -import           Data.Data+import Control.Applicative (Const(..))+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity(..))+#endif  infixr 6 /\ -- This comment needed because of CPP infixr 5 \/@@ -147,6 +157,10 @@ -- | Lattices with both bounds class (Lattice a, BoundedJoinSemiLattice a, BoundedMeetSemiLattice a) => BoundedLattice a where +-- | 'True' to 'top' and 'False' to 'bottom'+fromBool :: BoundedLattice a => Bool -> a+fromBool True  = top+fromBool False = bottom  -- -- Sets@@ -314,7 +328,7 @@  -- | Monoid wrapper for JoinSemiLattice newtype Join a = Join { getJoin :: a }-  deriving (Eq, Ord, Read, Show, Bounded, Typeable, Data)+  deriving (Eq, Ord, Read, Show, Bounded, Typeable, Data, Generic)  instance JoinSemiLattice a => Semigroup (Join a) where   Join a <> Join b = Join (a \/ b)@@ -323,9 +337,31 @@   mempty = Join bottom   Join a `mappend` Join b = Join (a \/ b) +instance Functor Join where+  fmap f (Join x) = Join (f x)++instance Applicative Join where+  pure = Join+  Join f <*> Join x = Join (f x)+  _ *> x = x++instance Monad Join where+  return = pure+  Join m >>= f = f m+  (>>) = (*>)++instance MonadZip Join where+  mzip (Join x) (Join y) = Join (x, y)++instance Universe a => Universe (Join a) where+  universe = fmap Join universe++instance Finite a => Finite (Join a) where+  universeF = fmap Join universeF+ -- | Monoid wrapper for MeetSemiLattice newtype Meet a = Meet { getMeet :: a }-  deriving (Eq, Ord, Read, Show, Bounded, Typeable, Data)+  deriving (Eq, Ord, Read, Show, Bounded, Typeable, Data, Generic)  instance MeetSemiLattice a => Semigroup (Meet a) where   Meet a <> Meet b = Meet (a /\ b)@@ -334,6 +370,28 @@   mempty = Meet top   Meet a `mappend` Meet b = Meet (a /\ b) +instance Functor Meet where+  fmap f (Meet x) = Meet (f x)++instance Applicative Meet where+  pure = Meet+  Meet f <*> Meet x = Meet (f x)+  _ *> x = x++instance Monad Meet where+  return = pure+  Meet m >>= f = f m+  (>>) = (*>)++instance MonadZip Meet where+  mzip (Meet x) (Meet y) = Meet (x, y)++instance Universe a => Universe (Meet a) where+  universe = fmap Meet universe++instance Finite a => Finite (Meet a) where+  universeF = fmap Meet universeF+ -- All instance JoinSemiLattice All where   All a \/ All b = All $ a \/ b@@ -413,6 +471,40 @@  instance Lattice (Proxy a) where instance BoundedLattice (Proxy a) where++#if MIN_VERSION_base(4,8,0)+-- Identity+instance JoinSemiLattice a => JoinSemiLattice (Identity a) where+  Identity a \/ Identity b = Identity (a \/ b)++instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Identity a) where+  bottom = Identity bottom++instance MeetSemiLattice a => MeetSemiLattice (Identity a) where+  Identity a /\ Identity b = Identity (a /\ b)++instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Identity a) where+  top = Identity top++instance Lattice a => Lattice (Identity a) where+instance BoundedLattice a => BoundedLattice (Identity a) where+#endif++-- Const+instance JoinSemiLattice a => JoinSemiLattice (Const a b) where+  Const a \/ Const b = Const (a \/ b)++instance BoundedJoinSemiLattice a => BoundedJoinSemiLattice (Const a b) where+  bottom = Const bottom++instance MeetSemiLattice a => MeetSemiLattice (Const a b) where+  Const a /\ Const b = Const (a /\ b)++instance BoundedMeetSemiLattice a => BoundedMeetSemiLattice (Const a b) where+  top = Const top++instance Lattice a => Lattice (Const a b) where+instance BoundedLattice a => BoundedLattice (Const a b) where  -- Void instance JoinSemiLattice Void where
+ Algebra/Lattice/Lexicographic.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ < 709+{-# LANGUAGE Trustworthy #-}+#else+{-# LANGUAGE Safe #-}+#endif+----------------------------------------------------------------------------+-- |+-- Module      :  Algebra.Lattice.Lexicographic+-- Copyright   :  (C) 2010-2015 Maximilian Bolingbroke, 2015 Oleg Grenrus+-- License     :  BSD-3-Clause (see the file LICENSE)+--+-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>+--+----------------------------------------------------------------------------+module Algebra.Lattice.Lexicographic (+    Lexicographic(..)+  ) where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++import Algebra.Lattice+import Algebra.PartialOrd++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+import Data.Foldable+import Data.Traversable+#endif++import Control.DeepSeq+import Control.Monad+import Data.Data+import Data.Hashable+import GHC.Generics++--+-- Lexicographic+--++-- | A pair lattice with a lexicographic ordering.  This means in +-- a join the second component of the resulting pair is the second+-- component of the pair with the larger first component.  If the+-- first components are equal, then the second components will be+-- joined.  The meet is similar only it prefers the smaller first+-- component.+--+-- An application of this type is versioning.  For example, a+-- Last-Writer-Wins register would look like +-- 'Lexicographc (Ordered Timestamp) v' where the lattice +-- structure handles the, presumably rare, case of matching+-- 'Timestamps'.  Typically this is done in an arbitary, but+-- deterministic manner.+data Lexicographic k v = Lexicographic !k !v+  deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic+#if __GLASGOW_HASKELL__ >= 706+           , Generic1+#endif+           )++instance Foldable (Lexicographic k) where+  foldMap f (Lexicographic _ v) = f v++instance Traversable (Lexicographic k) where+  traverse f (Lexicographic k v) = Lexicographic k <$> f v++instance Functor (Lexicographic k) where+  fmap f (Lexicographic k v) = Lexicographic k (f v)++instance BoundedJoinSemiLattice k => Applicative (Lexicographic k) where+  pure = return+  (<*>) = ap++-- Essentially the Writer monad.+instance BoundedJoinSemiLattice k => Monad (Lexicographic k) where+  return                   =  Lexicographic bottom+  Lexicographic k v >>= f  =+    case f v of+      Lexicographic k' v' -> Lexicographic (k \/ k') v'++instance (NFData k, NFData v) => NFData (Lexicographic k v) where+  rnf (Lexicographic k v) = rnf k `seq` rnf v++instance (Hashable k, Hashable v) => Hashable (Lexicographic k v)++instance (PartialOrd k, JoinSemiLattice k, JoinSemiLattice v) => JoinSemiLattice (Lexicographic k v) where+  l@(Lexicographic k1 v1) \/ r@(Lexicographic k2 v2)+    | k1 `leq` k2 = r+    | k2 `leq` k1 = l+    | otherwise   = Lexicographic (k1 \/ k2) (v1 \/ v2)++instance (PartialOrd k, MeetSemiLattice k, MeetSemiLattice v) => MeetSemiLattice (Lexicographic k v) where+  l@(Lexicographic k1 v1) /\ r@(Lexicographic k2 v2)+    | k1 `leq` k2 = l+    | k2 `leq` k1 = r+    | otherwise   = Lexicographic (k1 /\ k2) (v1 /\ v2)++instance (PartialOrd k, Lattice k, Lattice v) => Lattice (Lexicographic k v) where++instance (PartialOrd k, BoundedJoinSemiLattice k, BoundedJoinSemiLattice v) => BoundedJoinSemiLattice (Lexicographic k v) where+  bottom = Lexicographic bottom bottom++instance (PartialOrd k, BoundedMeetSemiLattice k, BoundedMeetSemiLattice v) => BoundedMeetSemiLattice (Lexicographic k v) where+  top = Lexicographic top top++instance (PartialOrd k, BoundedLattice k, BoundedLattice v) => BoundedLattice (Lexicographic k v) where++instance (PartialOrd k, PartialOrd v) => PartialOrd (Lexicographic k v) where+  Lexicographic k1 v1 `leq` Lexicographic k2 v2+    | k1 `leq` k2 = True+    | k1   ==  k1 = v1 `leq` v2+    | otherwise   = False -- Incomparable or k2 `leq` k1
+ Algebra/Lattice/Op.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ < 709+{-# LANGUAGE Trustworthy #-}+#else+{-# LANGUAGE Safe #-}+#endif+----------------------------------------------------------------------------+-- |+-- Module      :  Algebra.Lattice.Op+-- Copyright   :  (C) 2010-2015 Maximilian Bolingbroke, 2015 Oleg Grenrus+-- License     :  BSD-3-Clause (see the file LICENSE)+--+-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>+--+----------------------------------------------------------------------------+module Algebra.Lattice.Op (+    Op(..)+  ) where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++import Algebra.Lattice+import Algebra.PartialOrd++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+import Data.Foldable+import Data.Traversable+#endif++import Control.DeepSeq+import Control.Monad+import Data.Data+import Data.Hashable+import GHC.Generics++--+-- Op+--++-- | The opposite lattice of a given lattice.  That is, switch+-- meets and joins.+newtype Op a = Op { getOp :: a }+  deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic+#if __GLASGOW_HASKELL__ >= 706+           , Generic1+#endif+           )++instance Foldable Op where+  foldMap f (Op a) = f a++instance Traversable Op where+  traverse f (Op a) = Op <$> f a++instance Functor Op where+  fmap f (Op a) = Op (f a)++instance Applicative Op where+  pure = return+  (<*>) = ap++instance Monad Op where+  return      = Op+  Op x >>= f  = f x++instance NFData a => NFData (Op a) where+  rnf (Op a) = rnf a++instance Hashable a => Hashable (Op a)++instance MeetSemiLattice a => JoinSemiLattice (Op a) where+  Op x \/ Op y = Op (x /\ y)++instance JoinSemiLattice a => MeetSemiLattice (Op a) where+  Op x /\ Op y = Op (x \/ y)++instance (Lattice a, Ord a) => Lattice (Op a) where++instance BoundedMeetSemiLattice a => BoundedJoinSemiLattice (Op a) where+  bottom = Op top++instance BoundedJoinSemiLattice a => BoundedMeetSemiLattice (Op a) where+  top = Op bottom++instance (BoundedLattice a, Ord a, Bounded a) => BoundedLattice (Op a) where++instance PartialOrd a => PartialOrd (Op a) where+    Op a `leq` Op b = b `leq` a -- Note swap.
+ Algebra/Lattice/Ordered.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ < 709+{-# LANGUAGE Trustworthy #-}+#else+{-# LANGUAGE Safe #-}+#endif+----------------------------------------------------------------------------+-- |+-- Module      :  Algebra.Lattice.Ordered+-- Copyright   :  (C) 2010-2015 Maximilian Bolingbroke, 2015 Oleg Grenrus+-- License     :  BSD-3-Clause (see the file LICENSE)+--+-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>+--+----------------------------------------------------------------------------+module Algebra.Lattice.Ordered (+    Ordered(..)+  ) where++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++import Algebra.Lattice+import Algebra.PartialOrd++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+import Data.Foldable+import Data.Traversable+#endif++import Control.DeepSeq+import Control.Monad+import Data.Data+import Data.Hashable+import GHC.Generics++--+-- Ordered+--++-- | A total order gives rise to a lattice. Join is+-- max, meet is min.+newtype Ordered a = Ordered { getOrdered :: a }+  deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic+#if __GLASGOW_HASKELL__ >= 706+           , Generic1+#endif+           )++instance Foldable Ordered where+  foldMap f (Ordered a) = f a++instance Traversable Ordered where+  traverse f (Ordered a) = Ordered <$> f a++instance Functor Ordered where+  fmap f (Ordered a) = Ordered (f a)++instance Applicative Ordered where+  pure = return+  (<*>) = ap++instance Monad Ordered where+  return           = Ordered+  Ordered x >>= f  = f x++instance NFData a => NFData (Ordered a) where+  rnf (Ordered a) = rnf a++instance Hashable a => Hashable (Ordered a)++instance Ord a => JoinSemiLattice (Ordered a) where+  Ordered x \/ Ordered y = Ordered (max x y)++instance Ord a => MeetSemiLattice (Ordered a) where+  Ordered x /\ Ordered y = Ordered (min x y)++instance (Lattice a, Ord a) => Lattice (Ordered a) where++instance (Ord a, Bounded a) => BoundedJoinSemiLattice (Ordered a) where+  bottom = Ordered minBound++instance (Ord a, Bounded a) => BoundedMeetSemiLattice (Ordered a) where+  top = Ordered maxBound++instance (BoundedLattice a, Ord a, Bounded a) => BoundedLattice (Ordered a) where++instance Ord a => PartialOrd (Ordered a) where+    leq = (<=)
Algebra/PartialOrd.hs view
@@ -18,9 +18,6 @@     gfpFrom, unsafeGfpFrom   ) where -import           Data.Universe.Class (Finite(..))-import           Data.Universe.Instances.Eq ()- import qualified Data.Set as S import qualified Data.IntSet as IS import qualified Data.Map as M@@ -63,9 +60,6 @@  instance PartialOrd v => PartialOrd (IM.IntMap v) where     im1 `leq` im2 = im1 `IM.isSubmapOf` im2 && IM.fold (\(x1, x2) b -> b && x1 `leq` x2) True (IM.intersectionWith (,) im1 im2)--instance (PartialOrd v, Finite k) => PartialOrd (k -> v) where-    f `leq` g = all (\k -> f k `leq` g k) universeF  instance (PartialOrd a, PartialOrd b) => PartialOrd (a, b) where     -- NB: *not* a lexical ordering. This is because for some component partial orders, lexical
+ Algebra/PartialOrd/Instances.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+----------------------------------------------------------------------------+-- |+-- Module      :  Algebra.PartialOrd.Instances+-- Copyright   :  (C) 2010-2015 Maximilian Bolingbroke, 2015 Oleg Grenrus+-- License     :  BSD-3-Clause (see the file LICENSE)+--+-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- This module re-exports orphan instances from 'Data.Universe.Instances.Eq'+-- module, and @(PartialOrd v, Finite k) => PartialOrd (k -> v)@ instance.+----------------------------------------------------------------------------+module Algebra.PartialOrd.Instances () where++import Algebra.PartialOrd (PartialOrd(..))+import Data.Universe.Class (Finite(..))+import Data.Universe.Instances.Eq ()++-- | @Eq (k -> v)@ is from 'Data.Universe.Instances.Eq'+instance (PartialOrd v, Finite k) => PartialOrd (k -> v) where+    f `leq` g = all (\k -> f k `leq` g k) universeF
CHANGELOG.md view
@@ -1,3 +1,10 @@+# 1.5.0 (2015-12-18)++- Move `PartialOrd (k -> v)` instance into own module+- `Const` and `Identity` instances+- added `fromBool`+- Add `Lexicographic`, `Ordered` and `Op` newtypes+ # 1.4.1 (2015-10-26)  - `MINIMAL` pragma in with GHC 7.8
lattices.cabal view
@@ -1,5 +1,5 @@ name:               lattices-version:            1.4.1+version:            1.5.0 cabal-version:      >= 1.10 category:           Math license:            BSD3@@ -25,14 +25,18 @@                     Algebra.Lattice,                     Algebra.Lattice.Dropped,                     Algebra.Lattice.Levitated,+                    Algebra.Lattice.Lexicographic,                     Algebra.Lattice.Lifted,-                    Algebra.PartialOrd+                    Algebra.Lattice.Op,+                    Algebra.Lattice.Ordered,+                    Algebra.PartialOrd,+                    Algebra.PartialOrd.Instances    build-depends:    base                       >= 4.5  && < 4.9,                     containers                 >= 0.3  && < 0.6,                     deepseq                    >= 1.1  && < 1.5,                     hashable                   >= 1.2  && < 1.3,-                    semigroups                 >= 0.16 && < 0.18,+                    semigroups                 >= 0.16 && < 0.19,                     tagged                     >= 0.7  && < 0.9,                     void                       >= 0.7  && < 0.8,                     unordered-containers       >= 0.2  && < 0.3,
test/Tests.hs view
@@ -21,8 +21,11 @@ import Test.Tasty.QuickCheck as QC  import qualified Algebra.Lattice.Dropped as D-import qualified Algebra.Lattice.Lifted as U import qualified Algebra.Lattice.Levitated as L+import qualified Algebra.Lattice.Lexicographic as LO+import qualified Algebra.Lattice.Lifted as U+import qualified Algebra.Lattice.Op as Op+import qualified Algebra.Lattice.Ordered as O  -- For old GHC to work data Proxy1 (a :: * -> *) = Proxy1@@ -36,14 +39,23 @@ theseProps :: TestTree theseProps = testGroup "These"   [ functorLaws "Dropped" (Proxy1 :: Proxy1 D.Dropped)+  , functorLaws "Levitated" (Proxy1 :: Proxy1 L.Levitated)+  , functorLaws "Lexicographic" (Proxy1 :: Proxy1 (LO.Lexicographic Bool))   , functorLaws "Lifted" (Proxy1 :: Proxy1 U.Lifted)-  , functorLaws "Leviated" (Proxy1 :: Proxy1 L.Levitated)-  , traversableLaws "Dropped" (Proxy1 :: Proxy1 D.Dropped)-  , traversableLaws "Lifted" (Proxy1 :: Proxy1 U.Lifted)-  , traversableLaws "Levitated" (Proxy1 :: Proxy1 L.Levitated)+  , functorLaws "Op" (Proxy1 :: Proxy1 Op.Op)+  , functorLaws "Ordered" (Proxy1 :: Proxy1 O.Ordered)   , monadLaws "Dropped" (Proxy1 :: Proxy1 D.Dropped)-  , monadLaws "Lifted" (Proxy1 :: Proxy1 U.Lifted)   , monadLaws "Levitated" (Proxy1 :: Proxy1 L.Levitated)+  , monadLaws "Lexicographic" (Proxy1 :: Proxy1 (LO.Lexicographic Bool))+  , monadLaws "Lifted" (Proxy1 :: Proxy1 U.Lifted)+  , monadLaws "Op" (Proxy1 :: Proxy1 Op.Op)+  , monadLaws "Ordered" (Proxy1 :: Proxy1 O.Ordered)+  , traversableLaws "Dropped" (Proxy1 :: Proxy1 D.Dropped)+  , traversableLaws "Levitated" (Proxy1 :: Proxy1 L.Levitated)+  , traversableLaws "Lexicographic" (Proxy1 :: Proxy1 (LO.Lexicographic Bool))+  , traversableLaws "Lifted" (Proxy1 :: Proxy1 U.Lifted)+  , traversableLaws "Op" (Proxy1 :: Proxy1 Op.Op)+  , traversableLaws "Ordered" (Proxy1 :: Proxy1 O.Ordered)   ]  functorLaws :: forall (f :: * -> *). ( Functor f@@ -144,3 +156,12 @@                         , (1, pure L.Bottom)                         , (9, L.Levitate <$> arbitrary)                         ]++instance Arbitrary a => Arbitrary (O.Ordered a) where+  arbitrary = O.Ordered <$> arbitrary++instance Arbitrary a => Arbitrary (Op.Op a) where+  arbitrary = Op.Op <$> arbitrary++instance (Arbitrary k, Arbitrary v) => Arbitrary (LO.Lexicographic k v) where+  arbitrary = LO.Lexicographic <$> arbitrary <*> arbitrary