diff --git a/Algebra/Lattice.hs b/Algebra/Lattice.hs --- a/Algebra/Lattice.hs +++ b/Algebra/Lattice.hs @@ -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 diff --git a/Algebra/Lattice/Lexicographic.hs b/Algebra/Lattice/Lexicographic.hs new file mode 100644 --- /dev/null +++ b/Algebra/Lattice/Lexicographic.hs @@ -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 +-- +---------------------------------------------------------------------------- +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 diff --git a/Algebra/Lattice/Op.hs b/Algebra/Lattice/Op.hs new file mode 100644 --- /dev/null +++ b/Algebra/Lattice/Op.hs @@ -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 +-- +---------------------------------------------------------------------------- +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. diff --git a/Algebra/Lattice/Ordered.hs b/Algebra/Lattice/Ordered.hs new file mode 100644 --- /dev/null +++ b/Algebra/Lattice/Ordered.hs @@ -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 +-- +---------------------------------------------------------------------------- +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 = (<=) diff --git a/Algebra/PartialOrd.hs b/Algebra/PartialOrd.hs --- a/Algebra/PartialOrd.hs +++ b/Algebra/PartialOrd.hs @@ -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 diff --git a/Algebra/PartialOrd/Instances.hs b/Algebra/PartialOrd/Instances.hs new file mode 100644 --- /dev/null +++ b/Algebra/PartialOrd/Instances.hs @@ -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 +-- +-- 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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/lattices.cabal b/lattices.cabal --- a/lattices.cabal +++ b/lattices.cabal @@ -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, diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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