{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Semilattice (
type (-)
, JoinSemilattice
, BoundedJoinSemilattice
, Join(..)
, bottom
, (∨)
, join
, joinWith
, join1
, joinWith1
, MeetSemilattice
, BoundedMeetSemilattice
, Meet(..)
, top
, (∧)
, meet
, meetWith
, meet1
, meetWith1
, LatticeLaw
, BoundedLatticeLaw
, BoundedLattice
, LowerBoundedLattice
, UpperBoundedLattice
, Lattice
, glb
, glbWith
, lub
, lubWith
, eval
, evalWith
, eval1
, evalWith1
, cross
, cross1
) where
import Control.Applicative
import Data.Bool
import Data.Either
import Data.Fixed
import Data.Foldable
import Data.Functor.Apply
import Data.Int
import Data.Maybe
import Data.Ord (Ord)
import Data.Prd
import Data.Semigroup.Foldable
import Data.Semigroup.Join
import Data.Semigroup.Meet
import Data.Word
import Numeric.Natural
import Prelude hiding (Ord(..), Fractional(..),Num(..))
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as Map
import qualified Data.Set as Set
type LatticeLaw a = (JoinSemilattice a, MeetSemilattice a)
type BoundedLatticeLaw a = (BoundedJoinSemilattice a, BoundedMeetSemilattice a)
type BoundedLattice a = (Lattice a, BoundedLatticeLaw a)
type LowerBoundedLattice a = (Lattice a, (Join-Monoid) a)
type UpperBoundedLattice a = (Lattice a, (Meet-Monoid) a)
type BoundedJoinSemilattice a = (JoinSemilattice a, (Join-Monoid) a)
type BoundedMeetSemilattice a = (MeetSemilattice a, (Meet-Monoid) a)
class LatticeLaw a => Lattice a
glb :: Lattice a => a -> a -> a -> a
glb = glbWith id
glbWith :: Lattice r => (a -> r) -> a -> a -> a -> r
glbWith f x y z = (f x ∨ f y) ∧ (f y ∨ f z) ∧ (f z ∨ f x)
lub :: Lattice a => a -> a -> a -> a
lub = lubWith id
lubWith :: Lattice r => (a -> r) -> a -> a -> a -> r
lubWith f x y z = (f x ∧ f y) ∨ (f y ∧ f z) ∨ (f z ∧ f x)
join :: (Join-Monoid) a => Lattice a => Foldable f => f a -> a
join = joinWith id
joinWith :: (Join-Monoid) a => Foldable t => (b -> a) -> t b -> a
joinWith f = foldr' ((∨) . f) bottom
{-# INLINE joinWith #-}
meet :: (Meet-Monoid) a => Lattice a => Foldable f => f a -> a
meet = meetWith id
meetWith :: (Meet-Monoid) a => Foldable t => (b -> a) -> t b -> a
meetWith f = foldr' ((∧) . f) top
{-# INLINE meetWith #-}
join1 :: Lattice a => Foldable1 f => f a -> a
join1 = joinWith1 id
joinWith1 :: Foldable1 t => Lattice a => (b -> a) -> t b -> a
joinWith1 f = unJoin . foldMap1 (Join . f)
{-# INLINE joinWith1 #-}
meet1 :: Lattice a => Foldable1 f => f a -> a
meet1 = meetWith1 id
meetWith1 :: Foldable1 t => Lattice a => (b -> a) -> t b -> a
meetWith1 f = unMeet . foldMap1 (Meet . f)
{-# INLINE meetWith1 #-}
eval :: BoundedLattice a => Functor f => Foldable f => Foldable g => f (g a) -> a
eval = join . fmap meet
evalWith :: BoundedLattice r => Functor f => Functor g => Foldable f => Foldable g => (a -> r) -> f (g a) -> r
evalWith f = join . fmap meet . (fmap . fmap) f
eval1 :: Lattice a => Functor f => Foldable1 f => Foldable1 g => f (g a) -> a
eval1 = join1 . fmap meet1
evalWith1 :: Lattice r => Functor f => Functor g => Foldable1 f => Foldable1 g => (a -> r) -> f (g a) -> r
evalWith1 f = join1 . fmap meet1 . (fmap . fmap) f
cross :: Foldable f => Applicative f => LowerBoundedLattice a => f a -> f a -> a
cross a b = join $ liftA2 (∧) a b
{-# INLINE cross #-}
cross1 :: Foldable1 f => Apply f => Lattice a => f a -> f a -> a
cross1 a b = join1 $ liftF2 (∧) a b
{-# INLINE cross1 #-}
instance Lattice ()
instance Lattice Bool
instance Lattice Word
instance Lattice Word8
instance Lattice Word16
instance Lattice Word32
instance Lattice Word64
instance Lattice Natural
instance Lattice Int
instance Lattice Int8
instance Lattice Int16
instance Lattice Int32
instance Lattice Int64
instance Lattice Integer
instance Lattice Uni
instance Lattice Deci
instance Lattice Centi
instance Lattice Milli
instance Lattice Micro
instance Lattice Nano
instance Lattice Pico
instance Lattice a => Lattice (Down a)
instance (Lattice a, Lattice b) => Lattice (Either a b)
instance Lattice a => Lattice (Maybe a)
instance Lattice a => Lattice (IntMap.IntMap a)
instance Lattice IntSet.IntSet
instance Ord a => Lattice (Set.Set a)
instance (Ord k, Lattice a) => Lattice (Map.Map k a)