diff --git a/connections.cabal b/connections.cabal --- a/connections.cabal +++ b/connections.cabal @@ -1,7 +1,7 @@ name: connections -version: 0.0.3 -synopsis: Partial orders, Galois connections, and lattices. -description: A library for numerical conversions using Galois connections. +version: 0.1.0 +synopsis: Orders, Galois connections, and lattices. +description: A library for order manipulation using Galois connections. homepage: https://github.com/cmk/connections license: BSD3 license-file: LICENSE @@ -18,33 +18,32 @@ default-language: Haskell2010 ghc-options: -Wall -optc-std=c99 exposed-modules: - Data.Prd - , Data.Prd.Nan - , Data.Prd.Property - , Data.Float - , Data.Semigroup.Join - , Data.Semigroup.Meet - , Data.Connection + + Data.Connection + , Data.Connection.Conn + , Data.Connection.Class , Data.Connection.Int , Data.Connection.Word - , Data.Connection.Float , Data.Connection.Ratio - , Data.Connection.Round + , Data.Connection.Float + , Data.Connection.Double , Data.Connection.Property - , Data.Semilattice - , Data.Semilattice.N5 - , Data.Semilattice.Top - , Data.Semilattice.MaxMin - , Data.Semilattice.Property - , Numeric.Prelude + , Data.Lattice + , Data.Lattice.Property + , Data.Order + , Data.Order.Extended + , Data.Order.Interval + , Data.Order.Property + , Data.Order.Syntax + build-depends: - base >= 4.10 && < 5.0 - , lawz >= 0.1.1 && < 1.0 - , rings >= 0.0.3.1 && < 0.0.4 - , containers >= 0.4.0 && < 0.7 - , semigroupoids >= 5.0 && < 6.0 + base >= 4.10 && < 5.0 + , containers >= 0.4.0 && < 1.0 + , transformers >= 0.5.5 && < 0.6 + , universe-base >= 1.1.1 && < 2.0 + , finite-typelits >= 0.1.4.2 && < 0.1.5 default-extensions: ScopedTypeVariables @@ -58,7 +57,8 @@ test-suite test type: exitcode-stdio-1.0 other-modules: - Test.Data.Prd + Test.Data.Order + , Test.Data.Lattice , Test.Data.Connection , Test.Data.Connection.Int , Test.Data.Connection.Word @@ -68,11 +68,10 @@ base == 4.* , connections -any , hedgehog - , rings - , lawz default-extensions: ScopedTypeVariables, - TypeApplications + TypeApplications, + FlexibleContexts main-is: test.hs hs-source-dirs: test default-language: Haskell2010 diff --git a/src/Data/Connection.hs b/src/Data/Connection.hs --- a/src/Data/Connection.hs +++ b/src/Data/Connection.hs @@ -1,281 +1,187 @@ -{-# Language TypeFamilies #-} -{-# Language TypeApplications #-} +{-# Language TypeApplications #-} {-# Language AllowAmbiguousTypes #-} -{-# Language ConstraintKinds #-} +{-# Language ConstraintKinds #-} +{-# Language DataKinds #-} +{-# Language Safe #-} +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +{-# Language RankNTypes #-} +{-# Language QuantifiedConstraints #-} module Data.Connection ( + -- * Types + Kan(..) + , Semilattice + , Extremal + , ConnFloat + , ConnDouble + , ConnInteger + , ConnRational + , ConnExtended + -- * Connection L + , type ConnL + , pattern ConnL + , connL + , swapL + , embedL + , ceiling + , ceiling1 + , ceiling2 + , filterL + , minimal + , (\/) + , glb + -- * Connection R + , type ConnR + , pattern ConnR + , connR + , swapR + , floor + , floor1 + , floor2 + , embedR + , filterR + , maximal + , (/\) + , lub -- * Connection - Conn(..) - , connl - , connr - , unit - , counit - , pcomparing - , dual - , first - , second - , left - , right - , strong + , type Trip + , pattern Conn + , half + , midpoint + , round + , round1 + , round2 + , truncate + , truncate1 + , truncate2 + , maybeL + , maybeR , choice - , (&&&) - , (|||) - , just - , list - , ordbin - , binord - -- * Triple - , Trip(..) - , tripl - , tripr - , unitl - , unitr - , counitl - , counitr - , bound - , first' - , second' - , left' - , right' - , strong' - , choice' - , forked - , joined - , maybel - , mayber + , strong + , fmapped + -- * Connection + , Conn() + , Triple + , Connection(..) ) where - -import Control.Category (Category, (>>>)) -import Data.Bifunctor (bimap) -import Data.Bool -import Data.Prd -import Data.Semigroup.Join -import Data.Semigroup.Meet -import Prelude hiding (Ord(..), Num(..), Fractional(..), RealFrac(..)) - -import qualified Control.Category as C +import safe Data.Connection.Conn +import safe Data.Connection.Class +import safe Data.Order +import safe Prelude hiding + (Bounded,fromInteger, fromRational, floor, ceiling, round, truncate) +-- $setup +-- >>> :set -XTypeApplications +-- >>> import Data.Int +-- >>> import Prelude hiding (Ord(..), Bounded, fromInteger, fromRational, RealFrac(..)) +-- >>> import qualified Prelude as P +-- >>> :load Data.Connection --- | A Galois connection between two monotone functions. --- --- Each side of the connection may be defined in terms of the other: +-- | Determine which half of the interval between 2 representations of /a/ a particular value lies. -- --- \( connr(x) = \sup \{y \in E \mid connl(y) \leq x \} \) --- --- \( connl(x) = \inf \{y \in E \mid connr(y) \geq x \} \) --- --- Galois connections have the same properties as adjunctions defined over other categories: --- --- \( \forall x, y : connl \dashv connr \Rightarrow connl (x) \leq b \Leftrightarrow x \leq connr (y) \) --- --- \( \forall x, y : x \leq y \Rightarrow connl (x) \leq connl (y) \) +-- @ 'half' t x = 'pcompare' (x - 'counitR' t x) ('unitL' t x - x) @ -- --- \( \forall x, y : x \leq y \Rightarrow connr (x) \leq connr (y) \) +half :: (Num a, Preorder a) => Trip a b -> a -> Maybe Ordering +half t x = pcompare (x - counitR t x) (unitL t x - x) + +-- | Return the midpoint of the interval containing x. -- --- \( \forall x : connl \dashv connr \Rightarrow x \leq connr \circ connl (x) \) +-- >>> midpoint f32i08 4.3 +-- 4.5 +-- >>> midpoint f64i08 4.3 +-- 4.5 +-- >>> pi - midpoint f64f32 pi +-- 3.1786509424591713e-8 -- --- \( \forall x : connl \dashv connr \Rightarrow connl \circ connr (x) \leq x \) +-- >>> maybe False (~~ EQ) $ half f64f32 (midpoint f64f32 pi) +-- True -- --- \( \forall x : unit \circ unit (x) \sim unit (x) \) +midpoint :: Fractional a => Trip a b -> a -> a +midpoint t x = counitR t x / 2 + unitL t x / 2 + +--------------------------------------------------------------------- +-- Rounding +--------------------------------------------------------------------- + +-- | Return the nearest value to x. -- --- \( \forall x : counit \circ counit (x) \sim counit (x) \) +-- > round @a @a = id +-- +-- If x lies halfway between two finite values, then return the value +-- with the larger absolute value (i.e. round away from zero). -- --- \( \forall x : counit \circ connl (x) \sim connl (x) \) +-- See . -- --- \( \forall x : unit \circ connr (x) \sim connr (x) \) +-- Usable in conjunction with /RebindableSyntax/: -- --- See also 'Data.Function.Connection.Property' and . +-- >>> fromRational = round +-- >>> fromRational @Float 1.3 +-- 1.3 +-- >>> fromRational @Float (1 :% 0) +-- Infinity +-- >>> fromRational @Float (0 :% 0) +-- NaN -- -data Conn a b = Conn (a -> b) (b -> a) - -instance Category Conn where - id = Conn id id - Conn f' g' . Conn f g = Conn (f' . f) (g . g') +round :: forall a b. (Num a, Triple a b) => a -> b +round x = case pcompare halfR halfL of + Just GT -> ceiling x + Just LT -> floor x + _ -> truncate x --- | Extract the left side of a connection. --- -connl :: Prd a => Prd b => Conn a b -> a -> b -connl (Conn f _) = f + where + halfR = x - counitR (connR @a @b) x -- dist from lower bound --- | Extract the right side of a connection. --- -connr :: Prd a => Prd b => Conn a b -> b -> a -connr (Conn _ g) = g + halfL = unitL (connL @a @b) x - x -- dist from upper bound --- | Round trip through a connection. +-- | Lift a unary function over a 'Trip'. -- --- @x '<=' 'unit' x@ +-- Results are rounded to the nearest value with ties away from 0. -- -unit :: Prd a => Prd b => Conn a b -> a -> a -unit (Conn f g) = g . f +round1 :: forall a b. (Num a, Triple a b) => (a -> a) -> b -> b +round1 f x = round $ f (g x) where Conn _ g _ = connL +{-# INLINE round1 #-} --- | Reverse round trip through a connection. --- --- @'counit' x '<=' x@ +-- | Lift a binary function over a 'Trip'. -- -counit :: Prd a => Prd b => Conn a b -> b -> b -counit (Conn f g) = f . g - --- | Partial version of 'Data.Ord.comparing'. +-- Results are rounded to the nearest value with ties away from 0. -- -pcomparing :: Prd a => Prd b => Conn a b -> a -> a -> Maybe Ordering -pcomparing (Conn f _) x y = f x `pcompare` f y - ---------------------------------------------------------------------- --- Instances ---------------------------------------------------------------------- - --- | Reverse a connection using the dual partial order on each side. +-- >>> f x y = (x + y) - x +-- >>> maxOdd32 = 1.6777215e7 +-- >>> maxOdd64 = 9.007199254740991e15 +-- >>> f maxOdd32 2.0 :: Float +-- 1.0 +-- >>> round2 @Rational @Float f maxOdd32 2.0 +-- 2.0 +-- >>> f maxOdd64 2.0 :: Double +-- 1.0 +-- >>> round2 @Rational @Double f maxOdd64 2.0 +-- 2.0 -- -dual :: Prd a => Prd b => Conn a b -> Conn (Down b) (Down a) -dual (Conn f g) = Conn (\(Down b) -> Down $ g b) (\(Down a) -> Down $ f a) +round2 :: (Num a, Triple a b) => (a -> a -> a) -> b -> b -> b +round2 f x y = round $ f (g x) (g y) where Conn _ g _ = connL +{-# INLINE round2 #-} --- | @'first' (ab '>>>' cd) = 'first' ab '>>>' 'first' cd@ +-- | Truncate towards zero. -- -first :: Prd a => Prd b => Prd c => Conn a b -> Conn (a, c) (b, c) -first = flip strong C.id - --- | @'second' (ab '>>>' cd) = 'second' ab '>>>' 'second' cd@ +-- > truncate @a @a = id -- -second :: Prd a => Prd b => Prd c => Conn a b -> Conn (c, a) (c, b) -second = strong C.id +truncate :: (Num a, Triple a b) => a -> b +truncate x = if x >~ 0 then floor x else ceiling x --- | @'left' (ab '>>>' cd) = 'left' ab '>>>' 'left' cd@ +-- | Lift a unary function over a 'Trip'. -- -left :: Prd a => Prd b => Prd c => Conn a b -> Conn (Either a c) (Either b c) -left = flip choice C.id - --- | @'right' (ab '>>>' cd) = 'right' ab '>>>' 'right' cd@ +-- Results are truncated towards 0. -- -right :: Prd a => Prd b => Prd c => Conn a b -> Conn (Either c a) (Either c b) -right = choice C.id - -infixr 3 &&& -(&&&) :: Prd a => Prd b => JoinSemilattice c => MeetSemilattice c => Conn c a -> Conn c b -> Conn c (a, b) -f &&& g = tripr forked >>> f `strong` g - -infixr 2 ||| -(|||) :: Prd a => Prd b => Prd c => Conn a c -> Conn b c -> Conn (Either a b) c -f ||| g = f `choice` g >>> tripr joined - -strong :: Prd a => Prd b => Prd c => Prd d => Conn a b -> Conn c d -> Conn (a, c) (b, d) -strong (Conn ab ba) (Conn cd dc) = Conn f g where - f = bimap ab cd - g = bimap ba dc - -choice :: Prd a => Prd b => Prd c => Prd d => Conn a b -> Conn c d -> Conn (Either a c) (Either b d) -choice (Conn ab ba) (Conn cd dc) = Conn f g where - f = either (Left . ab) (Right . cd) - g = either (Left . ba) (Right . dc) - -just :: Prd a => Prd b => Conn a b -> Conn (Maybe a) (Maybe b) -just (Conn f g) = Conn (fmap f) (fmap g) - -list :: Prd a => Prd b => Conn a b -> Conn [a] [b] -list (Conn f g) = Conn (fmap f) (fmap g) - -ordbin :: Conn Ordering Bool -ordbin = Conn f g where - f GT = True - f _ = False - - g True = GT - g _ = EQ - -binord :: Conn Bool Ordering -binord = Conn f g where - f False = LT - f _ = EQ - - g LT = False - g _ = True - ---------------------------------------------------------------------- --- Adjoint triples ---------------------------------------------------------------------- +truncate1 :: (Num a, Triple a b) => (a -> a) -> b -> b +truncate1 f x = truncate $ f (g x) where Conn _ g _ = connL +{-# INLINE truncate1 #-} --- | An adjoint triple. --- --- @'Trip' f g h@ satisfies: --- --- @ --- f ⊣ g --- ⊥ ⊥ --- g ⊣ h --- @ +-- | Lift a binary function over a 'Trip'. -- --- See +-- Results are truncated towards 0. -- -data Trip a b = Trip (a -> b) (b -> a) (a -> b) - -instance Category Trip where - id = Trip id id id - Trip f' g' h' . Trip f g h = Trip (f' . f) (g . g') (h' . h) - -tripl :: Prd a => Prd b => Trip a b -> Conn a b -tripl (Trip f g _) = Conn f g - -tripr :: Prd a => Prd b => Trip a b -> Conn b a -tripr (Trip _ g h) = Conn g h - -unitl :: Prd a => Prd b => Trip a b -> a -> a -unitl = unit . tripl - -unitr :: Prd a => Prd b => Trip a b -> b -> b -unitr = unit . tripr - -counitl :: Prd a => Prd b => Trip a b -> b -> b -counitl = counit . tripl - -counitr :: Prd a => Prd b => Trip a b -> a -> a -counitr = counit . tripr - ---------------------------------------------------------------------- --- Instances ---------------------------------------------------------------------- - -bound :: Prd a => Bound a => Trip () a -bound = Trip (const minimal) (const ()) (const maximal) - -first' :: Prd a => Prd b => Prd c => Trip a b -> Trip (a, c) (b, c) -first' = flip strong' C.id - -second' :: Prd a => Prd b => Prd c => Trip a b -> Trip (c, a) (c, b) -second' = strong' C.id - -left' :: Prd a => Prd b => Prd c => Trip a b -> Trip (Either a c) (Either b c) -left' = flip choice' C.id - -right' :: Prd a => Prd b => Prd c => Trip a b -> Trip (Either c a) (Either c b) -right' = choice' C.id - -strong' :: Prd a => Prd b => Prd c => Prd d => Trip a b -> Trip c d -> Trip (a, c) (b, d) -strong' (Trip ab ba ab') (Trip cd dc cd') = Trip f g h where - f = bimap ab cd - g = bimap ba dc - h = bimap ab' cd' - -choice' :: Prd a => Prd b => Prd c => Prd d => Trip a b -> Trip c d -> Trip (Either a c) (Either b d) -choice' (Trip ab ba ab') (Trip cd dc cd') = Trip f g h where - f = either (Left . ab) (Right . cd) - g = either (Left . ba) (Right . dc) - h = either (Left . ab') (Right . cd') - -forked :: JoinSemilattice a => MeetSemilattice a => Trip (a, a) a -forked = Trip (uncurry (∨)) (\x -> (x,x)) (uncurry (∧)) - -joined :: Prd a => Trip a (Either a a) -joined = Trip Left (either id id) Right - -maybel :: Prd a => Bound b => Trip (Maybe a) (Either a b) -maybel = Trip f g h where - f = maybe (Right minimal) Left - g = either Just (const Nothing) - h = maybe (Right maximal) Left - -mayber :: Prd b => Bound a => Trip (Maybe b) (Either a b) -mayber = Trip f g h where - f = maybe (Left minimal) Right - g = either (const Nothing) Just - h = maybe (Left maximal) Right +truncate2 :: (Num a, Triple a b) => (a -> a -> a) -> b -> b -> b +truncate2 f x y = truncate $ f (g x) (g y) where Conn _ g _ = connL +{-# INLINE truncate2 #-} diff --git a/src/Data/Connection/Class.hs b/src/Data/Connection/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Connection/Class.hs @@ -0,0 +1,815 @@ +{-# Language TypeApplications #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language ConstraintKinds #-} +{-# Language DataKinds #-} +{-# Language Safe #-} +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +{-# Language RankNTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Data.Connection.Class ( + -- * Types + Kan(..) + , Conn() + , Semilattice + , Extremal + , ConnFloat + , ConnDouble + , ConnInteger + , ConnRational + , ConnExtended + -- * Connection L + , ConnL + , pattern ConnL + , connL + , swapL + , embedL + , ceiling + , ceiling1 + , ceiling2 + , filterL + , minimal + , (\/) + , glb + -- * Connection R + , ConnR + , pattern ConnR + , connR + , swapR + , floor + , floor1 + , floor2 + , embedR + , filterR + , maximal + , (/\) + , lub + -- * Connection k + , Trip + , pattern Conn + , maybeL + , maybeR + , choice + , strong + , fmapped + -- * Connection + , Connection(..) + , Triple +) where + +import safe Control.Applicative (liftA2) +import safe Control.Category ((>>>)) +import safe Data.Bool (bool) +import safe Data.Connection.Conn +import safe Data.Connection.Int +import safe Data.Connection.Word +import safe Data.Connection.Float +import safe Data.Connection.Double +import safe Data.Connection.Ratio +import safe Data.Functor.Contravariant +import safe Data.Functor.Identity +import safe Data.Monoid +import safe Data.Order +import safe Data.Order.Extended +import safe Data.Order.Interval +import safe Data.Word +import safe Data.Int +import safe GHC.TypeNats +import safe Numeric.Natural +import safe Prelude hiding (Bounded, floor, ceiling, fromInteger, fromRational) +import safe qualified Control.Category as C +import safe qualified Data.IntMap as IntMap +import safe qualified Data.IntSet as IntSet +import safe qualified Data.Map as Map +import safe qualified Data.Set as Set +import safe qualified Data.Finite as F +import safe qualified Data.Universe.Class as U +import safe qualified Prelude as P + +-- $setup +-- >>> :set -XTypeApplications +-- >>> import Data.Int +-- >>> import Prelude hiding (Ord(..), Bounded, fromInteger, fromRational, RealFrac(..)) +-- >>> import qualified Prelude as P +-- >>> :load Data.Connection + + +-- | Semilattices. +-- +-- A complete is a partially ordered set in which every two elements have a unique join +-- (least upper bound or supremum) and a unique meet (greatest lower bound or infimum). +-- +-- These operations may in turn be defined by the lower and upper adjoints to the unique +-- function /a -> (a, a)/. +-- +-- /Associativity/ +-- +-- @ +-- x '\/' (y '\/' z) = (x '\/' y) '\/' z +-- x '/\' (y '/\' z) = (x '/\' y) '/\' z +-- @ +-- +-- /Commutativity/ +-- +-- @ +-- x '\/' y = y '\/' x +-- x '/\' y = y '/\' x +-- @ +-- +-- /Idempotency/ +-- +-- @ +-- x '\/' x = x +-- x '/\' x = x +-- @ +-- +-- /Absorption/ +-- +-- @ +-- (x '\/' y) '/\' y = y +-- (x '/\' y) '\/' y = y +-- @ +-- +-- See < https://en.wikipedia.org/wiki/Absorption_law Absorption >. +-- +-- Note that distributivity is _not_ a requirement for a complete. +-- However when /a/ is distributive we have; +-- +-- @ +-- 'glb' x y z = 'lub' x y z +-- @ +-- +-- See < https://en.wikipedia.org/wiki/Lattice_(order) >. +-- +type Semilattice k a = Connection k (a, a) a + +type Extremal k = Connection k () + +type ConnInteger k = Connection k (Maybe Integer) + +type ConnFloat k = Connection k Float + +type ConnDouble k = Connection k Double + +type ConnRational k = Connection k Rational + +type ConnExtended k a b = Connection k a (Extended b) + +-- | An < https://ncatlab.org/nlab/show/adjoint+string adjoint string > of Galois connections of length 2 or 3. +-- +class (Preorder a, Preorder b) => Connection k a b where + + -- | + -- + -- >>> range (conn @_ @Double @Float) pi + -- (3.1415925,3.1415927) + -- >>> range (conn @_ @Rational @Float) (1 :% 7) + -- (0.14285713,0.14285715) + -- >>> range (conn @_ @Rational @Float) (1 :% 8) + -- (0.125,0.125) + -- + conn :: Conn k a b + +-- | A constraint kind representing an of Galois connections. +-- +type Triple a b = (Connection 'L a b, Connection 'R a b) + + + +--------------------------------------------------------------------- +-- Connection L +--------------------------------------------------------------------- + +-- | A specialization of /conn/ to left-side connections. +-- +-- This is a convenience function provided primarily to avoid needing +-- to enable /DataKinds/. +-- +connL :: Connection 'L a b => ConnL a b +connL = conn @'L + +-- | Extract the center of a 'Trip' or upper half of a 'ConnL'. +-- +embedL :: Connection 'L a b => b -> a +embedL = embed connL + +-- | Extract the ceiling of a 'Trip' or lower half of a 'ConnL'. +-- +-- > ceiling @a @a = id +-- +-- >>> ceiling @Rational @Float (0 :% 0) +-- NaN +-- >>> ceiling @Rational @Float (1 :% 0) +-- Infinity +-- >>> ceiling @Rational @Float (13 :% 10) +-- 1.3000001 +-- +ceiling :: Connection 'L a b => a -> b +ceiling = lowerL connL + +-- | Lift a unary function over a 'ConnL'. +-- +ceiling1 :: Connection 'L a b => (a -> a) -> b -> b +ceiling1 = lowerL1 connL + +-- | Lift a binary function over a 'ConnL'. +-- +ceiling2 :: Connection 'L a b => (a -> a -> a) -> b -> b -> b +ceiling2 = lowerL2 connL + +-- | Obtain the principal filter in /B/ generated by an element of /A/. +-- +-- A subset /B/ of a lattice is an filter if and only if it is an upper set +-- that is closed under finite meets, i.e., it is nonempty and for all +-- /x/, /y/ in /B/, the element @x /\ y@ is also in /b/. +-- +-- /filterL/ and /filterR/ commute with /Down/: +-- +-- > filterL a b <=> filterR (Down a) (Down b) +-- +-- > filterL (Down a) (Down b) <=> filterR a b +-- +-- /filterL a/ is upward-closed for all /a/: +-- +-- > a <= b1 && b1 <= b2 => a <= b2 +-- +-- > a1 <= b && inf a2 <= b => ceiling a1 /\ ceiling a2 <= b +-- +-- See +-- +filterL :: Connection 'L a b => a -> b -> Bool +filterL a b = ceiling a <~ b + +-- | A minimal element of a preorder defined by a connection with '()'. +-- +-- 'minimal' needn't be unique, but we must have: +-- +-- > x <~ minimal => x ~~ minimal +-- +minimal :: Extremal 'L a => a +minimal = lowerL connL () + +infixr 5 \/ + +-- | Semigroup operation on a join-semilattice. +-- +-- > (\/) = curry $ lowerL forked +-- +(\/) :: Semilattice 'L a => a -> a -> a +(\/) = curry $ lowerL connL + +-- | Greatest lower bound operator. +-- +-- > glb x x y = x +-- > glb x y z = glb z x y +-- > glb x x y = x +-- > glb x y z = glb x z y +-- > glb (glb x w y) w z = glb x w (glb y w z) +-- +-- >>> glb 1.0 9.0 7.0 +-- 7.0 +-- >>> glb 1.0 9.0 (0.0 / 0.0) +-- 9.0 +-- >>> glb (fromList [1..3]) (fromList [3..5]) (fromList [5..7]) :: Set Int +-- fromList [3,5] +-- +glb :: Triple (a, a) a => a -> a -> a -> a +glb x y z = (x \/ y) /\ (y \/ z) /\ (z \/ x) + +--------------------------------------------------------------------- +-- Connection R +--------------------------------------------------------------------- + +-- | A specialization of /conn/ to right-side connections. +-- +-- This is a convenience function provided primarily to avoid needing +-- to enable /DataKinds/. +-- +connR :: Connection 'R a b => ConnR a b +connR = conn @'R + +-- | Extract the floor of a 'Trip' or upper half of a 'ConnL'. +-- +-- > floor @a @a = id +-- +-- >>> floor @Rational @Float (0 :% 0) +-- NaN +-- >>> floor @Rational @Float (1 :% 0) +-- Infinity +-- >>> floor @Rational @Float (13 :% 10) +-- 1.3 +-- +floor :: Connection 'R a b => a -> b +floor = upperR connR + +-- | Lift a unary function over a 'ConnR'. +-- +floor1 :: Connection 'R a b => (a -> a) -> b -> b +floor1 = upperR1 connR + +-- | Lift a binary function over a 'ConnR'. +-- +floor2 :: Connection 'R a b => (a -> a -> a) -> b -> b -> b +floor2 = upperR2 connR + +-- | Extract the center of a 'Trip' or lower half of a 'ConnR'. +-- +embedR :: Connection 'R a b => b -> a +embedR = embed connR + +-- | Obtain the principal ideal in /B/ generated by an element of /A/. +-- +-- A subset /B/ of a lattice is an ideal if and only if it is a lower set +-- that is closed under finite joins, i.e., it is nonempty and for all +-- /x/, /y/ in /B/, the element /x \/ y/ is also in /B/. +-- +-- /filterR a/ is downward-closed for all /a/: +-- +-- > a >= b1 && b1 >= b2 => a >= b2 +-- +-- > a1 >= b && a2 >= b => floor a1 \/ floor a2 >= b +-- +-- See +-- +filterR :: Connection 'R a b => a -> b -> Bool +filterR a b = b <~ floor a + +-- | A maximal element of a preorder defined by a connection with '()'. +-- +-- 'maximal' needn't be unique, but we must have: +-- +-- > x >~ maximal => x ~~ maximal +-- +maximal :: Extremal 'R a => a +maximal = upperR connR () + +infixr 6 /\ -- comment for the parser + +-- | Semigroup operation on a meet-semilattice. +-- +-- > (/\) = curry $ upperR forked +-- +(/\) :: Semilattice 'R a => a -> a -> a +(/\) = curry $ upperR connR + +-- | Least upper bound operator. +-- +-- The order dual of 'glb'. +-- +-- >>> lub 1.0 9.0 7.0 +-- 7.0 +-- >>> lub 1.0 9.0 (0.0 / 0.0) +-- 1.0 +-- +lub :: Triple (a, a) a => a -> a -> a -> a +lub x y z = (x /\ y) \/ (y /\ z) \/ (z /\ x) + +--------------------------------------------------------------------- +-- Connection +--------------------------------------------------------------------- + +maybeL :: Triple () b => Trip (Maybe a) (Either a b) +maybeL = trip f g h where + f = maybe (Right minimal) Left + g = either Just (const Nothing) + h = maybe (Right maximal) Left + +maybeR :: Triple () a => Trip (Maybe b) (Either a b) +maybeR = trip f g h where + f = maybe (Left minimal) Right + g = either (const Nothing) Just + h = maybe (Left maximal) Right + +--------------------------------------------------------------------- +-- Instances +--------------------------------------------------------------------- + +instance Preorder a => Connection k a a where + conn = C.id + +instance Connection 'R Word16 Word8 where + conn = swapR w08w16 + +instance Connection 'R Word32 Word8 where + conn = swapR w08w32 + +instance Connection 'R Word32 Word16 where + conn = swapR w16w32 + +instance Connection 'R Word64 Word8 where + conn = swapR w08w64 + +instance Connection 'R Word64 Word16 where + conn = swapR w16w64 + +instance Connection 'R Word64 Word32 where + conn = swapR w32w64 + +instance Connection k Word Word64 where + conn = wxxw64 + +instance Connection 'R Natural Word8 where + conn = swapR w08nat + +instance Connection 'R Natural Word16 where + conn = swapR w16nat + +instance Connection 'R Natural Word32 where + conn = swapR w32nat + +instance Connection 'R Natural Word64 where + conn = swapR w64nat + +instance Connection 'R Natural Word where + conn = swapR wxxnat + +instance Connection 'R Natural Integer where + conn = swapR intnat + +instance Connection 'R Int32 Int8 where + conn = swapR i08i32 + +instance Connection 'R Int32 Int16 where + conn = swapR i16i32 + +instance Connection 'R Int64 Int8 where + conn = swapR i08i64 + +instance Connection 'R Int64 Int16 where + conn = swapR i16i64 + +instance Connection 'R Int64 Int32 where + conn = swapR i32i64 + +instance Connection k Int Int64 where + conn = ixxi64 + +instance Connection 'R (Maybe Integer) Word8 where + conn = swapR $ w08nat >>> natint + +instance Connection 'R (Maybe Integer) Word16 where + conn = swapR $ w16nat >>> natint + +instance Connection 'R (Maybe Integer) Word32 where + conn = swapR $ w32nat >>> natint + +instance Connection 'R (Maybe Integer) Word64 where + conn = swapR $ w64nat >>> natint + +instance Connection 'R (Maybe Integer) Word where + conn = swapR $ wxxnat >>> natint + +instance Connection 'R (Maybe Integer) Natural where + conn = swapR natint + +instance Connection 'R (Maybe Integer) Int8 where + conn = swapR i08int + +instance Connection 'R (Maybe Integer) Int16 where + conn = swapR i16int + +instance Connection 'R (Maybe Integer) Int32 where + conn = swapR i32int + +instance Connection 'R (Maybe Integer) Int64 where + conn = swapR i64int + +instance Connection 'R (Maybe Integer) Int where + conn = swapR ixxint + +instance Connection 'R (Maybe Integer) Integer where + -- | Provided as a shim for /RebindableSyntax/. + -- Note that this instance will clip negative numbers to zero. + conn = swapR $ intnat >>> natint + +instance Connection k Int8 Word8 where + conn = i08w08 + +instance Connection k Int16 Word16 where + conn = i16w16 + +instance Connection k Int32 Word32 where + conn = i32w32 + +instance Connection k Int64 Word64 where + conn = i64w64 + +instance Connection k Int Word where + conn = ixxwxx + +instance Connection k Double Float where + conn = f64f32 + +instance Connection k Rational Float where + conn = ratf32 + +instance Connection k Rational Double where + conn = ratf64 + +instance Connection k Rational (Extended Int8) where + conn = rati08 + +instance Connection k Rational (Extended Int16) where + conn = rati16 + +instance Connection k Rational (Extended Int32) where + conn = rati32 + +instance Connection k Rational (Extended Int64) where + conn = rati64 + +instance Connection k Rational (Extended Int) where + conn = ratixx + +instance Connection k Rational (Extended Integer) where + conn = ratint + +instance Connection k Float (Extended Int8) where + conn = f32i08 + +instance Connection k Float (Extended Int16) where + conn = f32i16 + +instance Connection 'L Float (Extended Int32) where + conn = conn >>> fmapped (i16w16 >>> w16w32 >>> w32i32) + +instance Connection 'L Float (Extended Int64) where + conn = conn >>> fmapped (i16w16 >>> w16w64 >>> w64i64) + +instance Connection 'L Float (Extended Int) where + conn = conn >>> fmapped (i16w16 >>> w16wxx >>> swapL ixxwxx) + +instance Connection k Double (Extended Int8) where + conn = f64i08 + +instance Connection k Double (Extended Int16) where + conn = f64i16 + +instance Connection k Double (Extended Int32) where + conn = f64i32 + +instance Connection 'L Double (Extended Int64) where + conn = conn >>> fmapped (i32w32 >>> w32w64 >>> w64i64) + +instance Connection 'L Double (Extended Int) where + conn = conn >>> fmapped (i32w32 >>> w32wxx >>> swapL ixxwxx) + +instance Connection k a b => Connection k (Identity a) b where + conn = Conn runIdentity Identity runIdentity >>> conn + +instance Connection k a b => Connection k a (Identity b) where + conn = conn >>> Conn Identity runIdentity Identity + +--------------------------------------------------------------------- +-- +--------------------------------------------------------------------- + +fork :: a -> (a, a) +fork x = (x, x) + +semilatticeN5 :: (Total a, Fractional a) => Conn k (a, a) a +semilatticeN5 = Conn (uncurry joinN5) fork (uncurry meetN5) where + joinN5 x y = maybe (1 / 0) (bool y x . (>= EQ)) (pcompare x y) + + meetN5 x y = maybe (-1 / 0) (bool y x . (<= EQ)) (pcompare x y) + +extremalN5 :: (Total a, Fractional a) => Conn k () a +extremalN5 = Conn (const $ -1/0) (const ()) (const $ 1/0) + +semilatticeOrd :: (Total a) => Conn k (a, a) a +semilatticeOrd = Conn (uncurry max) fork (uncurry min) + +extremalOrd :: (Total a, P.Bounded a) => Conn k () a +extremalOrd = Conn (const minBound) (const ()) (const maxBound) + +instance Connection k ((),()) () where conn = semilatticeOrd +instance Connection k (Bool, Bool) Bool where conn = semilatticeOrd +instance Connection k () Bool where conn = extremalOrd +instance Connection k (Ordering, Ordering) Ordering where conn = semilatticeOrd +instance Connection k () Ordering where conn = extremalOrd + +instance Connection k (Word8, Word8) Word8 where conn = semilatticeOrd +instance Connection k () Word8 where conn = extremalOrd +instance Connection k (Word16, Word16) Word16 where conn = semilatticeOrd +instance Connection k () Word16 where conn = extremalOrd +instance Connection k (Word32, Word32) Word32 where conn = semilatticeOrd +instance Connection k () Word32 where conn = extremalOrd +instance Connection k (Word64, Word64) Word64 where conn = semilatticeOrd +instance Connection k () Word64 where conn = extremalOrd +instance Connection k (Word, Word) Word where conn = semilatticeOrd +instance Connection k () Word where conn = extremalOrd +instance Connection k (Natural, Natural) Natural where conn = semilatticeOrd + +instance Connection k (Positive, Positive) Positive where conn = semilatticeN5 +instance Connection k () Positive where + conn = Conn (const $ 0 :% 1) (const ()) (const $ 1 :% 0) + +instance Connection k (Int8, Int8) Int8 where conn = semilatticeOrd +instance Connection k () Int8 where conn = extremalOrd +instance Connection k (Int16, Int16) Int16 where conn = semilatticeOrd +instance Connection k () Int16 where conn = extremalOrd +instance Connection k (Int32, Int32) Int32 where conn = semilatticeOrd +instance Connection k () Int32 where conn = extremalOrd +instance Connection k (Int64, Int64) Int64 where conn = semilatticeOrd +instance Connection k () Int64 where conn = extremalOrd +instance Connection k (Int, Int) Int where conn = semilatticeOrd +instance Connection k () Int where conn = extremalOrd +instance Connection k (Integer, Integer) Integer where conn = semilatticeOrd + +instance Connection k (Rational, Rational) Rational where conn = semilatticeN5 +instance Connection k () Rational where + conn = Conn (const $ -1 :% 0) (const ()) (const $ 1 :% 0) + +instance Connection k (F.Finite n, F.Finite n) (F.Finite n) where conn = semilatticeOrd +instance KnownNat n => Connection k () (F.Finite n) where conn = extremalOrd + +instance Connection k (Float, Float) Float where conn = semilatticeN5 +instance Connection k () Float where conn = extremalN5 + +instance Connection k (Double, Double) Double where conn = semilatticeN5 +instance Connection k () Double where conn = extremalN5 + +instance Total a => Connection k (Set.Set a, Set.Set a) (Set.Set a) where + conn = Conn (uncurry Set.union) fork (uncurry Set.intersection) + +--instance (Total a, U.Finite a) => Connection k () (Set.Set a) where +-- conn = Conn (const Set.empty) (const ()) (const $ Set.fromList U.universeF) +instance (Total a) => Connection 'L () (Set.Set a) where + conn = ConnL (const Set.empty) (const ()) + +instance (Total a, U.Finite a) => Connection 'R () (Set.Set a) where + conn = ConnR (const ()) (const $ Set.fromList U.universeF) + +instance Connection k (IntSet.IntSet, IntSet.IntSet) IntSet.IntSet where + conn = Conn (uncurry IntSet.union) fork (uncurry IntSet.intersection) + +instance Connection k () IntSet.IntSet where + conn = Conn (const IntSet.empty) (const ()) (const $ IntSet.fromList U.universeF) + +instance (Total a, Connection 'L (b,b) b) => Connection 'L (Map.Map a b, Map.Map a b) (Map.Map a b) where + conn = ConnL (uncurry $ Map.unionWith (\/)) fork + +instance (Total a, Connection 'R (b,b) b) => Connection 'R (Map.Map a b, Map.Map a b) (Map.Map a b) where + conn = ConnR fork (uncurry $ Map.intersectionWith (/\)) + +instance (Total a, Preorder b) => Connection 'L () (Map.Map a b) where + conn = ConnL (const Map.empty) (const ()) + +instance (Total a, U.Finite a, Connection 'R () b) => Connection 'R () (Map.Map a b) where + conn = ConnR (const ()) (const . Map.fromList $ U.universeF `zip` repeat maximal) + +instance Connection 'L (a,a) a => Connection 'L (IntMap.IntMap a, IntMap.IntMap a) (IntMap.IntMap a) where + conn = ConnL (uncurry $ IntMap.unionWith (\/)) fork + +instance Connection 'R (a,a) a => Connection 'R (IntMap.IntMap a, IntMap.IntMap a) (IntMap.IntMap a) where + conn = ConnR fork (uncurry $ IntMap.intersectionWith (/\)) + +instance Preorder a => Connection 'L () (IntMap.IntMap a) where + conn = ConnL (const IntMap.empty) (const ()) + +instance Connection 'R () a => Connection 'R () (IntMap.IntMap a) where + conn = ConnR (const ()) (const . IntMap.fromList $ U.universeF `zip` repeat maximal) + +joinMaybe :: Connection 'L (a, a) a => Maybe a -> Maybe a -> Maybe a +joinMaybe (Just x) (Just y) = Just (x \/ y) +joinMaybe u@(Just _) _ = u +joinMaybe _ u@(Just _) = u +joinMaybe Nothing Nothing = Nothing + +meetMaybe :: Connection 'R (a, a) a => Maybe a -> Maybe a -> Maybe a +meetMaybe Nothing Nothing = Nothing +meetMaybe Nothing _ = Nothing +meetMaybe _ Nothing = Nothing +meetMaybe (Just x) (Just y) = Just (x /\ y) + +instance Connection 'L (a, a) a => Connection 'L (Maybe a, Maybe a) (Maybe a) where + conn = ConnL (uncurry joinMaybe) fork + +instance Connection 'R (a, a) a => Connection 'R (Maybe a, Maybe a) (Maybe a) where + conn = ConnR fork (uncurry meetMaybe) + +instance Preorder a => Connection 'L () (Maybe a) where + conn = ConnL (const Nothing) (const ()) + +instance Connection 'R () a => Connection 'R () (Maybe a) where + conn = ConnR (const ()) (const $ Just maximal) + +joinExtended :: Connection 'L (a, a) a => Extended a -> Extended a -> Extended a +joinExtended Top _ = Top +joinExtended _ Top = Top +joinExtended (Extended x) (Extended y) = Extended (x \/ y) +joinExtended Bottom y = y +joinExtended x Bottom = x + +meetExtended :: Connection 'R (a, a) a => Extended a -> Extended a -> Extended a +meetExtended Top y = y +meetExtended x Top = x +meetExtended (Extended x) (Extended y) = Extended (x /\ y) +meetExtended Bottom _ = Bottom +meetExtended _ Bottom = Bottom + +instance Connection 'L (a, a) a => Connection 'L (Extended a, Extended a) (Extended a) where + conn = ConnL (uncurry joinExtended) fork + +instance Connection 'R (a, a) a => Connection 'R (Extended a, Extended a) (Extended a) where + conn = ConnR fork (uncurry meetExtended) + +instance Preorder a => Connection k () (Extended a) where + conn = Conn (const Bottom) (const ()) (const Top) + +joinEither :: (Connection 'L (a, a) a, Connection 'L (b, b) b) => Either a b -> Either a b -> Either a b +joinEither (Right x) (Right y) = Right (x \/ y) +joinEither u@(Right _) _ = u +joinEither _ u@(Right _) = u +joinEither (Left x) (Left y) = Left (x \/ y) + +meetEither :: (Connection 'R (a, a) a, Connection 'R (b, b) b) => Either a b -> Either a b -> Either a b +meetEither (Left x) (Left y) = Left (x /\ y) +meetEither l@(Left _) _ = l +meetEither _ l@(Left _) = l +meetEither (Right x) (Right y) = Right (x /\ y) + +-- | All minimal elements of the upper lattice cover all maximal elements of the lower lattice. +instance (Connection 'L (a,a) a, Connection 'L (b,b) b) => Connection 'L (Either a b, Either a b) (Either a b) where + conn = ConnL (uncurry joinEither) fork + +instance (Connection 'R (a,a) a, Connection 'R (b,b) b) => Connection 'R (Either a b, Either a b) (Either a b) where + conn = ConnR fork (uncurry meetEither) + +instance (Connection 'L () a, Preorder b) => Connection 'L () (Either a b) where + conn = ConnL (const $ Left minimal) (const ()) + +instance (Preorder a, Connection 'R () b) => Connection 'R () (Either a b) where + conn = ConnR (const ()) (const $ Right maximal) + +joinTuple :: (Connection 'L (a, a) a, Connection 'L (b, b) b) => (a, b) -> (a, b) -> (a, b) +joinTuple (x1, y1) (x2, y2) = (x1 \/ x2, y1 \/ y2) + +meetTuple :: (Connection 'R (a, a) a, Connection 'R (b, b) b) => (a, b) -> (a, b) -> (a, b) +meetTuple (x1, y1) (x2, y2) = (x1 /\ x2, y1 /\ y2) + +instance (Triple (a, a) a, Triple (b, b) b) => Connection k ((a, b), (a, b)) (a, b) where + conn = Conn (uncurry joinTuple) fork (uncurry meetTuple) + +instance (Triple () a, Triple () b) => Connection k () (a, b) where + conn = Conn (const (minimal, minimal)) (const ()) (const (maximal, maximal)) + +instance (U.Finite a, Triple (b, b) b) => Connection k (a -> b, a -> b) (a -> b) where + conn = Conn (uncurry $ liftA2 (\/)) fork (uncurry $ liftA2 (/\)) + +instance (U.Finite a, Triple () b) => Connection k () (a -> b) where + conn = Conn (const $ pure minimal) (const ()) (const $ pure maximal) + +instance (U.Finite a, Triple (a, a) a) => Connection k (Endo a, Endo a) (Endo a) where + conn = Conn (\(Endo x, Endo y) -> Endo $ x\/y) fork (\(Endo x, Endo y) -> Endo $ x/\y) + +instance (U.Finite a, Triple () a) => Connection k () (Endo a) where + conn = Conn (const $ Endo minimal) (const ()) (const $ Endo maximal) + +instance (U.Finite a, Triple (b, b) b) => Connection k (Op b a, Op b a) (Op b a) where + conn = Conn (\(Op x, Op y) -> Op $ x\/y) fork (\(Op x, Op y) -> Op $ x/\y) + +instance (U.Finite a, Triple () b) => Connection k () (Op b a) where + conn = Conn (const $ Op minimal) (const ()) (const $ Op maximal) + +instance U.Finite a => Connection k (Predicate a, Predicate a) (Predicate a) where + conn = Conn (\(Predicate x, Predicate y) -> Predicate $ x\/y) fork (\(Predicate x, Predicate y) -> Predicate $ x/\y) + +instance U.Finite a => Connection k () (Predicate a) where + conn = Conn (const $ Predicate minimal) (const ()) (const $ Predicate maximal) + +{- +instance (Applicative m, Connection k r) => Connection k (ContT r m a) where + (<>) = liftA2 joinCont + +instance (Applicative m, Connection k () r) => Connection k () (ContT r m a) where + mempty = pure . ContT . const $ pure bottom + +instance Monad m => Connection k (SelectT r m a) where + (<>) = liftA2 joinSelect + +instance MonadPlus m => Connection k () (SelectT r m a)) where + bottom = pure empty +instance (Ord.Ord a, Preorder a, Preorder r, Finite r) => Preorder (Cont r a) where + (ContT x) <~ (ContT y) = x `contLe` y + +instance (Ord.Ord a, Preorder a, Preorder r, Finite r) => Preorder (Select r a) where + (SelectT x) <~ (SelectT y) = x `contLe` y +instance (Applicative m, Total a, Preorder r, Finite r, Connection 'L r) => Connection 'L (ContT r m a, ContT r m a) (ContT r m a) where + conn = ConnL (uncurry joinCont) fork + +joinCont :: (Applicative m, Connection 'L (r,r) r) => ContT r m a -> ContT r m a -> ContT r m a +joinCont (ContT f) (ContT g) = ContT $ \p -> liftA2 join (f p) (g p) + +instance (Monad m, Total a, Preorder r, Finite r, Extremal 'L r) => Connection 'L (SelectT r m a, SelectT r m a) (SelectT r m a) where + conn = ConnL (uncurry joinSelect) fork + +joinSelect :: (Monad m, Extremal 'L r) => SelectT r m b -> SelectT r m b -> SelectT r m b +joinSelect x y = branch x y >>= id + where + ifM c x y = c >>= \b -> if b then x else y + branch x y = SelectT $ \p -> ifM ((~~ maximal) <$> p x) (pure x) (pure y) + +-} diff --git a/src/Data/Connection/Conn.hs b/src/Data/Connection/Conn.hs new file mode 100644 --- /dev/null +++ b/src/Data/Connection/Conn.hs @@ -0,0 +1,377 @@ +{-# Language TypeFamilies #-} +{-# Language TypeApplications #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language ConstraintKinds #-} +{-# Language Safe #-} +{-# Language DeriveFunctor #-} +{-# Language DeriveGeneric #-} +{-# Language DataKinds #-} +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +{-# Language RankNTypes #-} +module Data.Connection.Conn ( + -- * Conn + Kan(..) + , Conn() + , embed + -- ** Trip + , type Trip + , pattern Conn + , trip + , range + -- ** ConnL + , type ConnL + , pattern ConnL + , swapL + , downL + , unitL + , counitL + , lowerL + , lowerL1 + , lowerL2 + , upperL1 + , upperL2 + -- ** ConnR + , type ConnR + , pattern ConnR + , swapR + , downR + , unitR + , counitR + , upperR + , upperR1 + , upperR2 + , lowerR1 + , lowerR2 + -- * Connections + , choice + , strong + , fmapped +) where + +import safe Control.Arrow +import safe Control.Category (Category) +import safe Data.Bifunctor (bimap) +import safe Data.Order +import safe Prelude hiding (Ord(..), Bounded) +import safe qualified Control.Category as C + +-- | A data kind distinguishing the chirality of a Kan extension. +-- +-- Here it serves to distinguish the directionality of a preorder: +-- +-- * /L/-tagged types are 'upwards-directed' +-- +-- * /R/-tagged types are 'downwards-directed' +-- +data Kan = L | R + +-- | An < https://ncatlab.org/nlab/show/adjoint+string adjoint string > of Galois connections of length 2 or 3. +-- +data Conn (k :: Kan) a b = Conn_ (a -> (b , b)) (b -> a) + +instance Category (Conn k) where + id = Conn_ (id &&& id) id + + Conn_ f1 g1 . Conn_ f2 g2 = Conn_ ((fst.f1).(fst.f2) &&& (snd.f1).(snd.f2)) (g2 . g1) + +-- | Obtain the center of a /Trip/, upper half of a /ConnL/, or the lower half of a /ConnR/. +-- +embed :: Conn k a b -> b -> a +embed (Conn_ _ g) = g + +-- Internal floor function. When \(f \dashv g \dashv h \) this is h. +_1 :: Conn k a b -> a -> b +_1 (Conn_ f _) = fst . f + +-- Internal ceiling function. When \(f \dashv g \dashv h \) this is f. +_2 :: Conn k a b -> a -> b +_2 (Conn_ f _) = snd . f + +--------------------------------------------------------------------- +-- Trip +--------------------------------------------------------------------- + +-- | An of Galois connections. +-- +-- An adjoint triple is a chain of connections of length 3: +-- +-- \(f \dashv g \dashv h \) +-- +-- For detailed properties see 'Data.Connection.Property'. +-- +type Trip a b = forall k. Conn k a b + +-- | A view pattern for an arbitrary (left or right) 'Conn'. +-- +-- /Caution/: /Conn f g h/ must obey \(f \dashv g \dashv h\). This condition is not checked. +-- +-- For detailed properties see 'Data.Connection.Property'. +-- +pattern Conn :: (a -> b) -> (b -> a) -> (a -> b) -> Conn k a b +pattern Conn f g h <- (embed &&& _1 &&& _2 -> (g, (h, f))) + where Conn f g h = Conn_ (h &&& f) g +{-# COMPLETE Conn #-} + +-- | Obtain a /forall k. Conn k/ from an adjoint triple of monotone functions. +-- +-- /Caution/: @Conn f g h@ must obey \(f \dashv g \dashv h\). This condition is not checked. +-- +trip :: (a -> b) -> (b -> a) -> (a -> b) -> Trip a b +trip f g h = Conn_ (h &&& f) g + +-- | Obtain the lower and upper functions from a 'Trip'. +-- +-- > range c = upperR c &&& lowerL c +-- +-- >>> range f64f32 pi +-- (3.1415925,3.1415927) +-- >>> range f64f32 (0/0) +-- (NaN,NaN) +-- +range :: Trip a b -> a -> (b, b) +range c = upperR c &&& lowerL c + +--------------------------------------------------------------------- +-- ConnL +--------------------------------------------------------------------- + +-- | A between two monotone functions. +-- +-- A Galois connection between /f/ and /g/, written \(f \dashv g \) +-- is an adjunction in the category of preorders. +-- +-- Each side of the connection may be defined in terms of the other: +-- +-- \( g(x) = \sup \{y \in E \mid f(y) \leq x \} \) +-- +-- \( f(x) = \inf \{y \in E \mid g(y) \geq x \} \) +-- +-- For further information see 'Data.Connection.Property'. +-- +-- /Caution/: Monotonicity is not checked. +-- +type ConnL = Conn 'L + +-- | A view pattern for a 'ConnL'. +-- +-- /Caution/: /ConnL f g/ must obey \(f \dashv g \). This condition is not checked. +-- +pattern ConnL :: (a -> b) -> (b -> a) -> ConnL a b +pattern ConnL f g <- (_2 &&& embed -> (f, g)) where ConnL f g = Conn_ (f &&& f) g +{-# COMPLETE ConnL #-} + +-- | Witness to the symmetry between 'ConnL' and 'ConnR'. +-- +-- > swapL . swapR = id +-- > swapR . swapL = id +-- +swapL :: ConnR a b -> ConnL b a +swapL (ConnR f g) = ConnL f g + +-- | Convert an arbitrary 'Conn' to an inverted 'ConnL'. +-- +-- >>> unitL (downL $ conn @_ @() @Ordering) (Down LT) +-- Down LT +-- >>> unitL (downL $ conn @_ @() @Ordering) (Down GT) +-- Down LT +-- +downL :: ConnL a b -> ConnL (Down b) (Down a) +downL (ConnL f g) = ConnL (\(Down x) -> Down $ g x) (\(Down x) -> Down $ f x) + +-- | Round trip through a connection. +-- +-- > unitL c = upperL1 c id = embed c . lowerL c +-- > x <= unitL c x +-- +-- >>> compare pi $ unitL f64f32 pi +-- LT +-- +unitL :: ConnL a b -> a -> a +unitL c = upperL1 c id + +-- | Reverse round trip through a connection. +-- +-- > x >= counitL c x +-- +-- >>> counitL (conn @_ @() @Ordering) LT +-- LT +-- >>> counitL (conn @_ @() @Ordering) GT +-- LT +-- +counitL :: ConnL a b -> b -> b +counitL c = lowerL1 c id + +-- | Extract the lower half of a 'Trip' or 'ConnL'. +-- +-- When /a/ and /b/ are lattices we have: +-- +-- > lowerL c (x1 \/ a2) = lowerL c x1 \/ lowerL c x2 +-- +-- This is the adjoint functor theorem for preorders. +-- +-- >>> upperR f64f32 pi +-- 3.1415925 +-- >>> lowerL f64f32 pi +-- 3.1415927 +-- +lowerL :: ConnL a b -> a -> b +lowerL (ConnL f _) = f + +-- | Map over a connection from the left. +-- +lowerL1 :: ConnL a b -> (a -> a) -> b -> b +lowerL1 (ConnL f g) h b = f $ h (g b) + +-- | Zip over a connection from the left. +-- +lowerL2 :: ConnL a b -> (a -> a -> a) -> b -> b -> b +lowerL2 (ConnL f g) h b1 b2 = f $ h (g b1) (g b2) + +-- | Map over a connection from the left. +-- +upperL1 :: ConnL a b -> (b -> b) -> a -> a +upperL1 (ConnL f g) h a = g $ h (f a) + +-- | Zip over a connection from the left. +-- +upperL2 :: ConnL a b -> (b -> b -> b) -> a -> a -> a +upperL2 (ConnL f g) h a1 a2 = g $ h (f a1) (f a2) + +--------------------------------------------------------------------- +-- ConnR +--------------------------------------------------------------------- + +-- | A Galois connection between two monotone functions. +-- +-- 'ConnR' is the mirror image of 'ConnL': +-- +-- > swapR :: ConnL a b -> ConnR b a +-- +-- If you only require one connection there is no particular reason to +-- use one version over the other. +-- +-- However some use cases (e.g. rounding) require an adjoint triple +-- of connections (i.e. a 'Trip') that can lower into a standard +-- connection in either of two ways. +-- +type ConnR = Conn 'R + +-- | A view pattern for a 'ConnR'. +-- +-- /Caution/: /ConnR f g/ must obey \(f \dashv g \). This condition is not checked. +-- +pattern ConnR :: (b -> a) -> (a -> b) -> ConnR a b +pattern ConnR f g <- (embed &&& _1 -> (f, g)) where ConnR f g = Conn_ (g &&& g) f +{-# COMPLETE ConnR #-} + +-- | Convert an arbitrary 'Conn' to an inverted 'ConnR'. +-- +-- >>> counitR (downR $ conn @_ @() @Ordering) (Down LT) +-- Down GT +-- >>> counitR (downR $ conn @_ @() @Ordering) (Down GT) +-- Down GT +-- +downR :: ConnR a b -> ConnR (Down b) (Down a) +downR (ConnR f g) = ConnR (\(Down x) -> Down $ g x) (\(Down x) -> Down $ f x) + +-- | Witness to the symmetry between 'ConnL' and 'ConnR'. +-- +-- > swapL . swapR = id +-- > swapR . swapL = id +-- +swapR :: ConnL a b -> ConnR b a +swapR (ConnL f g) = ConnR f g + +-- | Round trip through a connection. +-- +-- > unitR c = upperR1 c id = upperR c . embed c +-- > x <= unitR c x +-- +-- >>> unitR (conn @_ @() @Ordering) LT +-- GT +-- >>> unitR (conn @_ @() @Ordering) GT +-- GT +-- +unitR :: ConnR a b -> b -> b +unitR c = upperR1 c id + +-- | Reverse round trip through a connection. +-- +-- > x >= counitR c x +-- +-- >>> compare pi $ counitR f64f32 pi +-- GT +-- +counitR :: ConnR a b -> a -> a +counitR c = lowerR1 c id + +-- | Extract the upper half of a connection. +-- +-- When /a/ and /b/ are lattices we have: +-- +-- > upperR c (x1 /\ x2) = upperR c x1 /\ upperR c x2 +-- +-- This is the adjoint functor theorem for preorders. +-- +-- >>> upperR f64f32 pi +-- 3.1415925 +-- >>> lowerL f64f32 pi +-- 3.1415927 +-- +upperR :: ConnR a b -> a -> b +upperR (ConnR _ g) = g + +-- | Map over a connection from the left. +-- +upperR1 :: ConnR a b -> (a -> a) -> b -> b +upperR1 (ConnR f g) h b = g $ h (f b) + +-- | Zip over a connection from the left. +-- +upperR2 :: ConnR a b -> (a -> a -> a) -> b -> b -> b +upperR2 (ConnR f g) h b1 b2 = g $ h (f b1) (f b2) + +-- | Map over a connection from the right. +-- +lowerR1 :: ConnR a b -> (b -> b) -> a -> a +lowerR1 (ConnR f g) h a = f $ h (g a) + +-- | Zip over a connection from the right. +-- +lowerR2 :: ConnR a b -> (b -> b -> b) -> a -> a -> a +lowerR2 (ConnR f g) h a1 a2 = f $ h (g a1) (g a2) + +--------------------------------------------------------------------- +-- Connections +--------------------------------------------------------------------- + +-- | Lift two 'Conn's into a 'Conn' on the +-- +-- > (choice id) (ab >>> cd) = (choice id) ab >>> (choice id) cd +-- > (flip choice id) (ab >>> cd) = (flip choice id) ab >>> (flip choice id) cd +-- +choice :: Conn k a b -> Conn k c d -> Conn k (Either a c) (Either b d) +choice (Conn ab ba ab') (Conn cd dc cd') = Conn f g h where + f = either (Left . ab) (Right . cd) + g = either (Left . ba) (Right . dc) + h = either (Left . ab') (Right . cd') + +-- | Lift two 'Conn's into a 'Conn' on the +-- +-- > (strong id) (ab >>> cd) = (strong id) ab >>> (strong id) cd +-- > (flip strong id) (ab >>> cd) = (flip strong id) ab >>> (flip strong id) cd +-- +strong :: Conn k a b -> Conn k c d -> Conn k (a, c) (b, d) +strong (Conn ab ba ab') (Conn cd dc cd') = Conn f g h where + f = bimap ab cd + g = bimap ba dc + h = bimap ab' cd' + +-- | Lift a 'Conn' into a functor. +-- +-- /Caution/: This function will result in an invalid connection +-- if the functor alters the internal preorder (i.e. 'Data.Ord.Down'). +-- +fmapped :: Functor f => Conn k a b -> Conn k (f a) (f b) +fmapped (Conn f g h) = Conn (fmap f) (fmap g) (fmap h) diff --git a/src/Data/Connection/Double.hs b/src/Data/Connection/Double.hs new file mode 100644 --- /dev/null +++ b/src/Data/Connection/Double.hs @@ -0,0 +1,322 @@ +{-# Language ConstraintKinds #-} +{-# Language Safe #-} +{-# Language RankNTypes #-} +module Data.Connection.Double ( + f64f32 + , f64i08 + , f64i16 + , f64i32 + , min64 + , max64 + , ulp + , covers + , shift + , within + , epsilon + , until +) where + + +--import safe Data.Universe.Class +import safe Data.Bool +import safe Data.Connection.Conn +import safe Data.Int +import safe Data.Order +import safe Data.Order.Extended +import safe Data.Order.Syntax hiding (min, max) +import safe Data.Word +import safe GHC.Float as F +import safe Prelude hiding (Eq(..), Ord(..), until) +import safe qualified Data.Connection.Float as F32 +import safe qualified Prelude as P + +--------------------------------------------------------------------- +-- Connections +--------------------------------------------------------------------- + +f64f32 :: Conn k Double Float +f64f32 = Conn f1 g f2 where + f1 x = let est = F.double2Float x in + if g est >~ x + then est + else ascend32 est g x + + f2 x = let est = F.double2Float x in + if g est <~ x + then est + else descend32 est g x + + g = F.float2Double + + ascend32 z g1 y = until (\x -> g1 x >~ y) (<~) (F32.shift 1) z + + descend32 z h1 x = until (\y -> h1 y <~ x) (>~) (F32.shift (-1)) z + +-- | All 'Data.Int.Int08' values are exactly representable in a 'Double'. +f64i08 :: Conn k Double (Extended Int8) +f64i08 = triple 127 + +-- | All 'Data.Int.Int16' values are exactly representable in a 'Double'. +f64i16 :: Conn k Double (Extended Int16) +f64i16 = triple 32767 + +-- | All 'Data.Int.Int32' values are exactly representable in a 'Double'. +f64i32 :: Conn k Double (Extended Int32) +f64i32 = triple 2147483647 + + +--------------------------------------------------------------------- +-- Double +--------------------------------------------------------------------- + +-- | A /NaN/-handling min function. +-- +-- > min64 x NaN = x +-- > min64 NaN y = y +-- +min64 :: Double -> Double -> Double +min64 x y = case (isNaN x, isNaN y) of + (False, False) -> if x <= y then x else y + (False, True) -> x + (True, False) -> y + (True, True) -> x + +-- | A /NaN/-handling max function. +-- +-- > max64 x NaN = x +-- > max64 NaN y = y +-- +max64 :: Double -> Double -> Double +max64 x y = case (isNaN x, isNaN y) of + (False, False) -> if x >= y then x else y + (False, True) -> x + (True, False) -> y + (True, True) -> x + +-- | Covering relation on the /N5/ lattice of doubles. +-- +-- < https://en.wikipedia.org/wiki/Covering_relation > +-- +-- >>> covers 1 (shift 1 1) +-- True +-- >>> covers 1 (shift 2 1) +-- False +-- +covers :: Double -> Double -> Bool +covers x y = x ~~ shift (-1) y + +-- | Compute the signed distance between two doubles in units of least precision. +-- +-- >>> ulp 1.0 (shift 1 1.0) +-- Just (LT,1) +-- >>> ulp (0.0/0.0) 1.0 +-- Nothing +-- +ulp :: Double -> Double -> Maybe (Ordering, Word64) +ulp x y = fmap f $ pcompare x y + where x' = doubleInt64 x + y' = doubleInt64 y + f LT = (LT, fromIntegral . abs $ y' - x') + f EQ = (EQ, 0) + f GT = (GT, fromIntegral . abs $ x' - y') + +-- | Shift by /n/ units of least precision. +-- +-- >>> shift 1 0 +-- 1.0e-45 +-- >>> shift 1 $ 0/0 +-- NaN +-- >>> shift (-1) $ 0/0 +-- NaN +-- >>> shift 1 $ 1/0 +-- Infinity +-- +shift :: Int64 -> Double -> Double +shift n x | x ~~ 0/0 = x + | otherwise = int64Double . clamp64 . (+ n) . doubleInt64 $ x + +-- | Compare two double-precision floats for approximate equality. +-- +-- Required accuracy is specified in units of least precision. +-- +-- See also . +-- +within :: Word64 -> Double -> Double -> Bool +within tol x y = maybe False ((<= tol) . snd) $ ulp x y + +-- | Difference between 1 and the smallest representable value greater than 1. +-- +-- > epsilon = shift 1 1 - 1 +-- +-- >>> epsilon +-- 2.220446049250313e-16 +-- +epsilon :: Double +epsilon = shift 1 1.0 - 1.0 + +{- + +-- | Minimal positive value. +-- +-- >>> minimal64 +-- 5.0e-324 +-- >>> shift (-1) minimal64 +-- 0 +-- +minimal64 :: Double +minimal64 = shift 1 0.0 + +-- | Maximum finite value. +-- +-- >>> maximal64 +-- 1.7976931348623157e308 +-- >>> shift 1 maximal64 +-- Infinity +-- >>> shift (-1) $ negate maximal64 +-- -Infinity +-- +maximal64 :: Double +maximal64 = shift (-1) maxBound +-} +-------------------------------------------------------------------------------- +-- Orphans +--------------------------------------------------------------------- +{- +instance Universe Double where + universe = 0/0 : indexFromTo (minBound ... maxBound) + +instance Finite Double +-} +--------------------------------------------------------------------- +-- Internal +--------------------------------------------------------------------- + +{-# INLINE until #-} +until :: (a -> Bool) -> (a -> a -> Bool) -> (a -> a) -> a -> a +until pre rel f seed = go seed + where go x | x' `rel` x = x + | pre x = x + | otherwise = go x' + where x' = f x + + + + +-- Non-monotonic function +signed64 :: Word64 -> Int64 +signed64 x | x < 0x8000000000000000 = fromIntegral x + | otherwise = fromIntegral (maxBound P.- (x P.- 0x8000000000000000)) + +-- Non-monotonic function converting from 2s-complement format. +unsigned64 :: Int64 -> Word64 +unsigned64 x | x >~ 0 = fromIntegral x + | otherwise = 0x8000000000000000 + (maxBound P.- (fromIntegral x)) + +-- Clamp between the int representations of -1/0 and 1/0 +clamp64 :: Int64 -> Int64 +clamp64 = P.max (-9218868437227405313) . P.min 9218868437227405312 + +int64Double :: Int64 -> Double +int64Double = word64Double . unsigned64 + +doubleInt64 :: Double -> Int64 +doubleInt64 = signed64 . doubleWord64 + +-- Bit-for-bit conversion. +word64Double :: Word64 -> Double +word64Double = F.castWord64ToDouble + +-- TODO force to pos representation? +-- Bit-for-bit conversion. +doubleWord64 :: Double -> Word64 +doubleWord64 = (+0) . F.castDoubleToWord64 + +{- + +-- | Exact embedding up to the largest representable 'Int64'. +f64i64 :: Conn Double (Maybe Int64) +f64i64 = Conn (nanf f) (nan g) where + f x | abs x <~ 2**53-1 = P.ceiling x + | otherwise = if x >~ 0 then 2^53 else minBound + + g i | abs' i <~ 2^53-1 = fromIntegral i + | otherwise = if i >~ 0 then 1/0 else -2**53 + +-- | Exact embedding up to the largest representable 'Int64'. +i64f64 :: Conn (Maybe Int64) Double +i64f64 = Conn (nan g) (nanf f) where + f x | abs x <~ 2**53-1 = P.floor x + | otherwise = if x >~ 0 then maxBound else -2^53 + + g i | abs i <~ 2^53-1 = fromIntegral i + | otherwise = if i >~ 0 then 2**53 else -1/0 + +-- | Exact embedding up to the largest representable 'Int64'. +f64ixx :: Conn Double (Maybe Int) +f64ixx = Conn (nanf f) (nan g) where + f x | abs x <~ 2**53-1 = P.ceiling x + | otherwise = if x >~ 0 then 2^53 else minBound + + g i | abs' i <~ 2^53-1 = fromIntegral i + | otherwise = if i >~ 0 then 1/0 else -2**53 + +-- | Exact embedding up to the largest representable 'Int64'. +ixxf64 :: Conn (Maybe Int) Double +ixxf64 = Conn (nan g) (nanf f) where + f x | abs x <~ 2**53-1 = P.floor x + | otherwise = if x >~ 0 then maxBound else -2^53 + + g i | abs i <~ 2^53-1 = fromIntegral i + | otherwise = if i >~ 0 then 2**53 else -1/0 + +-} + + +{- +-- | +-- +-- @'lower64' x@ is the least element /y/ in the descending +-- chain such that @not $ f y '<~' x@. +-- +lower :: Preorder a => Double -> (Double -> a) -> a -> Double +lower z f x = until (\y -> f y <~ x) (>~) (shift $ -1) z + +-- | +-- +-- @'upper64' y@ is the greatest element /x/ in the ascending +-- chain such that @g x '<~' y@. +-- +upper :: Preorder a => Double -> (Double -> a) -> a -> Double +upper z g y = until (\x -> g x >~ y) (<~) (shift 1) z + +-- | +-- +-- @'lower' x@ is the least element /y/ in the descending +-- chain such that @not $ f y '<~' x@. +-- +lower :: Preorder a => Float -> (Float -> a) -> a -> Float +lower z f x = until (\y -> f y <~ x) (>~) (F32.shift $ -1) z + +-- | +-- +-- @'upper' y@ is the greatest element /x/ in the ascending +-- chain such that @not $ g x '>~' y@. +-- +upper :: Preorder a => Float -> (Float -> a) -> a -> Float +upper z g y = until (\x -> g x >~ y) (<~) (F32.shift 1) z +-} + + +--------------------------------------------------------------------- +-- Internal +--------------------------------------------------------------------- + +triple :: (Bounded a, Integral a) => Double -> Conn k Double (Extended a) +triple high = Conn f1 g f2 where + f1 = liftExtended (~~ -1/0) (\x -> x ~~ 0/0 || x > high) $ \x -> if x < low then minBound else P.ceiling x + + f2 = liftExtended (\x -> x ~~ 0/0 || x < low) (~~ 1/0) $ \x -> if x > high then maxBound else P.floor x + + g = extended (-1/0) (1/0) P.fromIntegral + + low = -1 - high diff --git a/src/Data/Connection/Float.hs b/src/Data/Connection/Float.hs --- a/src/Data/Connection/Float.hs +++ b/src/Data/Connection/Float.hs @@ -1,173 +1,216 @@ +{-# Language ConstraintKinds #-} +{-# Language Safe #-} module Data.Connection.Float ( - -- * Float + -- * Connections f32i08 , f32i16 - , f32i32 - , i32f32 - -- * Double - --, f64f32 - , f64i08 - , f64i16 - , f64i32 - , f64i64 - , i64f64 + --, f32i32 + , min32 + , max32 + , covers + , ulp + , shift + , within + , epsilon ) where -import Data.Connection -import Data.Float -import Data.Int -import Data.Prd -import Data.Prd.Nan -import Data.Semifield -import Data.Semilattice -import Data.Semilattice.Top -import Data.Semiring -import GHC.Real hiding ((^),(/)) -import Prelude as P hiding (Ord(..), Num(..), Fractional(..), (^), Bounded) - --- | All 'Int08' values are exactly representable in a 'Float'. -f32i08 :: Trip Float (Extended Int8) -f32i08 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling x - - g = bounded ninf P.fromIntegral pinf - - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor x +import safe Data.Bool +import safe Data.Connection.Conn +import safe Data.Int +import safe Data.Order +import safe Data.Order.Extended +import safe Data.Order.Syntax +import safe Data.Word +import safe GHC.Float as F +import safe Prelude hiding (Eq(..), Ord(..), until) +import safe qualified Prelude as P - imax = 127 +--------------------------------------------------------------------- +-- Float +--------------------------------------------------------------------- - imin = -128 +-- | A /NaN/-handling min32 function. +-- +-- > min32 x NaN = x +-- > min32 NaN y = y +-- +min32 :: Float -> Float -> Float +min32 x y = case (isNaN x, isNaN y) of + (False, False) -> if x <= y then x else y + (False, True) -> x + (True, False) -> y + (True, True) -> x --- | All 'Int16' values are exactly representable in a 'Float'. -f32i16 :: Trip Float (Extended Int16) -f32i16 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling x +-- | A /NaN/-handling max32 function. +-- +-- > max32 x NaN = x +-- > max32 NaN y = y +-- +max32 :: Float -> Float -> Float +max32 x y = case (isNaN x, isNaN y) of + (False, False) -> if x >= y then x else y + (False, True) -> x + (True, False) -> y + (True, True) -> x - g = bounded ninf P.fromIntegral pinf +-- | Covering relation on the /N5/ lattice of floats. +-- +-- < https://en.wikipedia.org/wiki/Covering_relation > +-- +-- >>> covers 1 (shift 1 1) +-- True +-- >>> covers 1 (shift 2 1) +-- False +-- +covers :: Float -> Float -> Bool +covers x y = x ~~ shift (-1) y - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor x +-- | Compute the signed distance between two floats in units of least precision. +-- +-- >>> ulp 1.0 (shift 1 1.0) +-- Just (LT,1) +-- >>> ulp (0.0/0.0) 1.0 +-- Nothing +-- +ulp :: Float -> Float -> Maybe (Ordering, Word32) +ulp x y = fmap f $ pcompare x y + where x' = floatInt32 x + y' = floatInt32 y + f LT = (LT, fromIntegral . abs $ y' - x') + f EQ = (EQ, 0) + f GT = (GT, fromIntegral . abs $ x' - y') - imax = 32767 +-- | Shift a float by /n/ units of least precision. +-- +-- >>> shift 1 0 +-- 1.0e-45 +-- >>> shift 1 $ 0/0 +-- NaN +-- >>> shift (-1) $ 0/0 +-- NaN +-- >>> shift 1 $ 1/0 +-- Infinity +-- +shift :: Int32 -> Float -> Float +shift n x | x ~~ 0/0 = x + | otherwise = int32Float . clamp32 . (+ n) . floatInt32 $ x - imin = -32768 +-- | Compare two floats for approximate equality. +-- +-- Required accuracy is specified in units of least precision. +-- +-- See also . +-- +within :: Word32 -> Float -> Float -> Bool +within tol x y = maybe False ((<= tol) . snd) $ ulp x y --- | Exact embedding up to the largest representable 'Int32'. -f32i32 :: Conn Float (Nan Int32) -f32i32 = Conn (liftNan f) (nan' g) where - f x | abs x <= 2**24-1 = P.ceiling x - | otherwise = if x >= 0 then 2^24 else minimal +-- | Difference between 1 and the smallest representable value greater than 1. +-- +-- > epsilon = shift 1 1 - 1 +-- +-- >>> epsilon +-- 1.1920929e-7 +-- +epsilon :: Float +epsilon = shift 1 1.0 - 1.0 - g i | abs' i <= 2^24-1 = fromIntegral i - | otherwise = if i >= 0 then 1/0 else -2**24 +{- +-- | Minimal32 positive value. +-- +-- >>> minimal32 +-- 1.0e-45 +-- >>> shift (-1) minimal32 +-- 0 +-- +minimal32 :: Float +minimal32 = shift 1 0.0 --- | Exact embedding up to the largest representable 'Int32'. -i32f32 :: Conn (Nan Int32) Float -i32f32 = Conn (nan' g) (liftNan f) where - f x | abs x <= 2**24-1 = P.floor x - | otherwise = if x >= 0 then maximal else -2^24 +-- | Maximum finite value. +-- +-- >>> maximal32 +-- 3.4028235e38 +-- >>> shift 1 maximal32 +-- Infinity +-- >>> shift (-1) $ negate maximal32 +-- -Infinity +-- +maximal32 :: Float +maximal32 = shift (-1) (1/0) - g i | abs i <= 2^24-1 = fromIntegral i - | otherwise = if i >= 0 then 2**24 else -1/0 +-} --------------------------------------------------------------------- --- Double +-- Float --------------------------------------------------------------------- +-- | All 'Data.Int.Int08' values are exactly representable in a 'Float'. +f32i08 :: Conn k Float (Extended Int8) +f32i08 = signedTriple 127 --- | All 'Int8' values are exactly representable in a 'Double'. -f64i08 :: Trip Double (Extended Int8) -f64i08 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling x +-- | All 'Data.Int.Int16' values are exactly representable in a 'Float'. +f32i16 :: Conn k Float (Extended Int16) +f32i16 = signedTriple 32767 - g = bounded ninf P.fromIntegral pinf +{- +-- | Exact embedding up to the largest representable 'Int32'. +f32i32 :: ConnL Float (Maybe Int32) +f32i32 = Conn (nanf f) (nan g) where + f x | abs x <~ 2**24-1 = P.ceiling x + | otherwise = if x >~ 0 then 2^24 else minBound - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor x + g i | abs' i <~ 2^24-1 = fromIntegral i + | otherwise = if i >~ 0 then 1/0 else -2**24 - imax = 127 - imin = -128 - --- | All 'Int16' values are exactly representable in a 'Double'. -f64i16 :: Trip Double (Extended Int16) -f64i16 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling x - - g = bounded ninf P.fromIntegral pinf +-- | Exact embedding up to the largest representable 'Int32'. +i32f32 :: ConnL (Maybe Int32) Float +i32f32 = Conn (nan g) (nanf f) where + f x | abs x <~ 2**24-1 = P.floor x + | otherwise = if x >~ 0 then maxBound else -2^24 - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor x + g i | abs i <~ 2^24-1 = fromIntegral i + | otherwise = if i >~ 0 then 2**24 else -1/0 +-} - imax = 32767 +--------------------------------------------------------------------- +-- Internal +--------------------------------------------------------------------- - imin = -32768 +signedTriple :: (Bounded a, Integral a) => Float -> Conn k Float (Extended a) +signedTriple high = Conn f g h where --- | All 'Int32' values are exactly representable in a 'Double'. -f64i32 :: Trip Double (Extended Int32) -f64i32 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling x + f = liftExtended (~~ -1/0) (\x -> x ~~ 0/0 || x > high) $ \x -> if x < low then minBound else P.ceiling x - g = bounded ninf P.fromIntegral pinf + g = extended (-1/0) (1/0) P.fromIntegral + + h = liftExtended (\x -> x ~~ 0/0 || x < low) (~~ 1/0) $ \x -> if x > high then maxBound else P.floor x - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor x + low = -1 - high - imax = 2147483647 +-- Non-monotonic function +signed32 :: Word32 -> Int32 +signed32 x | x < 0x80000000 = fromIntegral x + | otherwise = fromIntegral (maxBound - (x - 0x80000000)) - imin = -2147483648 +-- Non-monotonic function converting from 2s-complement format. +unsigned32 :: Int32 -> Word32 +unsigned32 x | x >= 0 = fromIntegral x + | otherwise = 0x80000000 + (maxBound - (fromIntegral x)) --- | Exact embedding up to the largest representable 'Int64'. -f64i64 :: Conn Double (Nan Int64) -f64i64 = Conn (liftNan f) (nan' g) where - f x | abs x <= 2**53-1 = P.ceiling x - | otherwise = if x >= 0 then 2^53 else minimal +-- Clamp between the int representations of -1/0 and 1/0 +clamp32 :: Int32 -> Int32 +clamp32 = P.max (-2139095041) . P.min 2139095040 - g i | abs' i <= 2^53-1 = fromIntegral i - | otherwise = if i >= 0 then 1/0 else -2**53 - --- | Exact embedding up to the largest representable 'Int64'. -i64f64 :: Conn (Nan Int64) Double -i64f64 = Conn (nan' g) (liftNan f) where - f x | abs x <= 2**53-1 = P.floor x - | otherwise = if x >= 0 then maximal else -2^53 +int32Float :: Int32 -> Float +int32Float = word32Float . unsigned32 - g i | abs i <= 2^53-1 = fromIntegral i - | otherwise = if i >= 0 then 2**53 else -1/0 +floatInt32 :: Float -> Int32 +floatInt32 = signed32 . floatWord32 -abs' :: Ord a => Minimal a => Ring a => a -> a -abs' x = if x =~ minimal then abs (x+one) else abs x +-- Bit-for-bit conversion. +word32Float :: Word32 -> Float +word32Float = F.castWord32ToFloat -{- slightly broken -f32w08 :: Trip Float (Nan Word8) -f32w08 = Trip (liftNan f) (nan (0/0) g) (liftNan h) where - h x = if x > 0 then 0 else connr w08w32 $ B.shift (floatWord32 x) (-23) - g = word32Float . flip B.shift 23 . connl w08w32 - f x = 1 + min 254 (h x) --} +-- Bit-for-bit conversion. +floatWord32 :: Float -> Word32 +floatWord32 = (+0) . F.castFloatToWord32 diff --git a/src/Data/Connection/Int.hs b/src/Data/Connection/Int.hs --- a/src/Data/Connection/Int.hs +++ b/src/Data/Connection/Int.hs @@ -1,161 +1,164 @@ --- Note that in most cases the obvious implementation is not a valid --- Galois connection. For example: --- --- @ --- i08i16 = Conn fromIntegral (fromIntegral . min 127 . max (-1208)) --- @ --- +{-# Language ConstraintKinds #-} +{-# Language Safe #-} module Data.Connection.Int ( - ConnInteger(..) - , fromInteger -- * Int8 + i08c08 , i08w08 - , i08w08' , i08i16 , i08i32 , i08i64 , i08int -- * Int16 + , i16c16 , i16w16 - , i16w16' , i16i32 , i16i64 , i16int -- * Int32 + , i32c32 , i32w32 - , i32w32' , i32i64 , i32int -- * Int64 + , i64c64 , i64w64 - , i64w64' , i64int -- * Int , ixxwxx + , ixxi64 + , ixxint -- * Integer , intnat , natint ) where -import Control.Category ((>>>)) -import Data.Connection -import Data.Connection.Word -import Data.Int -import Data.Prd -import Data.Semilattice.Top -import Data.Word -import Numeric.Natural +import safe Control.Category ((>>>)) +import safe Control.Applicative +import safe Control.Monad +import safe Data.Connection.Conn +import safe Data.Connection.Word +import safe Data.Int +import safe Data.Order.Syntax +import safe Data.Word +import safe Foreign.C.Types +import safe Numeric.Natural +import safe Prelude hiding (Eq(..), Ord(..), Bounded) +import safe qualified Prelude as P -import Prelude hiding (Num(..), (^), Bounded) -import qualified Prelude as P +i08c08 :: ConnL Int8 CChar +i08c08 = ConnL CChar $ \(CChar x) -> x -class Prd a => ConnInteger a where - intxxx :: Conn (Bounded Integer) a +i08w08 :: Conn k Int8 Word8 +i08w08 = unsigned -instance ConnInteger Int8 where - intxxx = tripr i08int +i08int :: ConnL Int8 (Maybe Integer) +i08int = signed -instance ConnInteger Int16 where - intxxx = tripr i16int +i16c16 :: ConnL Int16 CShort +i16c16 = ConnL CShort $ \(CShort x) -> x -instance ConnInteger Int32 where - intxxx = tripr i32int +i16w16 :: Conn k Int16 Word16 +i16w16 = unsigned -instance ConnInteger Int64 where - intxxx = tripr i64int +i16int :: ConnL Int16 (Maybe Integer) +i16int = signed -instance ConnInteger Word8 where - intxxx = tripr i08int >>> i08w08 +i32c32 :: ConnL Int32 CInt +i32c32 = ConnL CInt $ \(CInt x) -> x -instance ConnInteger Word16 where - intxxx = tripr i16int >>> i16w16 +i32w32 :: Conn k Int32 Word32 +i32w32 = unsigned -instance ConnInteger Word32 where - intxxx = tripr i32int >>> i32w32 +i32int :: ConnL Int32 (Maybe Integer) +i32int = signed -instance ConnInteger Word64 where - intxxx = tripr i64int >>> i64w64 +i64c64 :: ConnL Int64 CLong +i64c64 = ConnL CLong $ \(CLong x) -> x --- | Lawful replacement for the version in base. --- -fromInteger :: ConnInteger a => Integer -> a -fromInteger = connl intxxx . Just . Fin +i64w64 :: Conn k Int64 Word64 +i64w64 = unsigned -unsigned :: (Bound a, Integral a, Integral b) => Conn a b -unsigned = Conn (\y -> fromIntegral (y P.+ maximal P.+ 1)) - (\x -> fromIntegral x P.- minimal) +-- | /Caution/: This assumes that 'Int' on your system is 64 bits. +ixxi64 :: Conn k Int Int64 +ixxi64 = Conn fromIntegral fromIntegral fromIntegral -i08w08' :: Conn Int8 Word8 -i08w08' = unsigned +i64int :: ConnL Int64 (Maybe Integer) +i64int = signed -i08w08 :: Conn Int8 Word8 -i08w08 = Conn (fromIntegral . max 0) (fromIntegral . min 127) +ixxwxx :: Conn k Int Word +ixxwxx = unsigned -i08i16 :: Conn Int8 Int16 -i08i16 = i08w08' >>> w08w16 >>> w16i16 +-- | /Caution/: This assumes that 'Int' on your system is 64 bits. +ixxint :: ConnL Int (Maybe Integer) +ixxint = signed -i08i32 :: Conn Int8 Int32 -i08i32 = i08w08' >>> w08w32 >>> w32i32 +intnat :: ConnL Integer Natural +intnat = ConnL (fromIntegral . max 0) fromIntegral -i08i64 :: Conn Int8 Int64 -i08i64 = i08w08' >>> w08w64 >>> w64i64 +natint :: ConnL Natural (Maybe Integer) +natint = ConnL (fmap fromIntegral . fromPred (==0)) (maybe 0 $ P.fromInteger . max 0) -i08int :: Trip Int8 (Bounded Integer) -i08int = Trip (liftBottom' fromIntegral) - (bounded' $ P.fromInteger . min 127 . max (-128)) - (liftTop' fromIntegral) +i08i16 :: ConnL Int8 Int16 +i08i16 = i08w08 >>> w08w16 >>> w16i16 -i16w16' :: Conn Int16 Word16 -i16w16' = unsigned +i08i32 :: ConnL Int8 Int32 +i08i32 = i08w08 >>> w08w32 >>> w32i32 -i16w16 :: Conn Int16 Word16 -i16w16 = Conn (fromIntegral . max 0) (fromIntegral . min 32767) +i08i64 :: ConnL Int8 Int64 +i08i64 = i08w08 >>> w08w64 >>> w64i64 -i16i32 :: Conn Int16 Int32 -i16i32 = i16w16' >>> w16w32 >>> w32i32 +i16i32 :: ConnL Int16 Int32 +i16i32 = i16w16 >>> w16w32 >>> w32i32 -i16i64 :: Conn Int16 Int64 -i16i64 = i16w16' >>> w16w64 >>> w64i64 +i16i64 :: ConnL Int16 Int64 +i16i64 = i16w16 >>> w16w64 >>> w64i64 -i16int :: Trip Int16 (Bounded Integer) -i16int = Trip (liftBottom' fromIntegral) - (bounded' $ P.fromInteger . min 32767 . max (-32768)) - (liftTop' fromIntegral) +i32i64 :: ConnL Int32 Int64 +i32i64 = i32w32 >>> w32w64 >>> w64i64 -i32w32' :: Conn Int32 Word32 -i32w32' = unsigned +--------------------------------------------------------------------- +-- Internal +--------------------------------------------------------------------- -i32w32 :: Conn Int32 Word32 -i32w32 = Conn (fromIntegral . max 0) (fromIntegral . min 2147483647) -i32i64 :: Conn Int32 Int64 -i32i64 = i32w32' >>> w32w64 >>> w64i64 +fromPred :: Alternative f => (t -> Bool) -> t -> f t +fromPred p a = a <$ guard (p a) -i32int :: Trip Int32 (Bounded Integer) -i32int = Trip (liftBottom' fromIntegral) - (bounded' $ P.fromInteger . min 2147483647 . max (-2147483648)) - (liftTop' fromIntegral) +unsigned :: (P.Bounded a, Integral a, Integral b) => Conn k a b +unsigned = Conn f g f where + f y = fromIntegral (y + P.maxBound + 1) + g x = fromIntegral x - P.minBound -i64w64' :: Conn Int64 Word64 -i64w64' = unsigned +signed :: forall a. (P.Bounded a, Integral a) => ConnL a (Maybe Integer) +signed = ConnL f g where + f = fmap fromIntegral . fromPred (==P.minBound) + g = maybe P.minBound $ P.fromInteger . min (fromIntegral @a P.maxBound) . max (fromIntegral @a P.minBound) -i64w64 :: Conn Int64 Word64 -i64w64 = Conn (fromIntegral . max 0) (fromIntegral . min 9223372036854775807) +{- -i64int :: Trip Int64 (Bounded Integer) -i64int = Trip (liftBottom' fromIntegral) - (bounded' $ P.fromInteger . min 9223372036854775807 . max (-9223372036854775808)) - (liftTop' fromIntegral) -ixxwxx :: Conn Int Word -ixxwxx = unsigned +clip08 :: Integer -> Integer +clip08 = min 127 . max (-128) -intnat :: Conn Integer Natural -intnat = Conn (fromIntegral . max 0) fromIntegral +clip16 :: Integer -> Integer +clip16 = min 32767 . max (-32768) -natint :: Conn Natural (Maybe Integer) -natint = Conn f (maybe minimal g) where - f i | i == 0 = Nothing - | otherwise = Just $ fromIntegral i +clip32 :: Integer -> Integer +clip32 = min 2147483647 . max (-2147483648) - g = P.fromInteger . max 0 +clip64 :: Integer -> Integer +clip64 = min 9223372036854775807 . max (-9223372036854775808) + +unsigned :: (Bounded a, Preorder b, Integral a, Integral b) => ConnL a b +unsigned = ConnL f g where + f = fromIntegral . max 0 + g = fromIntegral . min (f P.maxBound) + +signed' :: forall a k. (Bounded a, Integral a) => Conn k a (Extended Integer) +signed' = Conn f g h where + f = liftExtended (~~ P.minBound) (const False) fromIntegral + g = extended P.minBound P.maxBound $ P.fromInteger . min (fromIntegral @a P.maxBound) . max (fromIntegral @a P.minBound) + h = liftExtended (const False) (~~ P.maxBound) fromIntegral +-} + + diff --git a/src/Data/Connection/Property.hs b/src/Data/Connection/Property.hs --- a/src/Data/Connection/Property.hs +++ b/src/Data/Connection/Property.hs @@ -1,88 +1,143 @@ +{-# Language DataKinds #-} {-# Language TypeFamilies #-} {-# Language TypeApplications #-} +{-# Language ConstraintKinds #-} +{-# Language RankNTypes #-} + +-- | Galois connections have the same properties as adjunctions defined over other categories: +-- +-- \( \forall x, y : f \dashv g \Rightarrow f (x) \leq b \Leftrightarrow x \leq g (y) \) +-- +-- \( \forall x, y : x \leq y \Rightarrow f (x) \leq f (y) \) +-- +-- \( \forall x, y : x \leq y \Rightarrow g (x) \leq g (y) \) +-- +-- \( \forall x : f \dashv g \Rightarrow x \leq g \circ f (x) \) +-- +-- \( \forall x : f \dashv g \Rightarrow f \circ g (x) \leq x \) +-- +-- \( \forall x : unit \circ unit (x) \sim unit (x) \) +-- +-- \( \forall x : counit \circ counit (x) \sim counit (x) \) +-- +-- \( \forall x : counit \circ f (x) \sim f (x) \) +-- +-- \( \forall x : unit \circ g (x) \sim g (x) \) +-- module Data.Connection.Property where -import Data.Prd +import Data.Order +import Data.Order.Property import Data.Connection -import Prelude hiding (Num(..),Ord(..)) - -import qualified Test.Function.Idempotent as Prop -import qualified Test.Function.Invertible as Prop -import qualified Test.Function.Monotone as Prop +import Data.Connection.Conn +import Prelude hiding (Num(..),Ord(..), floor, ceiling) -- | \( \forall x, y : f \dashv g \Rightarrow f (x) \leq y \Leftrightarrow x \leq g (y) \) -- --- A Galois connection. This is a required property. +-- A Galois connection is an adjunction of preorders. This is a required property. -- -connection :: Prd a => Prd b => Conn a b -> a -> b -> Bool -connection (Conn f g) = Prop.adjoint_on (<=) (<=) f g +adjoint :: (Preorder a, Preorder b) => Trip a b -> a -> b -> Bool +adjoint t a b = adjointL t a b && + adjointR t a b && + adjointL (swapL t) b a && + adjointR (swapR t) b a --- | \( \forall x : f \dashv g \Rightarrow x \leq g \circ f (x) \) --- --- This is a required property. --- -closed :: Prd a => Prd b => Conn a b -> a -> Bool -closed (Conn f g) = Prop.invertible_on (>=) f g +adjointL :: (Preorder a, Preorder b) => ConnL a b -> a -> b -> Bool +adjointL (ConnL f g) = adjunction (<~) (<~) f g +adjointR :: (Preorder a, Preorder b) => ConnR a b -> a -> b -> Bool +adjointR (ConnR f g) = adjunction (>~) (>~) g f + -- | \( \forall x : f \dashv g \Rightarrow x \leq g \circ f (x) \) -- -- This is a required property. -- -closed' :: Prd a => Prd b => Trip a b -> a -> Bool -closed' t x = closed (tripl t) x && kernel (tripr t) x +closed :: (Preorder a, Preorder b) => Trip a b -> a -> Bool +closed t a = closedL t a && closedR t a --- | \( \forall x : f \dashv g \Rightarrow f \circ g (x) \leq x \) --- --- This is a required property. --- -kernel :: Prd a => Prd b => Conn a b -> b -> Bool -kernel (Conn f g) = Prop.invertible_on (<=) g f +closedL :: (Preorder a, Preorder b) => ConnL a b -> a -> Bool +closedL (ConnL f g) = invertible (>~) f g +closedR :: (Preorder a, Preorder b) => ConnR a b -> a -> Bool +closedR (ConnR f g) = invertible (<~) g f + -- | \( \forall x : f \dashv g \Rightarrow x \leq g \circ f (x) \) -- -- This is a required property. -- -kernel' :: Prd a => Prd b => Trip a b -> b -> Bool -kernel' t x = closed (tripr t) x && kernel (tripl t) x +kernel :: (Preorder a, Preorder b) => Trip a b -> b -> Bool +kernel t b = kernelL t b && kernelR t b --- | \( \forall x, y : x \leq y \Rightarrow g (x) \leq g (y) \) --- --- This is a required property. --- -monotoner :: Prd a => Prd b => Conn a b -> b -> b -> Bool -monotoner (Conn _ g) = Prop.monotone_on (<=) (<=) g +kernelL :: (Preorder a, Preorder b) => ConnL a b -> b -> Bool +kernelL (ConnL f g) = invertible (<~) g f +kernelR :: (Preorder a, Preorder b) => ConnR a b -> b -> Bool +kernelR (ConnR f g) = invertible (>~) f g + -- | \( \forall x, y : x \leq y \Rightarrow f (x) \leq f (y) \) -- -- This is a required property. -- -monotonel :: Prd a => Prd b => Conn a b -> a -> a -> Bool -monotonel (Conn f _) = Prop.monotone_on (<=) (<=) f +monotonic :: (Preorder a, Preorder b) => Trip a b -> a -> a -> b -> b -> Bool +monotonic t a1 a2 b1 b2 = monotonicL t a1 a2 b1 b2 && monotonicR t a1 a2 b1 b2 --- | \( \forall x : f \dashv g \Rightarrow unit \circ unit (x) \sim unit (x) \) +monotonicR :: (Preorder a, Preorder b) => ConnR a b -> a -> a -> b -> b -> Bool +monotonicR (ConnR f g) a1 a2 b1 b2 = monotone (<~) (<~) g a1 a2 && monotone (<~) (<~) f b1 b2 + +monotonicL :: (Preorder a, Preorder b) => ConnL a b -> a -> a -> b -> b -> Bool +monotonicL (ConnL f g) a1 a2 b1 b2 = monotone (<~) (<~) f a1 a2 && monotone (<~) (<~) g b1 b2 + +-- | \( \forall x: f \dashv g \Rightarrow counit \circ f (x) \sim f (x) \wedge unit \circ g (x) \sim g (x) \) -- --- This is a required property. +-- See -- -idempotent_unit :: Prd a => Prd b => Conn a b -> a -> Bool -idempotent_unit conn = Prop.idempotent_on (=~) $ unit conn +idempotent :: (Preorder a, Preorder b) => Trip a b -> a -> b -> Bool +idempotent t a b = idempotentL t a b && idempotentR t a b --- | \( \forall x : f \dashv g \Rightarrow counit \circ counit (x) \sim counit (x) \) +idempotentL :: (Preorder a, Preorder b) => ConnL a b -> a -> b -> Bool +idempotentL c@(ConnL f g) a b = projective (~~) g (unitL c) b && projective (~~) f (counitL c) a + +idempotentR :: (Preorder a, Preorder b) => ConnR a b -> a -> b -> Bool +idempotentR c@(ConnR f g) a b = projective (~~) g (unitR c) a && projective (~~) f (counitR c) b + +--------------------------------------------------------------------- +-- Properties of general relations +--------------------------------------------------------------------- + +-- | \( \forall a, b: a \leq b \Rightarrow f(a) \leq f(b) \) -- --- This is a required property. +monotone :: Rel r Bool -> Rel s Bool -> (r -> s) -> r -> r -> Bool +monotone (#) (%) f a b = a # b ==> f a % f b + +-- | \( \forall a, b: a \leq b \Rightarrow f(b) \leq f(a) \) -- -idempotent_counit :: Prd a => Prd b => Conn a b -> b -> Bool -idempotent_counit conn = Prop.idempotent_on (=~) $ counit conn +antitone :: Rel r Bool -> Rel s Bool -> (r -> s) -> r -> r -> Bool +antitone (#) (%) f a b = a # b ==> f b % f a --- | \( \forall x: f \dashv g \Rightarrow counit \circ f (x) \sim f (x) \) +-- | \( \forall a: f a \leq b \Leftrightarrow a \leq g b \) -- --- See +-- For example, a monotone Galois connection is defined by @adjunction (<~) (<~)@, +-- and an antitone Galois connection is defined by @adjunction (>~) (<~)@. -- -projectivel :: Prd a => Prd b => Conn a b -> a -> Bool -projectivel conn@(Conn f _) = Prop.projective_on (=~) f $ counit conn +adjunction :: Rel r Bool -> Rel s Bool -> (s -> r) -> (r -> s) -> s -> r -> Bool +adjunction (#) (%) f g a b = f a # b <=> a % g b --- | \( \forall x: f \dashv g \Rightarrow unit \circ g (x) \sim g (x) \) +range' :: Triple () a => (a, a) +range' = (floor (), ceiling ()) + +ordering :: Trip () Ordering +ordering = trip (const GT) (const ()) (const LT) +--extremalOrd :: (Total a, P.Bounded a) => Conn k () a +--extremalOrd = Conn (const minBound) (const ()) (const maxBound) + +-- | \( \forall a: f (g a) \sim a \) -- --- See +invertible :: Rel s b -> (s -> r) -> (r -> s) -> s -> b +invertible (#) f g a = g (f a) # a + +-- | \( \forall a: g \circ f (a) \sim f (a) \) -- -projectiver :: Prd a => Prd b => Conn a b -> b -> Bool -projectiver conn@(Conn _ g) = Prop.projective_on (=~) g $ unit conn +-- > idempotent (#) f = projective (#) f f +-- +projective :: Rel s b -> (r -> s) -> (s -> s) -> r -> b +projective (#) f g r = g (f r) # f r diff --git a/src/Data/Connection/Ratio.hs b/src/Data/Connection/Ratio.hs --- a/src/Data/Connection/Ratio.hs +++ b/src/Data/Connection/Ratio.hs @@ -1,292 +1,222 @@ {-# Language AllowAmbiguousTypes #-} -{-# Language FunctionalDependencies #-} +{-# Language ConstraintKinds #-} +{-# Language Safe #-} +module Data.Connection.Ratio ( + Ratio(..) + , reduce + , shiftd + -- * Rational + , ratf32 + , ratf64 + , rati08 + , rati16 + , rati32 + , rati64 + , ratixx + , ratint + -- * Positive + , posw08 + , posw16 + , posw32 + , posw64 + , poswxx + , posnat +) where -module Data.Connection.Ratio where +import safe Data.Connection.Conn +import safe Data.Int +import safe Data.Order +import safe Data.Order.Extended +import safe Data.Ratio +import safe Data.Word +import safe GHC.Real (Ratio(..), Rational) +import safe Numeric.Natural +import safe Prelude hiding (Ord(..), until) +import safe qualified Prelude as P +import safe qualified Data.Connection.Float as F32 +import safe qualified Data.Connection.Double as F64 -import Data.Connection -import Data.Float -import Data.Int -import Data.Prd -import Data.Prd.Nan -import Data.Ratio -import Data.Semifield -import Data.Semilattice -import Data.Semilattice.Top -import Data.Semiring -import Data.Word -import GHC.Real hiding ((/), (^)) -import Numeric.Natural -import Prelude hiding (until, Ord(..), Num(..), Fractional(..), (^), Bounded) -import qualified Control.Category as C -import qualified Prelude as P +-- | A total version of 'GHC.Real.reduce'. +-- +reduce :: Integral a => Ratio a -> Ratio a +reduce (x :% 0) = x :% 0 +reduce (x :% y) = (x `quot` d) :% (y `quot` d) where d = gcd x y -reduce :: Integral a => a -> a -> Ratio a -reduce x 0 = x :% 0 -reduce x y = (x `quot` d) :% (y `quot` d) where d = gcd x y +-- | Shift by n 'units of least precision' where the ULP is determined by the denominator +-- +-- This is an analog of 'Data.Connection.Float.shift' for rationals. +-- +shiftd :: Num a => a -> Ratio a -> Ratio a +shiftd n (x :% y) = (n + x) :% y --- x % y = reduce (x * signum y) (abs y) -cancel :: Prd a => (Additive-Group) a => Ratio a -> Ratio a -cancel (x :% y) = if x < zero && y < zero then (pabs x) :% (pabs y) else x :% y +--------------------------------------------------------------------- +-- Rational +--------------------------------------------------------------------- --- TODO replace w/ Yoneda / Index / Graded --- shift by n 'units of least precision' where the ULP is --- determined by the denominator -shiftd :: (Additive-Semigroup) a => a -> Ratio a -> Ratio a -shiftd n (x :% y) = (n + x) :% y +rati08 :: Conn k Rational (Extended Int8) +rati08 = signedTriple 127 -class (Prd (Ratio a), Prd b) => TripRatio a b | b -> a where - ratxxx :: Trip (Ratio a) b +rati16 :: Conn k Rational (Extended Int16) +rati16 = signedTriple 32767 --- | Lawful replacement for the version in base. --- --- >>> fromRational @Float 1.3 --- 1.3000001 --- >>> fromRational @Float (1/0) --- Infinity --- >>> fromRational @Float (0/0) --- NaN --- --- >>> fromRational @(Extended Int8) 4.9 --- Def (fin 5) --- >>> fromRational @(Extended Int8) (-1.2) --- Def (fin (-1)) --- >>> fromRational @(Extended Int8) (1/0) --- Def Just Top --- >>> fromRational @(Extended Int8) (0/0) --- Nan --- >>> fromRational @(Extended Int8) (-1/0) --- Def Nothing --- -fromRational :: TripRatio a b => Ratio a -> b -fromRational = connl . tripl $ ratxxx +rati32 :: Conn k Rational (Extended Int32) +rati32 = signedTriple 2147483647 -ratf32 :: Trip (Ratio Integer) Float -ratf32 = Trip (extend' f) (extend' g) (extend' h) where +rati64 :: Conn k Rational (Extended Int64) +rati64 = signedTriple 9223372036854775807 + +ratixx :: Conn k Rational (Extended Int) +ratixx = signedTriple 9223372036854775807 + +ratint :: Conn k Rational (Extended Integer) +ratint = Conn f g h where + + f = liftExtended (~~ ninf) (\x -> x ~~ nan || x ~~ pinf) P.ceiling + + g = extended ninf pinf P.fromIntegral + + h = liftExtended (\x -> x ~~ nan || x ~~ ninf) (~~ pinf) P.floor + +ratf32 :: Conn k Rational Float +ratf32 = Conn (toFloating f) (fromFloating g) (toFloating h) where f x = let est = P.fromRational x in --F.fromRat' - if extend' g est >= x + if fromFloating g est >~ x then est - else ascendf est (extend' g) x + else ascendf est (fromFloating g) x g = flip approxRational 0 h x = let est = P.fromRational x in - if extend' g est <= x + if fromFloating g est <~ x then est - else descendf est (extend' g) x + else descendf est (fromFloating g) x - ascendf z g1 y = until (\x -> g1 x >= y) (<=) (shiftf 1) z + ascendf z g1 y = F64.until (\x -> g1 x >~ y) (<~) (F32.shift 1) z - descendf z f1 x = until (\y -> f1 y <= x) (>=) (shiftf (-1)) z + descendf z f1 x = F64.until (\y -> f1 y <~ x) (>~) (F32.shift (-1)) z -ratf64 :: Trip (Ratio Integer) Double -ratf64 = Trip (extend' f) (extend' g) (extend' h) where +ratf64 :: Conn k Rational Double +ratf64 = Conn (toFloating f) (fromFloating g) (toFloating h) where f x = let est = P.fromRational x in - if extend' g est >= x + if fromFloating g est >~ x then est - else ascendf est (extend' g) x + else ascendf est (fromFloating g) x g = flip approxRational 0 h x = let est = P.fromRational x in - if extend' g est <= x + if fromFloating g est <~ x then est - else descendf est (extend' g) x + else descendf est (fromFloating g) x - ascendf z g1 y = until (\x -> g1 x >= y) (<=) (shift 1) z + ascendf z g1 y = F64.until (\x -> g1 x >~ y) (<~) (F64.shift 1) z - descendf z f1 x = until (\y -> f1 y <= x) (>=) (shift (-1)) z + descendf z f1 x = F64.until (\y -> f1 y <~ x) (>~) (F64.shift (-1)) z -rati08 :: Trip (Ratio Integer) (Extended Int8) -rati08 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling $ cancel x +--------------------------------------------------------------------- +-- Ratio Natural +--------------------------------------------------------------------- - g = bounded ninf P.fromIntegral pinf +posw08 :: Conn k Positive (Lowered Word8) +posw08 = unsignedTriple 255 - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor $ cancel x +posw16 :: Conn k Positive (Lowered Word16) +posw16 = unsignedTriple 65535 - imax = 127 +posw32 :: Conn k Positive (Lowered Word32) +posw32 = unsignedTriple 4294967295 - imin = -128 +posw64 :: Conn k Positive (Lowered Word64) +posw64 = unsignedTriple 18446744073709551615 -rati16 :: Trip (Ratio Integer) (Extended Int16) -rati16 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling $ cancel x +poswxx :: Conn k Positive (Lowered Word) +poswxx = unsignedTriple 18446744073709551615 - g = bounded ninf P.fromIntegral pinf +posnat :: Conn k Positive (Lowered Natural) +posnat = Conn f g h where + + f = liftEitherR (\x -> x ~~ nan || x ~~ pinf) P.ceiling - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor $ cancel x + g = either P.fromIntegral (const pinf) - imax = 32767 + h = liftEitherR (~~ pinf) $ \x -> if x ~~ nan then 0 else P.floor x - imin = -32768 +--------------------------------------------------------------------- +-- Internal +--------------------------------------------------------------------- -rati32 :: Trip (Ratio Integer) (Extended Int32) -rati32 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling $ cancel x +{- +pabs :: (Lattice a, Eq a, Num a) => a -> a +pabs x = if 0 <~ x then x else negate x - g = bounded ninf P.fromIntegral pinf +cancel :: (Lattice a, Eq a, Num a) => Ratio a -> Ratio a +cancel (x :% y) = if x < 0 && y < 0 then (pabs x) :% (pabs y) else x :% y - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor $ cancel x +-- | An exception-safe version of 'nanf' for rationals. +-- +nanr :: Integral b => (a -> Ratio b) -> Maybe a -> Ratio b +nanr f = maybe (0 :% 0) f +-} - imax = 2147483647 +pinf :: Num a => Ratio a +pinf = 1 :% 0 - imin = -2147483648 +ninf :: Num a => Ratio a +ninf = (-1) :% 0 -rati64 :: Trip (Ratio Integer) (Extended Int64) -rati64 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Just Top - | x =~ ninf = Nothing - | x < imin = fin bottom - | otherwise = fin $ P.ceiling $ cancel x +nan :: Num a => Ratio a +nan = 0 :% 0 - g = bounded ninf P.fromIntegral pinf +{- +intnat :: Conn Integer Natural +intnat = Conn (fromIntegral . max 0) fromIntegral - h x | x =~ pinf = Just Top - | x > imax = fin top - | x < imin = Nothing - | otherwise = fin $ P.floor $ cancel x - - imax = 9223372036854775807 +natint :: Conn Natural (Lifted Integer) +natint = Conn (lifts P.fromIntegral) (lifted $ P.fromInteger . max 0) - imin = -9223372036854775808 +ratpos :: Conn k Rational Positive +ratpos = Conn k f g h where + + f = liftExtended (~~ ninf) (\x -> x ~~ nan || x ~~ pinf) P.ceiling -ratint :: Trip (Ratio Integer) (Extended Integer) -ratint = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x =~ pinf = Just Top - | x =~ ninf = Nothing - | otherwise = fin $ P.ceiling $ cancel x + g = extended minBound maxBound P.fromIntegral - g = bounded ninf P.fromIntegral pinf + h = liftExtended (\x -> x ~~ nan || x ~~ ninf) (~~ pinf) P.floor +-} - h x | x =~ pinf = Just Top - | x =~ ninf = Nothing - | otherwise = fin $ P.floor $ cancel x +unsignedTriple :: (Bounded a, Integral a) => Ratio Natural -> Conn k Positive (Lowered a) +unsignedTriple high = Conn f g h where + f x | x ~~ nan = Right maxBound + | x > high = Right maxBound + | otherwise = Left $ P.ceiling x -ratw08 :: Trip (Ratio Natural) (Lifted Word8) -ratw08 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Top - | otherwise = Fin $ P.ceiling x + g = either P.fromIntegral (const pinf) - g = topped P.fromIntegral pinf + h x | x ~~ nan = Left minBound + | x ~~ pinf = Right maxBound + | x > high = Left maxBound + | otherwise = Left $ P.floor x - h x | x =~ pinf = Top - | x > imax = Fin top - | otherwise = Fin $ P.floor x +signedTriple :: (Bounded a, Integral a) => Rational -> Conn k Rational (Extended a) +signedTriple high = Conn f g h where - imax = 255 + f = liftExtended (~~ ninf) (\x -> x ~~ nan || x > high) $ \x -> if x < low then minBound else P.ceiling x -ratw16 :: Trip (Ratio Natural) (Lifted Word16) -ratw16 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Top - | otherwise = Fin $ P.ceiling x + g = extended ninf pinf P.fromIntegral + + h = liftExtended (\x -> x ~~ nan || x < low) (~~ pinf) $ \x -> if x > high then maxBound else P.floor x - g = topped P.fromIntegral pinf + low = -1 - high - h x | x =~ pinf = Top - | x > imax = Fin top - | otherwise = Fin $ P.floor x - imax = 65535 - -ratw32 :: Trip (Ratio Natural) (Lifted Word32) -ratw32 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Top - | otherwise = Fin $ P.ceiling x - - g = topped P.fromIntegral pinf - - h x | x =~ pinf = Top - | x > imax = Fin top - | otherwise = Fin $ P.floor x - - imax = 4294967295 - -ratw64 :: Trip (Ratio Natural) (Lifted Word64) -ratw64 = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x > imax = Top - | otherwise = Fin $ P.ceiling x - - g = topped P.fromIntegral pinf - - h x | x =~ pinf = Top - | x > imax = Fin top - | otherwise = Fin $ P.floor x - - imax = 18446744073709551615 - -ratnat :: Trip (Ratio Natural) (Lifted Natural) -ratnat = Trip (liftNan f) (nan' g) (liftNan h) where - f x | x =~ pinf = Top - | otherwise = Fin $ P.ceiling x - - g = topped P.fromIntegral pinf - - h x | x =~ pinf = Top - | otherwise = Fin $ P.floor x - ---------------------------------------------------------------------- --- Instances ---------------------------------------------------------------------- - -instance TripRatio Integer Float where - ratxxx = ratf32 - -instance TripRatio Integer Double where - ratxxx = ratf64 - -instance TripRatio Integer (Ratio Integer) where - ratxxx = C.id - -instance TripRatio Integer (Nan Ordering) where - ratxxx = fldord - -instance TripRatio Integer (Extended Int8) where - ratxxx = rati08 - -instance TripRatio Integer (Extended Int16) where - ratxxx = rati16 - -instance TripRatio Integer (Extended Int32) where - ratxxx = rati32 - -instance TripRatio Integer (Extended Int64) where - ratxxx = rati64 - -instance TripRatio Integer (Extended Integer) where - ratxxx = ratint - -instance TripRatio Natural (Ratio Natural) where - ratxxx = C.id - -instance TripRatio Natural (Lifted Word8) where - ratxxx = ratw08 - -instance TripRatio Natural (Lifted Word16) where - ratxxx = ratw16 - -instance TripRatio Natural (Lifted Word32) where - ratxxx = ratw32 - -instance TripRatio Natural (Lifted Word64) where - ratxxx = ratw64 +toFloating :: (Order (Ratio a), Fractional b, Num a) => (Ratio a -> b) -> Ratio a -> b +toFloating f x | x ~~ nan = 0/0 + | x ~~ ninf = (-1)/0 + | x ~~ pinf = 1/0 + | otherwise = f x -instance TripRatio Natural (Lifted Natural) where - ratxxx = ratnat +fromFloating :: (Order a, Eq a, Fractional a, Num b) => (a -> Ratio b) -> a -> Ratio b +fromFloating f x | x ~~ 0/0 = nan + | x ~~ (-1)/0 = ninf + | x ~~ 1/0 = pinf + | otherwise = f x diff --git a/src/Data/Connection/Round.hs b/src/Data/Connection/Round.hs deleted file mode 100644 --- a/src/Data/Connection/Round.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# Language AllowAmbiguousTypes #-} - -module Data.Connection.Round ( - -- * Rounding Classes - TripInt16(..) - , ceil16 - , floor16 - , trunc16 - , round16 - , TripInt32(..) - , ceil32 - , floor32 - , trunc32 - , round32 - -- * Rounding Utils - , Mode(..) - , half - , tied - , above - , below - , addWith - , negWith - , subWith - , mulWith - , fmaWith - , remWith - , divWith - , divWith' -) where - -import Data.Bool -import Data.Connection -import Data.Connection.Float -import Data.Connection.Ratio -import Data.Float -import Data.Int -import Data.Prd -import Data.Ratio -import Data.Semifield -import Data.Semilattice -import Data.Semilattice.Top -import Data.Semiring -import Prelude hiding (until, Ord(..), Num(..), Fractional(..), (^), Bounded) -import Test.Logic (xor) - -class Prd a => TripInt16 a where - xxxi16 :: Trip a (Extended Int16) - -ceil16 :: TripInt16 a => a -> a -ceil16 = unitl xxxi16 - -floor16 :: TripInt16 a => a -> a -floor16 = counitr xxxi16 - -trunc16 :: (Additive-Monoid) a => TripInt16 a => a -> a -trunc16 x = bool (ceil16 x) (floor16 x) $ x >= zero - -round16 :: (Additive-Group) a => TripInt16 a => a -> a -round16 x | above xxxi16 x = ceil16 x -- upper half interval - | below xxxi16 x = floor16 x -- lower half interval - | otherwise = trunc16 x - -class Prd a => TripInt32 a where - xxxi32 :: Trip a (Extended Int32) - -ceil32 :: TripInt32 a => a -> a -ceil32 = unitl xxxi32 - -floor32 :: TripInt32 a => a -> a -floor32 = counitr xxxi32 - -trunc32 :: (Additive-Monoid) a => TripInt32 a => a -> a -trunc32 x = bool (ceil32 x) (floor32 x) $ x >= zero - -round32 :: (Additive-Group) a => TripInt32 a => a -> a -round32 x | above xxxi32 x = ceil32 x -- upper half interval - | below xxxi32 x = floor32 x -- lower half interval - | otherwise = trunc32 x - ---------------------------------------------------------------------- --- Rounding ---------------------------------------------------------------------- - --- | The four primary IEEE rounding modes. --- --- See . --- -data Mode = - RNZ -- ^ round to nearest with ties towards zero - | RTP -- ^ round towards pos infinity - | RTN -- ^ round towards neg infinity - | RTZ -- ^ round towards zero - deriving (Eq, Show) - --- | Determine which half of the interval between two representations of /a/ a particular value lies. --- -half :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Maybe Ordering -half t x = pcompare (x - unitl t x) (counitr t x - x) - --- | Determine whether /x/ lies above the halfway point between two representations. --- --- @ 'above' t x '==' (x '-' 'unitl' t x) '`gt`' ('counitr' t x '-' x) @ --- -above :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Bool -above t = maybe False (== GT) . half t - --- | Determine whether /x/ lies below the halfway point between two representations. --- --- @ 'below' t x '==' (x '-' 'unitl' t x) '`lt`' ('counitr' t x '-' x) @ --- -below :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Bool -below t = maybe False (== LT) . half t - --- | Determine whether /x/ lies exactly halfway between two representations. --- --- @ 'tied' t x '==' (x '-' 'unitl' t x) '=~' ('counitr' t x '-' x) @ --- -tied :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Bool -tied t = maybe False (== EQ) . half t - --- >>> addWith ratf32 RTN 1 2 --- 3.0 --- minSubf -addWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> b -addWith t@(Trip _ f _) rm x y = rnd t rm (addSgn t rm x y) (f x + f y) - -negWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -negWith t@(Trip _ f _) rm x = rnd t rm (neg' t rm x) (zero - f x) - -subWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> b -subWith t@(Trip _ f _) rm x y = rnd t rm (subSgn t rm x y) (f x - f y) - -mulWith :: (Prd a, Prd b, Ring a) => Trip a b -> Mode -> b -> b -> b -mulWith t@(Trip _ f _) rm x y = rnd t rm (xorSgn t rm x y) (f x * f y) - -{- -big = shiftf (-1) maximal -λ> fmaWith ratf32 RTN big 2 (-big) -3.4028235e38 -λ> big * 2 - big -Infinity --} -fmaWith :: (Prd a, Prd b, Ring a) => Trip a b -> Mode -> b -> b -> b -> b -fmaWith t@(Trip _ f _) rm x y z = rnd t rm (fmaSgn t rm x y z) $ f x * f y + f z - -{- -λ> remWith @Int RTP 17 5 --3 -λ> remWith @Int RNZ 17 5 -2 --} -remWith :: (Prd a, Prd b, Field a) => Trip a b -> Mode -> b -> b -> b -remWith t rm x y = fmaWith t rm (negWith t rm $ divWith t rm x y) y x - -{- -λ> divWith @Int RNZ 17 5 -3 -λ> divWith @Int RTP 17 5 -4 --} --- when pos numbers are divided by −0 we return minus infinity rather than pos: --- >>> divWith C.id RNZ 1 (shiftf (-1) 0) --- -Infinity -divWith :: (Prd a, Prd b, Field a) => Trip a b -> Mode -> b -> b -> b -divWith t@(Trip _ f _) rm x y = rnd t rm (xorSgn t rm x y) (f x / f y) - --- requires that sign be flipped back in /a/. -divWith' :: (Prd a, Prd b, Field a) => Trip a b -> Mode -> b -> b -> b -divWith' t@(Trip _ f _) rm x y | xorSgn t rm x y = rnd t rm True (negate $ f x / f y) - | otherwise = rnd t rm False (f x / f y) - ---------------------------------------------------------------------- --- Internal ---------------------------------------------------------------------- - --- @ truncateWith C.id == id @ -truncateWith :: (Prd a, Prd b, (Additive-Monoid) a) => Trip a b -> a -> b -truncateWith t x = bool (ceilingWith t x) (floorWith t x) $ x >= zero - --- @ ceilingWith C.id == id @ -ceilingWith :: Prd a => Prd b => Trip a b -> a -> b -ceilingWith = connl . tripl - --- @ floorWith C.id == id @ -floorWith :: Prd a => Prd b => Trip a b -> a -> b -floorWith = connr . tripr - --- @ roundWith C.id == id @ -roundWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> a -> b -roundWith t x | above t x = ceilingWith t x -- upper half interval - | below t x = floorWith t x -- lower half interval - | otherwise = truncateWith t x - -{- - -rndWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -rndWith t@(Trip f g h) rm x = rnd t rm (neg' t rm x) (g x) - --} - --- Determine the sign of 0 when /a/ contains signed 0s -rsz :: (Prd a, Prd b) => Trip a b -> Bool -> a -> b -rsz t = bool (floorWith t) (ceilingWith t) - -rnd :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> Bool -> a -> b -rnd t RNZ s x = bool (roundWith t x) (rsz t s x) $ x =~ zero -rnd t RTP s x = bool (ceilingWith t x) (rsz t s x) $ x =~ zero -rnd t RTN s x = bool (floorWith t x) (rsz t s x) $ x =~ zero -rnd t RTZ s x = bool (truncateWith t x) (rsz t s x) $ x =~ zero - -neg' :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> Bool -neg' t rm x = x < rnd t rm False zero - ---pos' :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> Bool ---pos' t rm x = x > rnd t rm False zero - --- | Determine signed-0 behavior under addition. -addSgn :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> Bool -addSgn t rm x y | rm == RTN = neg' t rm x || neg' t rm y - | otherwise = neg' t rm x && neg' t rm y - -subSgn :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> Bool -subSgn t rm x y = not (addSgn t rm x y) - --- | Determine signed-0 behavior under multiplication and division. -xorSgn :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> Bool -xorSgn t rm x y = neg' t rm x `xor` neg' t rm y - -fmaSgn :: (Prd a, Prd b, Ring a) => Trip a b -> Mode -> b -> b -> b -> Bool -fmaSgn t rm x y z = addSgn t rm (mulWith t rm x y) z - ---------------------------------------------------------------------- --- Instances ---------------------------------------------------------------------- - -instance TripInt16 Float where - xxxi16 = f32i16 - -instance TripInt16 Double where - xxxi16 = f64i16 - -instance TripInt16 (Ratio Integer) where - xxxi16 = rati16 - -instance TripInt32 Double where - xxxi32 = f64i32 - -instance TripInt32 (Ratio Integer) where - xxxi32 = rati32 diff --git a/src/Data/Connection/Word.hs b/src/Data/Connection/Word.hs --- a/src/Data/Connection/Word.hs +++ b/src/Data/Connection/Word.hs @@ -1,74 +1,145 @@ +{-# Language Safe #-} module Data.Connection.Word ( + -- * Bool + c08bin + , binc08 -- * Word8 - w08i08 + , w08c08 + , w08i08 , w08w16 , w08w32 , w08w64 + , w08wxx , w08nat -- * Word16 + , w16c16 , w16i16 , w16w32 , w16w64 + , w16wxx , w16nat -- * Word32 + , w32c32 , w32i32 , w32w64 + , w32wxx , w32nat -- * Word64 + , w64c64 , w64i64 , w64nat + -- * Word + , wxxw64 + , wxxnat ) where -import Data.Connection -import Data.Int -import Data.Word -import Numeric.Natural +import safe Data.Connection.Conn +import safe Data.Int +import safe Data.Order +import safe Data.Order.Syntax +import safe Data.Word +import safe Foreign.C.Types +import safe Numeric.Natural +import safe Prelude hiding (Ord(..), Eq(..)) -signed :: (Bounded b, Integral a, Integral b) => Conn a b -signed = Conn (\x -> fromIntegral x - minBound) - (\y -> fromIntegral (y + maxBound + 1)) +c08bin :: ConnL CBool Bool +c08bin = ConnL f g where + f (CBool i) | i == 255 = True + | otherwise = False + + g True = CBool 255 + g _ = CBool 254 -w08i08 :: Conn Word8 Int8 +binc08 :: ConnL Bool CBool +binc08 = ConnL f g where + f False = CBool 0 + f _ = CBool 1 + + g (CBool i) | i == 0 = False + | otherwise = True + +w08c08 :: ConnL Word8 CUChar +w08c08 = ConnL CUChar $ \(CUChar x) -> x + +w08i08 :: ConnL Word8 Int8 w08i08 = signed -w08w16 :: Conn Word8 Word16 -w08w16 = Conn fromIntegral (fromIntegral . min 255) +w08nat :: ConnL Word8 Natural +w08nat = unsigned +w08w16 :: ConnL Word8 Word16 +w08w16 = unsigned + -- w08w32 = w08w16 >>> w16w32 -w08w32 :: Conn Word8 Word32 -w08w32 = Conn fromIntegral (fromIntegral . min 255) +w08w32 :: ConnL Word8 Word32 +w08w32 = unsigned -- w08w64 = w08w32 >>> w32w64 = w08w16 >>> w16w64 -w08w64 :: Conn Word8 Word64 -w08w64 = Conn fromIntegral (fromIntegral . min 255) +w08w64 :: ConnL Word8 Word64 +w08w64 = unsigned -w08nat :: Conn Word8 Natural -w08nat = Conn fromIntegral (fromIntegral . min 255) +w08wxx :: ConnL Word8 Word +w08wxx = unsigned -w16i16 :: Conn Word16 Int16 +w16c16 :: ConnL Word16 CUShort +w16c16 = ConnL CUShort $ \(CUShort x) -> x + +w16i16 :: ConnL Word16 Int16 w16i16 = signed -w16w32 :: Conn Word16 Word32 -w16w32 = Conn fromIntegral (fromIntegral . min 65535) +w16w32 :: ConnL Word16 Word32 +w16w32 = unsigned -- w16w64 = w16w32 >>> w32w64 -w16w64 :: Conn Word16 Word64 -w16w64 = Conn fromIntegral (fromIntegral . min 65535) +w16w64 :: ConnL Word16 Word64 +w16w64 = unsigned -w16nat :: Conn Word16 Natural -w16nat = Conn fromIntegral (fromIntegral . min 65535) +w16wxx :: ConnL Word16 Word +w16wxx = unsigned -w32i32 :: Conn Word32 Int32 +w16nat :: ConnL Word16 Natural +w16nat = unsigned + +w32c32 :: ConnL Word32 CUInt +w32c32 = ConnL CUInt $ \(CUInt x) -> x + +w32i32 :: ConnL Word32 Int32 w32i32 = signed -w32w64 :: Conn Word32 Word64 -w32w64 = Conn fromIntegral (fromIntegral . min 4294967295) +w32w64 :: ConnL Word32 Word64 +w32w64 = unsigned -w32nat :: Conn Word32 Natural -w32nat = Conn fromIntegral (fromIntegral . min 4294967295) +w32wxx :: ConnL Word32 Word +w32wxx = unsigned -w64i64 :: Conn Word64 Int64 +w32nat :: ConnL Word32 Natural +w32nat = unsigned + +w64c64 :: ConnL Word64 CULong +w64c64 = ConnL CULong $ \(CULong x) -> x + +w64i64 :: ConnL Word64 Int64 w64i64 = signed -w64nat :: Conn Word64 Natural -w64nat = Conn fromIntegral (fromIntegral . min 18446744073709551615) +w64nat :: ConnL Word64 Natural +w64nat = unsigned + +-- | /Caution/: This assumes that 'Word' on your system is 64 bits. +wxxw64 :: Conn k Word Word64 +wxxw64 = Conn fromIntegral fromIntegral fromIntegral + +-- | /Caution/: This assumes that 'Word' on your system is 64 bits. +wxxnat :: ConnL Word Natural +wxxnat = ConnL fromIntegral (fromIntegral . min 18446744073709551615) + +--------------------------------------------------------------------- +-- Internal +--------------------------------------------------------------------- +signed :: (Bounded b, Integral a, Integral b) => ConnL a b +signed = ConnL (\x -> fromIntegral x - minBound) + (\y -> fromIntegral (y + maxBound + 1)) + +unsigned :: (Bounded a, Preorder b, Integral a, Integral b) => ConnL a b +unsigned = ConnL f g where + f = fromIntegral + g = fromIntegral . min (f maxBound) diff --git a/src/Data/Float.hsc b/src/Data/Float.hsc deleted file mode 100644 --- a/src/Data/Float.hsc +++ /dev/null @@ -1,875 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# LANGUAGE FlexibleContexts #-} -module Data.Float ( - Float - , Double - , module Data.Float -) where - -import Data.Bits ((.&.)) -import Data.Connection -import Data.Function (on) -import Data.Int -import Data.Prd -import Data.Semifield -import Data.Semigroup.Join -import Data.Semigroup.Meet -import Data.Semiring -import Data.Word -import Foreign hiding (shift) -import Foreign.C -import GHC.Float as F -import Prelude (Double,realToFrac,fromIntegral,($),return,IO) -import Prelude hiding (Ord(..), Num(..), Fractional(..), Floating(..), (^^), (^), RealFloat(..), Real(..), Enum(..)) -import System.IO.Unsafe (unsafePerformIO) -import qualified Prelude as P - - -{-# LINE 28 "Foreign/C/Math/Double.hsc" #-} - - --- | The acos function computes the principal value of the arc cosine of x --- in the range [0, pi] --- -acos :: Double -> Double -acos x = realToFrac (c_acos (realToFrac x)) -{-# INLINE acos #-} - -foreign import ccall unsafe "math.h acos" - c_acos :: CDouble -> CDouble - --- | The asin function computes the principal value of the arc sine of x in --- the range [-pi/2, +pi/2]. --- -asin :: Double -> Double -asin x = realToFrac (c_asin (realToFrac x)) -{-# INLINE asin #-} - -foreign import ccall unsafe "math.h asin" - c_asin :: CDouble -> CDouble - --- | The atan function computes the principal value of the arc tangent of x --- in the range [-pi/2, +pi/2]. --- -atan :: Double -> Double -atan x = realToFrac (c_atan (realToFrac x)) -{-# INLINE atan #-} - -foreign import ccall unsafe "math.h atan" - c_atan :: CDouble -> CDouble - --- | The atan2 function computes the principal value of the arc tangent of --- y/x, using the signs of both arguments to determine the quadrant of the --- return value. --- -atan2 :: Double -> Double -> Double -atan2 x y = realToFrac (c_atan2 (realToFrac x) (realToFrac y)) -{-# INLINE atan2 #-} - -foreign import ccall unsafe "math.h atan2" - c_atan2 :: CDouble -> CDouble -> CDouble - --- | The cos function computes the cosine of x (measured in radians). --- A large magnitude argument may yield a result with little or no significance. For a --- discussion of error due to roundoff, see math(3). --- -cos :: Double -> Double -cos x = realToFrac (c_cos (realToFrac x)) -{-# INLINE cos #-} - -foreign import ccall unsafe "math.h cos" - c_cos :: CDouble -> CDouble - --- | The sin function computes the sine of x (measured in radians). --- A large magnitude argument may yield a result with little or no --- significance. For a discussion of error due to roundoff, see math(3). --- -sin :: Double -> Double -sin x = realToFrac (c_sin (realToFrac x)) -{-# INLINE sin #-} - -foreign import ccall unsafe "math.h sin" - c_sin :: CDouble -> CDouble - --- | The tan function computes the tangent of x (measured in radians). --- A large magnitude argument may yield a result with little or no --- significance. For a discussion of error due to roundoff, see math(3). --- -tan :: Double -> Double -tan x = realToFrac (c_tan (realToFrac x)) -{-# INLINE tan #-} - -foreign import ccall unsafe "math.h tan" - c_tan :: CDouble -> CDouble - --- | The cosh function computes the hyperbolic cosine of x. --- -cosh :: Double -> Double -cosh x = realToFrac (c_cosh (realToFrac x)) -{-# INLINE cosh #-} - -foreign import ccall unsafe "math.h cosh" - c_cosh :: CDouble -> CDouble - --- | The sinh function computes the hyperbolic sine of x. --- -sinh :: Double -> Double -sinh x = realToFrac (c_sinh (realToFrac x)) -{-# INLINE sinh #-} - -foreign import ccall unsafe "math.h sinh" - c_sinh :: CDouble -> CDouble - --- | The tanh function computes the hyperbolic tangent of x. --- -tanh :: Double -> Double -tanh x = realToFrac (c_tanh (realToFrac x)) -{-# INLINE tanh #-} - -foreign import ccall unsafe "math.h tanh" - c_tanh :: CDouble -> CDouble - ------------------------------------------------------------------------- - --- | The exp() function computes the exponential value of the given argument x. --- -exp :: Double -> Double -exp x = realToFrac (c_exp (realToFrac x)) -{-# INLINE exp #-} - -foreign import ccall unsafe "math.h exp" - c_exp :: CDouble -> CDouble - --- | frexp convert floating-point number to fractional and integral components --- frexp is not defined in the Haskell 98 report. --- -frexp :: Double -> (Double,Int) -frexp x = unsafePerformIO $ - alloca $ \p -> do - d <- c_frexp (realToFrac x) p - i <- peek p - return (realToFrac d, fromIntegral i) - -foreign import ccall unsafe "math.h frexp" - c_frexp :: CDouble -> Ptr CInt -> IO Double - --- | The ldexp function multiplies a floating-point number by an integral power of 2. --- ldexp is not defined in the Haskell 98 report. --- -ldexp :: Double -> Int -> Double -ldexp x i = realToFrac (c_ldexp (realToFrac x) (fromIntegral i)) -{-# INLINE ldexp #-} - -foreign import ccall unsafe "math.h ldexp" - c_ldexp :: CDouble -> CInt -> Double - --- | The log() function computes the value of the natural logarithm of argument x. --- -log :: Double -> Double -log x = realToFrac (c_log (realToFrac x)) -{-# INLINE log #-} - -foreign import ccall unsafe "math.h log" - c_log :: CDouble -> CDouble - --- | The log10 function computes the value of the logarithm of argument x to base 10. --- log10 is not defined in the Haskell 98 report. -log10 :: Double -> Double -log10 x = realToFrac (c_log10 (realToFrac x)) -{-# INLINE log10 #-} - -foreign import ccall unsafe "math.h log10" - c_log10 :: CDouble -> CDouble - --- | The modf function breaks the argument value into integral and fractional --- parts, each of which has the same sign as the argument. --- modf is not defined in the Haskell 98 report. --- -modf :: Double -> (Double,Double) -modf x = unsafePerformIO $ - alloca $ \p -> do - d <- c_modf (realToFrac x) p - i <- peek p - return (realToFrac d, realToFrac i) - -foreign import ccall unsafe "math.h modf" - c_modf :: CDouble -> Ptr CDouble -> IO CDouble - --- | The pow function computes the value of x to the exponent y. --- -pow :: Double -> Double -> Double -pow x y = realToFrac (c_pow (realToFrac x) (realToFrac y)) -{-# INLINE pow #-} - -foreign import ccall unsafe "math.h pow" - c_pow :: CDouble -> CDouble -> CDouble - --- | The sqrt function computes the non-negative square root of x. --- -sqrt :: Double -> Double -sqrt x = realToFrac (c_sqrt (realToFrac x)) -{-# INLINE sqrt #-} - -foreign import ccall unsafe "math.h sqrt" - c_sqrt :: CDouble -> CDouble - --- | The ceil function returns the smallest integral value greater than or equal to x. --- -ceil :: Double -> Double -ceil x = realToFrac (c_ceil (realToFrac x)) -{-# INLINE ceil #-} - -foreign import ccall unsafe "math.h ceil" - c_ceil :: CDouble -> CDouble - --- | The fabs function computes the absolute value of a floating-point number x. --- -fabs :: Double -> Double -fabs x = realToFrac (c_fabs (realToFrac x)) -{-# INLINE fabs #-} - -foreign import ccall unsafe "math.h fabs" - c_fabs :: CDouble -> CDouble - --- | The floor function returns the largest integral value less than or equal to x. --- -floor :: Double -> Double -floor x = realToFrac (c_floor (realToFrac x)) -{-# INLINE floor #-} - -foreign import ccall unsafe "math.h floor" - c_floor :: CDouble -> CDouble - --- | The fmod function computes the floating-point remainder of x \/ y. --- -fmod :: Double -> Double -> Double -fmod x y = realToFrac (c_fmod (realToFrac x) (realToFrac y)) -{-# INLINE fmod #-} - -foreign import ccall unsafe "math.h fmod" - c_fmod :: CDouble -> CDouble -> CDouble - --- | The round function returns the nearest integral value to x; if x lies --- halfway between two integral values, then these functions return the integral --- value with the larger absolute value (i.e., it rounds away from zero). --- -round :: Double -> Double -round x = realToFrac (c_round (realToFrac x)) -{-# INLINE round #-} - -foreign import ccall unsafe "math.h round" - c_round :: CDouble -> CDouble - --- | The fmod function computes the floating-point remainder of x \/ y. --- -trunc :: Double -> Double -trunc x = realToFrac (c_trunc (realToFrac x)) -{-# INLINE trunc #-} - -foreign import ccall unsafe "math.h trunc" - c_trunc :: CDouble -> CDouble - --- | The erf calculates the error function of x. The error function is defined as: --- --- > erf(x) = 2/sqrt(pi)*integral from 0 to x of exp(-t*t) dt. --- -erf :: Double -> Double -erf x = realToFrac (c_erf (realToFrac x)) -{-# INLINE erf #-} - -foreign import ccall unsafe "math.h erf" - c_erf :: CDouble -> CDouble - --- | The erfc function calculates the complementary error function of x; --- that is erfc() subtracts the result of the error function erf(x) from --- 1.0. This is useful, since for large x places disappear. --- -erfc :: Double -> Double -erfc x = realToFrac (c_erfc (realToFrac x)) -{-# INLINE erfc #-} - -foreign import ccall unsafe "math.h erfc" - c_erfc :: CDouble -> CDouble - --- | The gamma function. --- -gamma :: Double -> Double -gamma x = realToFrac (c_gamma (realToFrac x)) -{-# INLINE gamma #-} - -foreign import ccall unsafe "math.h gamma" - c_gamma :: CDouble -> CDouble - --- | The hypot function function computes the sqrt(x*x+y*y) in such a way that --- underflow will not happen, and overflow occurs only if the final result --- deserves it. --- --- > hypot(Infinity, v) = hypot(v, Infinity) = +Infinity for all v, including NaN. --- -hypot :: Double -> Double -> Double -hypot x y = realToFrac (c_hypot (realToFrac x) (realToFrac y)) -{-# INLINE hypot #-} - -foreign import ccall unsafe "math.h hypot" - c_hypot :: CDouble -> CDouble -> CDouble - --- | The isinf function returns 1 if the number n is Infinity, otherwise 0. --- -isinf :: Double -> Int -isinf x = fromIntegral (c_isinf (realToFrac x)) -{-# INLINE isinf #-} - -foreign import ccall unsafe "math.h isinf" - c_isinf :: CDouble -> CInt - --- | The isnan function returns 1 if the number n is ``not-a-number'', --- otherwise 0. --- -isnan :: Double -> Int -isnan x = fromIntegral (c_isnan (realToFrac x)) -{-# INLINE isnan #-} - -foreign import ccall unsafe "math.h isnan" - c_isnan :: CDouble -> CInt - --- | finite returns the value 1 just when -Infinity < x < +Infinity; otherwise --- a zero is returned (when |x| = Infinity or x is NaN. --- -finite :: Double -> Int -finite x = fromIntegral (c_finite (realToFrac x)) -{-# INLINE finite #-} - -foreign import ccall unsafe "math.h finite" - c_finite :: CDouble -> CInt - --- | The functions j0() and j1() compute the Bessel function of the --- first kind of the order 0 and the order 1, respectively, for the real --- value x --- -j0 :: Double -> Double -j0 x = realToFrac (c_j0 (realToFrac x)) -{-# INLINE j0 #-} - -foreign import ccall unsafe "math.h j0" - c_j0 :: CDouble -> CDouble - --- | The functions j0() and j1() compute the Bessel function of the --- first kind of the order 0 and the order 1, respectively, for the real --- value x --- -j1 :: Double -> Double -j1 x = realToFrac (c_j1 (realToFrac x)) -{-# INLINE j1 #-} - -foreign import ccall unsafe "math.h j1" - c_j1 :: CDouble -> CDouble - --- | The functions y0() and y1() compute the linearly independent Bessel --- function of the second kind of the order 0 and the order 1, --- respectively, for the positive integer value x (expressed as a double) --- -y0 :: Double -> Double -y0 x = realToFrac (c_y0 (realToFrac x)) -{-# INLINE y0 #-} - -foreign import ccall unsafe "math.h y0" - c_y0 :: CDouble -> CDouble - --- | The functions y0() and y1() compute the linearly independent Bessel --- function of the second kind of the order 0 and the order 1, --- respectively, for the positive integer value x (expressed as a double) --- -y1 :: Double -> Double -y1 x = realToFrac (c_y1 (realToFrac x)) -{-# INLINE y1 #-} - -foreign import ccall unsafe "math.h y1" - c_y1 :: CDouble -> CDouble - --- | yn() computes the Bessel function of the second kind for the --- integer Bessel0 n for the positive integer value x (expressed as a --- double). --- -yn :: Int -> Double -> Double -yn x y = realToFrac (c_yn (fromIntegral x) (realToFrac y)) -{-# INLINE yn #-} - -foreign import ccall unsafe "math.h yn" - c_yn :: CInt -> CDouble -> CDouble - --- | lgamma(x) returns ln|| (x)|. --- -lgamma :: Double -> Double -lgamma x = realToFrac (c_lgamma (realToFrac x)) -{-# INLINE lgamma #-} - -foreign import ccall unsafe "math.h lgamma" - c_lgamma :: CDouble -> CDouble - - --- | The acosh function computes the inverse hyperbolic cosine of the real argument x. --- -acosh :: Double -> Double -acosh x = realToFrac (c_acosh (realToFrac x)) -{-# INLINE acosh #-} - -foreign import ccall unsafe "math.h acosh" - c_acosh :: CDouble -> CDouble - --- | The asinh function computes the inverse hyperbolic sine of the real argument. --- -asinh :: Double -> Double -asinh x = realToFrac (c_asinh (realToFrac x)) -{-# INLINE asinh #-} - -foreign import ccall unsafe "math.h asinh" - c_asinh :: CDouble -> CDouble - --- | The atanh function computes the inverse hyperbolic tangent of the real argument x. --- -atanh :: Double -> Double -atanh x = realToFrac (c_atanh (realToFrac x)) -{-# INLINE atanh #-} - -foreign import ccall unsafe "math.h atanh" - c_atanh :: CDouble -> CDouble - --- | The cbrt function computes the cube root of x. --- -cbrt :: Double -> Double -cbrt x = realToFrac (c_cbrt (realToFrac x)) -{-# INLINE cbrt #-} - -foreign import ccall unsafe "math.h cbrt" - c_cbrt :: CDouble -> CDouble - --- | logb x returns x's exponent n, a signed integer converted to --- double-precision floating-point. --- --- > logb(+-Infinity) = +Infinity; --- > logb(0) = -Infinity with a division by zero exception. --- -logb :: Double -> Double -logb x = realToFrac (c_logb (realToFrac x)) -{-# INLINE logb #-} - -foreign import ccall unsafe "math.h logb" - c_logb :: CDouble -> CDouble - - --- | nextafter returns the next machine representable number from x in direction y. --- -nextafter :: Double -> Double -> Double -nextafter x y = realToFrac (c_nextafter (realToFrac x) (realToFrac y)) -{-# INLINE nextafter #-} - -foreign import ccall unsafe "math.h nextafter" - c_nextafter :: CDouble -> CDouble -> CDouble - --- | remainder returns the remainder r := x - n*y where n is the integer --- nearest the exact value of x/y; moreover if |n - x/y| = 1/2 then n is even. --- Consequently, the remainder is computed exactly and |r| <= |y|/2. But --- remainder(x, 0) and remainder(Infinity, 0) are invalid operations that produce --- a NaN. -- -remainder :: Double -> Double -> Double -remainder x y = realToFrac (c_remainder (realToFrac x) (realToFrac y)) -{-# INLINE remainder #-} - -foreign import ccall unsafe "math.h remainder" - c_remainder :: CDouble -> CDouble -> CDouble - --- | scalb(x, n) returns x*(2**n) computed by exponent manipulation. -scalb :: Double -> Double -> Double -scalb x y = realToFrac (c_scalb (realToFrac x) (realToFrac y)) -{-# INLINE scalb #-} - -foreign import ccall unsafe "math.h scalb" - c_scalb :: CDouble -> CDouble -> CDouble - --- | significand(x) returns sig, where x := sig * 2**n with 1 <= sig < 2. --- significand(x) is not defined when x is 0, +-Infinity, or NaN. --- -significand :: Double -> Double -significand x = realToFrac (c_significand (realToFrac x)) -{-# INLINE significand #-} - -foreign import ccall unsafe "math.h significand" - c_significand :: CDouble -> CDouble - - --- | copysign x y returns x with its sign changed to y's. -copysign :: Double -> Double -> Double -copysign x y = realToFrac (c_copysign (realToFrac x) (realToFrac y)) -{-# INLINE copysign #-} - -foreign import ccall unsafe "math.h copysign" - c_copysign :: CDouble -> CDouble -> CDouble - --- | ilogb() returns x's exponent n, in integer format. --- ilogb(+-Infinity) re- turns INT_MAX and ilogb(0) returns INT_MIN. --- -ilogb :: Double -> Int -ilogb x = fromIntegral (c_ilogb (realToFrac x)) -{-# INLINE ilogb #-} - -foreign import ccall unsafe "math.h ilogb" - c_ilogb :: CDouble -> CInt - --- | The rint() function returns the integral value (represented as a --- double precision number) nearest to x according to the prevailing --- rounding mode. --- -rint :: Double -> Double -rint x = realToFrac (c_rint (realToFrac x)) -{-# INLINE rint #-} - -foreign import ccall unsafe "math.h rint" - c_rint :: CDouble -> CDouble - - --- | Determine bitwise equality. --- -eq :: Double -> Double -> Bool -eq = (==) `on` doubleWord64 - -eqf :: Float -> Float -> Bool -eqf = (==) `on` floatWord32 - --- | Maximum finite value. --- --- >>> shift 1 maxNorm --- Infinity --- -maxNorm :: Double -maxNorm = shift (-1) maximal - -maxNormf :: Float -maxNormf = shiftf (-1) maximal - --- | Minimum normalized value. --- --- >>> shift (-1) minNorm --- 0 --- -minNorm :: Double -minNorm = word64Double 0x0080000000000000 - -minNormf :: Float -minNormf = word32Float 0x00800000 - --- | Maximum representable odd integer. --- --- @ maxOdd = 2**53 - 1@ --- -maxOdd :: Double -maxOdd = 9.007199254740991e15 - --- | Maximum representable odd integer. --- --- @ maxOddf = 2**24 - 1@ --- -maxOddf :: Float -maxOddf = 1.6777215e7 - --- | Minimum (pos) value. --- --- >>> shift (-1) minSub --- 0.0 --- -minSub :: Double -minSub = shift 1 0 - -minSubf :: Float -minSubf = shiftf 1 0 - --- | Difference between 1 and the smallest representable value greater than 1. -epsilon :: Double -epsilon = shift 1 1 - 1 - -epsilonf :: Float -epsilonf = shiftf 1 1 - 1 - --- | Split a 'Double' symmetrically along the sign bit. --- --- >>> split 0 --- Right 0.0 --- >>> split (shift (-1) 0) --- Left (-0.0) --- -split :: Double -> Either Double Double -split x = case signBit x of - True -> Left x - _ -> Right x - -splitf :: Float -> Either Float Float -splitf x = case signBitf x of - True -> Left x - _ -> Right x - - --- TODO replace w/ Yoneda / Index / Graded --- | Shift by /Int64/ units of least precision. --- -shift :: Int64 -> Double -> Double -shift n = int64Double . (+ n) . doubleInt64 - -shiftf :: Int32 -> Float -> Float -shiftf n = int32Float . (+ n) . floatInt32 - --- | Compute signed distance in units of least precision. --- --- @ 'ulps' x ('shift' ('abs' n) x) '==' ('True', 'abs' n) @ --- -ulps :: Double -> Double -> (Bool, Word64) -ulps x y = o - where x' = doubleInt64 x - y' = doubleInt64 y - o | x' >= y' = (False, fromIntegral . abs $ x' - y') - | otherwise = (True, fromIntegral . abs $ y' - x') - -ulpsf :: Float -> Float -> (Bool, Word32) -ulpsf x y = o - where x' = floatInt32 x - y' = floatInt32 y - o | x' >= y' = (False, fromIntegral . abs $ x' - y') - | otherwise = (True, fromIntegral . abs $ y' - x') - --- | Compute distance in units of least precision. --- --- @ 'ulps'' x ('shift' n x) '==' 'abs' n @ --- -ulps' :: Double -> Double -> Word64 -ulps' x y = snd $ ulps x y - -ulpsf' :: Float -> Float -> Word32 -ulpsf' x y = snd $ ulpsf x y - --- | Compare two values for approximate equality. --- --- Required accuracy is specified in units of least precision. --- --- See also . --- -within :: Word64 -> Double -> Double -> Bool -within tol a b = ulps' a b <= tol - -withinf :: Word32 -> Float -> Float -> Bool -withinf tol a b = ulpsf' a b <= tol - - - -{- -ulpDelta :: Float -> Float -> Int -ulpDelta x y = if lesser then d' else (-1) * d' - where (lesser, d) = ulps x y - d' = fromIntegral d - -ulpDelta' :: Float -> Float -> Int32 -ulpDelta' x y = if lesser then d' else (-1) * d' - where (lesser, d) = ulps x y - d' = fromIntegral d --} - ----------------------------------------------------------------- --- Ulp32 ----------------------------------------------------------------- - --- | 32 bit unit of least precision type. --- -newtype Ulp32 = Ulp32 { unUlp32 :: Int32 } deriving Show - -ulp32Nan :: Ulp32 -> Bool -ulp32Nan (Ulp32 x) = x /= (min 2139095040 . max (- 2139095041)) x - -instance Eq Ulp32 where - x == y | ulp32Nan x && ulp32Nan y = True - | ulp32Nan x || ulp32Nan y = False - | otherwise = on (==) unUlp32 x y - -instance Prd Ulp32 where - x <= y | ulp32Nan x && ulp32Nan y = True - | ulp32Nan x || ulp32Nan y = False - | otherwise = on (<=) unUlp32 x y - -instance Minimal Ulp32 where - minimal = Ulp32 $ -2139095041 - -instance Maximal Ulp32 where - maximal = Ulp32 $ 2139095040 - -instance Semigroup (Additive Ulp32) where - Additive (Ulp32 x) <> Additive (Ulp32 y) = Additive . Ulp32 $ x + y - -instance Monoid (Additive Ulp32) where - mempty = Additive $ Ulp32 0 - -instance Semigroup (Multiplicative Ulp32) where - Multiplicative (Ulp32 x) <> Multiplicative (Ulp32 y) = Multiplicative . Ulp32 $ x * y - -instance Monoid (Multiplicative Ulp32) where - mempty = Multiplicative $ Ulp32 1 - -instance Presemiring Ulp32 -instance Semiring Ulp32 - -instance Semigroup (Join Ulp32) where - Join (Ulp32 x) <> Join (Ulp32 y) = Join . Ulp32 $ P.max x y - -instance Semigroup (Meet Ulp32) where - Meet (Ulp32 x) <> Meet (Ulp32 y) = Meet . Ulp32 $ P.min x y - -f32u32 :: Conn Float Ulp32 -f32u32 = Conn (Ulp32 . floatInt32) (int32Float . unUlp32) - -u32f32 :: Conn Ulp32 Float -u32f32 = Conn (int32Float . unUlp32) (Ulp32 . floatInt32) - --- fromIntegral (maxBound :: Ulp32) + 1 , image of aNan - - ---newtype Ulp a = Ulp { unUlp :: a } --- instance -{- correct but should replace w/ Graded / Yoneda / Indexed etc -u32w64 :: Conn Ulp32 (Nan Word64) -u32w64 = Conn f g where - conn = i32w32 >>> w32w64 - - offset = 2139095041 :: Word64 - offset' = 2139095041 :: Int32 - - f x@(Ulp32 y) | ulp32Nan x = Nan - | neg y = Def $ fromIntegral (y + offset') - | otherwise = Def $ (fromIntegral y) + offset - where fromIntegral = connl conn - - g x = case x of - Nan -> Ulp32 offset' - Def y | y < offset -> Ulp32 $ (fromIntegral y) P.- offset' - | otherwise -> Ulp32 $ fromIntegral ((min 4278190081 y) P.- offset) - where fromIntegral = connr conn --} - - --- internal - --- ---TODO handle neg case, get # of nans/denormals, collect constants - ---abs' :: Eq a => Ord a => Bound a => Ring a => a -> a ---abs' x = if x == minimal then abs (x+one) else abs x - -signBit :: Double -> Bool -signBit x = if x =~ anan then False else msbMask x /= 0 - -evenBit :: Double -> Bool -evenBit x = lsbMask x == 0 - -lsbMask :: Double -> Word64 -lsbMask x = 0x0000000000000001 .&. doubleWord64 x - -msbMask :: Double -> Word64 -msbMask x = 0x8000000000000000 .&. doubleWord64 x - --- loatWord64 maximal == exponent maximal ---expMask :: Double -> Word64 ---expMask x = 0x7F80000000000000 .&. doubleWord64 x - --- chk = >= 0 ==> == word64Double $ exponent + signiicand -sigMask :: Double -> Word64 -sigMask x = 0x007FFFFFFFFFFFFF .&. doubleWord64 x - - - -signBitf :: Float -> Bool -signBitf x = if x =~ anan then False else msbMaskf x /= 0 - -evenBitf :: Float -> Bool -evenBitf x = lsbMaskf x == 0 - -lsbMaskf :: Float -> Word32 -lsbMaskf x = 0x00000001 .&. floatWord32 x - -msbMaskf :: Float -> Word32 -msbMaskf x = 0x80000000 .&. floatWord32 x - --- floatWord32 maximal == exponent maximal -expMaskf :: Float -> Word32 -expMaskf x = 0x7f800000 .&. floatWord32 x - --- chk f = f >= 0 ==> f == word32Float $ exponent f + significand f -sigMaskf :: Float -> Word32 -sigMaskf x = 0x007FFFFF .&. floatWord32 x - - - -{- --- | first /NaN/ value. ---naN :: Float ---naN = 0/0 -- inc pInf - --- | Positive infinity --- --- @nInf = 1/0@ --- -pInf :: Float -pInf = word32Float 0x7f800000 - --- | Negative infinity --- --- @nInf = -1/0@ --- -nInf :: Float -nInf = word32Float 0xff800000 --} - - --- Non-monotonic function -signed64 :: Word64 -> Int64 -signed64 x | x < 0x8000000000000000 = fromIntegral x - | otherwise = fromIntegral (maximal P.- (x P.- 0x8000000000000000)) - --- Non-monotonic function converting from 2s-complement format. -unsigned64 :: Int64 -> Word64 -unsigned64 x | x >= 0 = fromIntegral x - | otherwise = 0x8000000000000000 + (maximal P.- (fromIntegral x)) - -int64Double :: Int64 -> Double -int64Double = word64Double . unsigned64 - -doubleInt64 :: Double -> Int64 -doubleInt64 = signed64 . doubleWord64 - --- Bit-for-bit conversion. -word64Double :: Word64 -> Double -word64Double = F.castWord64ToDouble - --- TODO force to pos representation? --- Bit-for-bit conversion. -doubleWord64 :: Double -> Word64 -doubleWord64 = (+0) . F.castDoubleToWord64 - --- Non-monotonic function -signed32 :: Word32 -> Int32 -signed32 x | x < 0x80000000 = fromIntegral x - | otherwise = fromIntegral (maximal P.- (x P.- 0x80000000)) - --- Non-monotonic function converting from 2s-complement format. -unsigned32 :: Int32 -> Word32 -unsigned32 x | x >= 0 = fromIntegral x - | otherwise = 0x80000000 + (maximal P.- (fromIntegral x)) - -int32Float :: Int32 -> Float -int32Float = word32Float . unsigned32 - -floatInt32 :: Float -> Int32 -floatInt32 = signed32 . floatWord32 - --- Bit-for-bit conversion. -word32Float :: Word32 -> Float -word32Float = F.castWord32ToFloat - --- TODO force to pos representation? --- Bit-for-bit conversion. -floatWord32 :: Float -> Word32 -floatWord32 = (+0) . F.castFloatToWord32 - diff --git a/src/Data/Lattice.hs b/src/Data/Lattice.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lattice.hs @@ -0,0 +1,696 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +-- | Lattices & algebras +module Data.Lattice ( + -- * Types + Lattice + , Semilattice + -- * HeytingL + , type HeytingL + , (\\) + , non + , equiv + , boundary + , booleanL + , heytingL + -- * HeytingR + , type HeytingR + , (//) + , neg + , iff + , middle + , booleanR + , heytingR + -- * Heyting + , (\/) + , (/\) + , glb + , lub + , true + , false + , Heyting(..) + -- * Symmetric + , Biheyting + , Symmetric(..) + , symmetricL + , symmetricR + -- * Boolean + , Boolean(..) +) where + +import safe Control.Applicative +import safe Data.Bifunctor (bimap) +import safe Data.Bool hiding (not) +import safe Data.Connection.Conn +import safe Data.Connection.Class +import safe Data.Either +import safe Data.Functor.Contravariant +import safe Data.Foldable +import safe Data.Order +import safe Data.Order.Extended +import safe Data.Order.Interval +import safe Data.Order.Syntax +import safe Data.Int +import safe Data.Maybe +import safe Data.Monoid +import safe Data.Word +import safe GHC.TypeNats +--import safe Numeric.Natural +import safe Prelude hiding (Eq(..),Ord(..),Bounded, not) +import safe qualified Data.IntMap as IntMap +import safe qualified Data.IntSet as IntSet +import safe qualified Data.Map as Map +import safe qualified Data.Map.Merge.Lazy as Map +import safe qualified Data.Set as Set +import safe qualified Data.Finite as F +import safe qualified Data.Universe.Class as U +import safe qualified Prelude as P + +------------------------------------------------------------------------------- +-- Lattices +------------------------------------------------------------------------------- + +-- | Bounded < https://ncatlab.org/nlab/show/lattice lattices >. +-- +-- /Neutrality/: +-- +-- The least and greatest elements of a complete /a/ are given by the unique +-- upper and lower adjoints to the function /a -> ()/. +-- +-- @ +-- x '\/' 'false' = x +-- x '/\' 'true' = x +-- 'glb' 'false' x 'true' = x +-- 'lub' 'false' x 'true' = x +-- @ +-- +type Lattice a = (Eq a, Semilattice 'L a, Extremal 'L a, Semilattice 'R a, Extremal 'R a) + +-- | The unique top element of a bounded lattice +-- +-- > x /\ true = x +-- > x \/ true = true +-- +true :: Lattice a => a +true = maximal + +-- | The unique bottom element of a bounded lattice +-- +-- > x /\ false = false +-- > x \/ false = x +-- +false :: Lattice a => a +false = minimal + +------------------------------------------------------------------------------- +-- Heyting algebras +------------------------------------------------------------------------------- + +-- | A < https://ncatlab.org/nlab/show/co-Heyting+algebra bi-Heyting algebra >. +-- +-- /Laws/: +-- +-- > neg x <= non x +-- +-- with equality occurring iff /a/ is a 'Boolean' algebra. +-- +type Biheyting a = (HeytingL a, HeytingR a) + +-- | A convenience alias for a < https://ncatlab.org/nlab/show/co-Heyting+algebra co-Heyting algebra >. +-- +type HeytingL = Heyting 'L + +-- | A convenience alias for a Heyting algebra. +-- +type HeytingR = Heyting 'R + +-- | Heyting algebras +-- +-- A Heyting algebra is a bounded, distributive complete equipped with an +-- implication operation. +-- +-- * The complete of closed subsets of a trueological space is the primordial +-- example of a /HeytingL/ (co-Heyting) algebra. +-- +-- * The dual complete of open subsets of a trueological space is likewise +-- the primordial example of a /HeytingR/ algebra. +-- +-- /Heyting 'L/: +-- +-- Co-implication to /a/ is the lower adjoint of disjunction with /a/: +-- +-- > x \\ a <= y <=> x <= y \/ a +-- +-- Note that co-Heyting algebras needn't obey the law of non-contradiction: +-- +-- > EQ /\ non EQ = EQ /\ GT \\ EQ = EQ /\ GT = EQ /= LT +-- +-- See < https://ncatlab.org/nlab/show/co-Heyting+algebra > +-- +-- /Heyting 'R/: +-- +-- Implication from /a/ is the upper adjoint of conjunction with /a/: +-- +-- > x <= a // y <=> a /\ x <= y +-- +-- Similarly, Heyting algebras needn't obey the law of the excluded middle: +-- +-- > EQ \/ neg EQ = EQ \/ EQ // LT = EQ \/ LT = EQ /= GT +-- +-- See < https://ncatlab.org/nlab/show/Heyting+algebra > +-- +class Lattice a => Heyting k a where + + -- | The defining connection of a (co-)Heyting algebra. + -- + -- > heyting @'L x = ConnL (\\ x) (\/ x) + -- > heyting @'R x = ConnR (x /\) (x //) + -- + heyting :: a -> Conn k a a + +------------------------------------------------------------------------------- +-- HeytingL +------------------------------------------------------------------------------- + +infixl 8 \\ + +-- | Logical co-implication: +-- +-- \( a \Rightarrow b = \wedge \{x \mid a \leq b \vee x \} \) +-- +-- /Laws/: +-- +-- > x \\ y <= z <=> x <= y \/ z +-- > x \\ y >= (x /\ z) \\ y +-- > x >= y => x \\ z >= y \\ z +-- > x >= x \\ y +-- > x >= y <=> y \\ x = false +-- > x \\ (y /\ z) >= x \\ y +-- > z \\ (x \/ y) = z \\ x \\ y +-- > (y \/ z) \\ x = y \\ x \/ z \\ x +-- > x \/ y \\ x = x \/ y +-- +-- >>> False \\ False +-- False +-- >>> False \\ True +-- False +-- >>> True \\ False +-- True +-- >>> True \\ True +-- False +-- +-- For many collections (e.g. 'Data.Set.Set') '\\' coincides with the native 'Data.Set.\\' operator. +-- +-- >>> :set -XOverloadedLists +-- >>> [GT,EQ] Set.\\ [LT] +-- fromList [EQ,GT] +-- >>> [GT,EQ] \\ [LT] +-- fromList [EQ,GT] +-- +(\\) :: Heyting 'L a => a -> a -> a +(\\) = flip $ lowerL . heyting + +-- | Logical < https://ncatlab.org/nlab/show/co-Heyting+negation co-negation >. +-- +-- @ 'non' x = 'true' '\\' x @ +-- +-- /Laws/: +-- +-- > non false = true +-- > non true = false +-- > x >= non (non x) +-- > non (x /\ y) >= non x +-- > non (y \\ x) = non (non x) \/ non y +-- > non (x /\ y) = non x \/ non y +-- > x \/ non x = true +-- > non (non (non x)) = non x +-- > non (non (x /\ non x)) = false +-- +non :: Heyting 'L a => a -> a +non x = true \\ x + +-- | Intuitionistic co-equivalence. +-- +equiv :: Heyting 'L a => a -> a -> a +equiv x y = (x \\ y) \/ (y \\ x) + +-- | The co-Heyting < https://ncatlab.org/nlab/show/co-Heyting+boundary boundary > operator. +-- +-- > x = boundary x \/ (non . non) x +-- > boundary (x /\ y) = (boundary x /\ y) \/ (x /\ boundary y) -- (Leibniz rule) +-- > boundary (x \/ y) \/ boundary (x /\ y) = boundary x \/ boundary y +-- +boundary :: Heyting 'L a => a -> a +boundary x = x /\ non x + +-- | An adjunction between a co-Heyting algebra and its Boolean sub-algebra. +-- +-- Double negation is a join-preserving comonad. +-- +booleanL :: Heyting 'L a => Conn 'L a a +booleanL = + let + -- Check that /x/ is a regular element + -- See https://ncatlab.org/nlab/show/regular+element + inj x = if x == (non . non) x then x else true + + in + ConnL inj (non . non) + +-- | Default constructor for a co-Heyting algebra. +-- +heytingL :: Lattice a => (a -> a -> a) -> a -> Conn 'L a a +heytingL f a = ConnL (`f` a) (\/ a) + +------------------------------------------------------------------------------- +-- HeytingR +------------------------------------------------------------------------------- + +infixr 8 // -- same as ^ + +-- | Logical implication: +-- +-- \( a \Rightarrow b = \vee \{x \mid x \wedge a \leq b \} \) +-- +-- /Laws/: +-- +-- > x /\ y <= z <=> x <= y // z +-- > x // y <= x // (y \/ z) +-- > x <= y => z // x <= z // y +-- > y <= x // (x /\ y) +-- > x <= y <=> x // y = true +-- > (x \/ z) // y <= x // y +-- > (x /\ y) // z = x // y // z +-- > x // (y /\ z) = x // y /\ x // z +-- > x /\ x // y = x /\ y +-- +-- >>> False // False +-- True +-- >>> False // True +-- True +-- >>> True // False +-- False +-- >>> True // True +-- True +-- +(//) :: Heyting 'R a => a -> a -> a +(//) x = upperR $ heyting x + +-- | Logical negation. +-- +-- @ 'neg' x = x '//' 'false' @ +-- +-- /Laws/: +-- +-- > neg false = true +-- > neg true = false +-- > x <= neg (neg x) +-- > neg (x \/ y) <= neg x +-- > neg (x // y) = neg (neg x) /\ neg y +-- > neg (x \/ y) = neg x /\ neg y +-- > x /\ neg x = false +-- > neg (neg (neg x)) = neg x +-- > neg (neg (x \/ neg x)) = true +-- +-- Some logics may in addition obey < https://ncatlab.org/nlab/show/De+Morgan+Heyting+algebra De Morgan conditions >. +-- +neg :: Heyting 'R a => a -> a +neg x = x // false + +-- | Intuitionistic equivalence. +-- +-- When /a=Bool/ this is 'if-and-only-if'. +-- +iff :: Heyting 'R a => a -> a -> a +iff x y = (x // y) /\ (y // x) + +-- | The Heyting (< https://ncatlab.org/nlab/show/excluded+middle not necessarily excluded>) middle operator. +-- +middle :: Heyting 'R a => a -> a +middle x = x \/ neg x + +-- | An adjunction between a Heyting algebra and its Boolean sub-algebra. +-- +-- Double negation is a meet-preserving monad. +-- +booleanR :: Heyting 'R a => Conn 'R a a +booleanR = + let + -- Check that /x/ is a regular element + -- See https://ncatlab.org/nlab/show/regular+element + inj x = if x == (neg . neg) x then x else false + + in + ConnR (neg . neg) inj + +-- | Default constructor for a Heyting algebra. +-- +heytingR :: Lattice a => (a -> a -> a) -> a -> Conn 'R a a +heytingR f a = ConnR (a /\) (a `f`) + +------------------------------------------------------------------------------- +-- Symmetric +------------------------------------------------------------------------------- + +-- | Symmetric Heyting algebras +-- +-- A symmetric Heyting algebra is a +-- bi-Heyting algebra with an idempotent, antitone negation operator. +-- +-- /Laws/: +-- +-- > x <= y => not y <= not x -- antitone +-- > not . not = id -- idempotence +-- > x \\ y = not (not y // not x) +-- > x // y = not (not y \\ not x) +-- +-- and: +-- +-- > converseR x <= converseL x +-- +-- with equality occurring iff /a/ is a 'Boolean' algebra. +-- +class Biheyting a => Symmetric a where + + -- | Symmetric negation. + -- + -- > not . not = id + -- > neg . neg = converseR . converseL + -- > non . non = converseL . converseR + -- > neg . non = converseR . converseR + -- > non . neg = converseL . converseL + -- + -- > neg = converseR . not = not . converseL + -- > non = not . converseR = converseL . not + -- > x \\ y = not (not y // not x) + -- > x // y = not (not y \\ not x) + -- + not :: a -> a + + infixl 4 `xor` + + -- | Exclusive or. + -- + -- > xor x y = (x \/ y) /\ (not x \/ not y) + -- + xor :: a -> a -> a + xor x y = (x \/ y) /\ not (x /\ y) + + -- | Left converse operator. + -- + converseL :: a -> a + converseL x = true \\ not x + + -- | Right converse operator. + -- + converseR :: a -> a + converseR x = not x // false + +-- | Default constructor for a co-Heyting algebra. +-- +symmetricL :: Symmetric a => a -> ConnL a a +symmetricL = heytingL $ \x y -> not (not y // not x) + +-- | Default constructor for a Heyting algebra. +-- +symmetricR :: Symmetric a => a -> ConnR a a +symmetricR = heytingR $ \x y -> not (not y \\ not x) + +------------------------------------------------------------------------------- +-- Boolean +------------------------------------------------------------------------------- + +-- | Boolean algebras. +-- +-- < https://ncatlab.org/nlab/show/Boolean+algebra Boolean algebras > are +-- symmetric Heyting algebras that satisfy both the law of excluded middle +-- and the law of law of non-contradiction: +-- +-- > x \/ neg x = true +-- > x /\ non x = false +-- +-- If /a/ is Boolean we also have: +-- +-- > non = not = neg +-- +class Symmetric a => Boolean a where + + -- | A witness to the lawfulness of a boolean algebra. + -- + boolean :: Trip a a + boolean = Conn (converseR . converseL) id (converseL . converseR) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + + +impliesL :: (Total a, P.Bounded a) => a -> a -> a +impliesL x y = if y < x then x else P.minBound + +impliesR :: (Total a, P.Bounded a) => a -> a -> a +impliesR x y = if x > y then y else P.maxBound + +instance Heyting 'L () where heyting = heytingL impliesL +instance Heyting 'L Bool where heyting = heytingL impliesL +instance Heyting 'L Ordering where heyting = heytingL impliesL +instance Heyting 'L Word8 where heyting = heytingL impliesL +instance Heyting 'L Word16 where heyting = heytingL impliesL +instance Heyting 'L Word32 where heyting = heytingL impliesL +instance Heyting 'L Word64 where heyting = heytingL impliesL +instance Heyting 'L Word where heyting = heytingL impliesL +instance KnownNat n => Heyting 'L (F.Finite n) where heyting = heytingL impliesL + +instance Heyting 'R () where heyting = heytingR impliesR +instance Heyting 'R Bool where heyting = heytingR impliesR +--instance Heyting 'R Ordering where heyting = heytingR impliesR +instance Heyting 'R Word8 where heyting = heytingR impliesR +instance Heyting 'R Word16 where heyting = heytingR impliesR +instance Heyting 'R Word32 where heyting = heytingR impliesR +instance Heyting 'R Word64 where heyting = heytingR impliesR +instance Heyting 'R Word where heyting = heytingR impliesR +instance KnownNat n => Heyting 'R (F.Finite n) where heyting = heytingR impliesR + +instance Heyting 'L Int8 where heyting = heytingL impliesL +instance Heyting 'L Int16 where heyting = heytingL impliesL +instance Heyting 'L Int32 where heyting = heytingL impliesL +instance Heyting 'L Int64 where heyting = heytingL impliesL +instance Heyting 'L Int where heyting = heytingL impliesL +instance Heyting 'R Int8 where heyting = heytingR impliesR +instance Heyting 'R Int16 where heyting = heytingR impliesR +instance Heyting 'R Int32 where heyting = heytingR impliesR +instance Heyting 'R Int64 where heyting = heytingR impliesR +instance Heyting 'R Int where heyting = heytingR impliesR + +instance Symmetric () where not _ = () +instance Symmetric Bool where not = P.not +instance Symmetric Ordering where + not LT = GT + not EQ = EQ + not GT = LT + +instance Heyting 'R Ordering where heyting = symmetricR + +instance Boolean () +instance Boolean Bool + +------------------------------------------------------------------------------- +-- Instances: sum types +------------------------------------------------------------------------------- + + + +-- | +-- Subdirectly irreducible Heyting algebra. +instance Heyting 'R a => Heyting 'R (Lowered a) where + heyting = heytingR f where + + (Left a) `f` (Left b) | a <= b = true + | otherwise = Left (a // b) + (Right _) `f` a = a + _ `f` (Right _) = true + +instance Heyting 'R a => Heyting 'R (Lifted a) where + heyting = heytingR f where + f (Right a) (Right b) = Right (a // b) + f (Left _) _ = Right true + f _ (Left _) = false + +instance Heyting 'R a => Heyting 'R (Maybe a) where + heyting = heytingR f where + f (Just a) (Just b) = Just (a // b) + f Nothing _ = Just true + f _ Nothing = Nothing + +--instance Complete k a => Complete k (Extended a) +instance Heyting 'R a => Heyting 'R (Extended a) where + heyting = heytingR f where + + Extended a `f` Extended b | a <= b = Top + | otherwise = Extended (a // b) + Top `f` a = a + _ `f` Top = Top + Bottom `f` _ = Top + _ `f` Bottom = Bottom + +--instance Symmetric a => Symmetric (Extended a) where + +------------------------------------------------------------------------------- +-- Instances: product types +------------------------------------------------------------------------------- + +instance (Heyting k a, Heyting k b) => Heyting k (a, b) where + heyting (a,b) = heyting a `strong` heyting b + +instance (Symmetric a, Symmetric b) => Symmetric (a, b) where + not = bimap not not + +instance (Boolean a, Boolean b) => Boolean (a, b) where + +------------------------------------------------------------------------------- +-- Instances: function types +------------------------------------------------------------------------------- + + +instance (U.Finite a, Biheyting b) => Heyting 'L (a -> b) where + heyting = heytingL $ liftA2 (\\) + +instance (U.Finite a, Biheyting b) => Heyting 'R (a -> b) where + heyting = heytingR $ liftA2 (//) + +instance (U.Finite a, Symmetric b) => Symmetric (a -> b) where not = fmap not + +instance (U.Finite a, Boolean b) => Boolean (a -> b) + +deriving via (a -> a) instance (U.Finite a, Biheyting a) => Heyting 'L (Endo a) +deriving via (a -> a) instance (U.Finite a, Biheyting a) => Heyting 'R (Endo a) +instance (U.Finite a, Symmetric a) => Symmetric (Endo a) +instance (U.Finite a, Boolean a) => Boolean (Endo a) + +deriving via (a -> b) instance (U.Finite a, Biheyting b) => Heyting 'L (Op b a) +deriving via (a -> b) instance (U.Finite a, Biheyting b) => Heyting 'R (Op b a) +instance (U.Finite a, Symmetric b) => Symmetric (Op b a) +instance (U.Finite a, Boolean b) => Boolean (Op b a) + +deriving via (Op Bool a) instance (U.Finite a) => Heyting 'L (Predicate a) +deriving via (Op Bool a) instance (U.Finite a) => Heyting 'R (Predicate a) +instance (U.Finite a) => Symmetric (Predicate a) +instance (U.Finite a) => Boolean (Predicate a) + +------------------------------------------------------------------------------- +-- Instances: collections +------------------------------------------------------------------------------- + + +instance (Total a, U.Finite a) => Heyting 'L (Set.Set a) where + heyting = heytingL (Set.\\) + +instance (Total a, U.Finite a) => Heyting 'R (Set.Set a) where + heyting = symmetricR + +instance (Total a, U.Finite a) => Symmetric (Set.Set a) where + not = non --(U.universe Set.\\) + +instance (Total a, U.Finite a) => Boolean (Set.Set a) where + +instance Heyting 'L IntSet.IntSet where + heyting = heytingL (IntSet.\\) + +instance Heyting 'R IntSet.IntSet where + --heyting = heytingR $ \x y -> non x \/ y + heyting = symmetricR + +instance Symmetric IntSet.IntSet where + not = non --(U.universe IntSet.\\) + +instance Boolean IntSet.IntSet where + +{- TODO pick an instance either key-aware or no +instance (Total a, U.Finite a, Lattice b) => Heyting 'L (Map.Map a b) where + heyting = heytingL (Map.\\) + +instance (Total a, U.Finite a, Heyting 'R b) => Heyting 'R (Map.Map a b) where + + heyting = heytingR $ \a b -> + let + x = Map.merge + Map.dropMissing -- drop if an element is missing in @b@ + (Map.mapMissing (\_ _ -> true)) -- put @true@ if an element is missing in @a@ + (Map.zipWithMatched (\_ -> (//) )) -- merge matching elements with @`implies`@ + a b + + y = Map.fromList [(k, true) | k <- U.universeF, not (Map.member k a), not (Map.member k b) ] + -- for elements which are not in a, nor in b add + -- a @true@ key + in + Map.union x y +{- +-- TODO: compare performance +impliesMap a b = + Map.intersection (`implies`) a b + `Map.union` Map.map (const true) (Map.difference b a) + `Map.union` Map.fromList [(k, true) | k <- universeF, not (Map.member k a), not (Map.member k b)] +-} +-} + + +{- + +-- A symmetric Heyting algebra +-- +-- λ> implies (False ... True) (False ... True) +-- Interval True True +-- λ> implies (False ... True) (singleton False) +-- Interval False False +-- λ> implies (singleton True) (False ... True) +-- Interval False True +-- +-- λ> implies ([EQ,GT] ... [EQ,GT]) ([LT] ... [LT,EQ]) :: Interval (Set.Set Ordering) +-- Interval (fromList [LT]) (fromList [LT,EQ]) +-- +-- TODO: may need /a/ to be boolean here. +implies :: Symmetric a => Interval a -> Interval a -> Interval a +implies i1 i2 = maybe iempty (uncurry (...)) $ liftA2 f (endpts i1) (endpts i2) where + f (x1,x2) (y1,y2) = (x1 // y1 /\ x2 // y2, x2 // y2) + + --TODO: would this work for interval orders? + f (x1,x2) (y1,y2) = (x1 // y1 /\ x2 // y2, x1 // y1 \/ x2 // y2) + +coimplies i1 i2 = not (not i1 `implies` not i2) + +-- The symmetry +-- neg x = true \\ not x +-- non x = not x // false +-- λ> not ([LT] ... [LT,GT]) :: Interval (Set.Set Ordering) +-- Interval (fromList [EQ]) (fromList [EQ,GT]) +-- +not :: Symmetric a => Interval a -> Interval a +not = maybe iempty (\(x1, x2) -> neg x2 ... neg x1) . endpts + +-- λ> neg' (False ... True) +-- Interval False False +-- λ> (False ... True) `implies` (singleton False) +-- Interval False False +-- +neg' x = (false ... true) `coimplies` (not x) + +-- λ> non' (False ... True) +-- Interval False False +-- λ> (singleton True) `coimplies` (False ... True) +-- Interval False False +-- +non' x = not x `implies` (singleton false) + +-} + + diff --git a/src/Data/Lattice/Property.hs b/src/Data/Lattice/Property.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lattice/Property.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE DataKinds #-} +module Data.Lattice.Property where + +import Data.Connection.Conn +import Data.Connection.Property +import Data.Order +import Data.Order.Property +import Data.Order.Syntax +import Data.Lattice +import Prelude hiding (Eq(..), Ord(..), Bounded, not) + +--foo x y z = x // y <= x // y /\ z +--foo x z y = x /\ z // y <= x // y +-- +-- x '\\' x = 'true' +-- x '/\' (x '\\' y) = x '/\' y +-- y '/\' (x '\\' y) = y +-- x '\\' (y '\\' z) = (x '/\' y) '\\' z +-- x '\\' (y '/\' z) = (x '\\' y) '/\' (x '\\' z) +-- 'neg' (x '/\' y) = 'neg' (x '\/' y) +-- 'neg' (x '\/' y) = 'neg' x '/\' 'neg' y +-- (x '\\' y) '\/' x '<=' y +-- y '<=' (x '\\' x '/\' y) +-- x '<=' y => (z '\\' x) '<=' (z '\\' y) +-- x '<=' y => (x '\\' z) '<=' (y '\\' z) +-- x '<=' y <=> x '\\' y '==' 'true' +-- x '/\' y '<=' z <=> x '<=' (y '\\' z) <=> y '<=' (x '\\' z) +-- +-- + + +-- adjointL $ ConnL (\x -> y \\ not x) (\z -> not z // not y) +symmetric1 x = neg x <= non x +symmetric2 x = (neg . neg) x == (converseR . converseL) x +symmetric3 x = (non . non) x == (converseL . converseR) x +symmetric4 x = non x == (converseL . not) x && neg x == (not . converseL) x +symmetric5 x = non x == (not . converseR) x && neg x == (converseR . not) x +symmetric6 x = neg x \/ neg (neg x) == true +symmetric7 x y = not (x /\ y) == not x \/ not y +symmetric8 x y = (not . not) (x \/ y) == not (not x) \/ not (not y) +symmetric9 x y = not (x \/ y) == not x /\ not y +symmetric10 x y = converseL (x \/ y) == converseL x \/ converseL y +symmetric11 x y = converseR (x /\ y) == converseR x /\ converseR y +symmetric12 x y = converseL (x /\ y) == (non . non) (converseL x /\ converseL y) +symmetric13 x y = converseR (x \/ y) == (neg . neg) (converseR x \/ converseR y) + +boolean0 x = neg x == non x +boolean1 x = neg (neg x) == x +boolean2 x = x \/ neg x == true +boolean3 x = x /\ non x == false +boolean4 x y = (x <= y) // (neg y <= neg x) +boolean5 x y = x \\ y == neg (neg y // neg x) +boolean6 x y = x // y == non (non y \\ non x) + + +heytingL0 :: Heyting 'L a => a -> a -> a -> Bool +heytingL0 x y z = x \\ y <= z <=> x <= y \/ z + +heytingL1 :: Heyting 'L a => a -> a -> a -> Bool +heytingL1 x y z = x \\ y >= (x /\ z) \\ y + +heytingL2 :: Heyting 'L a => a -> a -> a -> Bool +heytingL2 x y z = x \\ (y /\ z) >= x \\ y + +heytingL3 :: Heyting 'L a => a -> a -> a -> Bool +heytingL3 x y z = x >= y ==> x \\ z >= y \\ z + +heytingL4 :: Heyting 'L a => a -> a -> a -> Bool +heytingL4 x y z = z \\ (x \/ y) == z \\ x \\ y + +heytingL5 :: Heyting 'L a => a -> a -> a -> Bool +heytingL5 x y z = (y \/ z) \\ x == y \\ x \/ z \\ x + +heytingL6 :: Heyting 'L a => a -> a -> Bool +heytingL6 x y = x >= x \\ y + +heytingL7 :: Heyting 'L a => a -> a -> Bool +heytingL7 x y = x \/ y \\ x == x \/ y + +heytingL8 :: forall a. Heyting 'L a => a -> Bool +heytingL8 _ = non false == true @a && non true == false @a + +-- Double co-negation is a co-monad. +heytingL9 :: Heyting 'L a => a -> a -> Bool +heytingL9 x y = x /\ non y >= x \\ y + +heytingL10 :: Heyting 'L a => a -> a -> Bool +heytingL10 x y = x >= y <=> y \\ x == false + +heytingL11 :: Heyting 'L a => a -> a -> Bool +heytingL11 x y = non (x /\ y) >= non x + +heytingL12 :: Heyting 'L a => a -> a -> Bool +heytingL12 x y = non (y \\ x) == non (non x) \/ non y + +heytingL13 :: Heyting 'L a => a -> a -> Bool +heytingL13 x y = non (x /\ y) == non x \/ non y + +heytingL14 :: Heyting 'L a => a -> Bool +heytingL14 x = x \/ non x == true + +heytingL15 :: Heyting 'L a => a -> Bool +heytingL15 x = non (non (non x)) == non x + +heytingL16 :: Heyting 'L a => a -> Bool +heytingL16 x = non (non (x /\ non x)) == false + +heytingL17 :: Heyting 'L a => a -> Bool +heytingL17 x = x >= non (non x) + +heytingL18 :: Heyting 'L c => c -> Bool +heytingL18 x = x == boundary x \/ (non . non) x + +heytingL19 :: Heyting 'L a => a -> a -> Bool +heytingL19 x y = boundary (x /\ y) == (boundary x /\ y) \/ (x /\ boundary y) -- (Leibniz rule) + +heytingL20 :: Heyting 'L a => a -> a -> Bool +heytingL20 x y = boundary (x \/ y) \/ boundary (x /\ y) == boundary x \/ boundary y + + +heytingR0 :: Heyting 'R a => a -> a -> a -> Bool +heytingR0 x y z = x /\ y <= z <=> x <= y // z + +heytingR1 :: Heyting 'R a => a -> a -> a -> Bool +heytingR1 x y z = x // y <= x // (y \/ z) + +heytingR2 :: Heyting 'R a => a -> a -> a -> Bool +heytingR2 x y z = (x \/ z) // y <= x // y + +heytingR3 :: Heyting 'R a => a -> a -> a -> Bool +heytingR3 x y z = x <= y ==> z // x <= z // y + +heytingR4 :: Heyting 'R a => a -> a -> a -> Bool +heytingR4 x y z = (x /\ y) // z == x // y // z + +heytingR5 :: Heyting 'R a => a -> a -> a -> Bool +heytingR5 x y z = x // (y /\ z) == x // y /\ x // z + +heytingR6 :: Heyting 'R a => a -> a -> Bool +heytingR6 x y = y <= x // (x /\ y) + +heytingR7 :: Heyting 'R a => a -> a -> Bool +heytingR7 x y = x /\ x // y == x /\ y + +heytingR8 :: forall a. Heyting 'R a => a -> Bool +heytingR8 _ = neg false == true @a && neg true == false @a + +-- Double negation is a monad. +heytingR9 :: Heyting 'R a => a -> a -> Bool +heytingR9 x y = neg x \/ y <= x // y + +heytingR10 :: Heyting 'R a => a -> a -> Bool +heytingR10 x y = x <= y <=> x // y == true + +heytingR11 :: Heyting 'R a => a -> a -> Bool +heytingR11 x y = neg (x \/ y) <= neg x + +heytingR12 :: Heyting 'R a => a -> a -> Bool +heytingR12 x y = neg (x // y) == neg (neg x) /\ neg y + +heytingR13 :: Heyting 'R a => a -> a -> Bool +heytingR13 x y = neg (x \/ y) == neg x /\ neg y + +heytingR14 :: Heyting 'R a => a -> Bool +heytingR14 x = x /\ neg x == false + +heytingR15 :: Heyting 'R a => a -> Bool +heytingR15 x = neg (neg (neg x)) == neg x + +heytingR16 :: Heyting 'R a => a -> Bool +heytingR16 x = neg (neg (x \/ neg x)) == true + +heytingR17 :: Heyting 'R a => a -> Bool +heytingR17 x = x <= neg (neg x) + +{- +infix 4 `joinLe` +-- | The partial ordering induced by the join-semilattice structure. +-- +-- +-- Normally when /a/ implements 'Ord' we should have: +-- @ 'joinLe' x y = x '<=' y @ +-- +joinLe :: Lattice a => a -> a -> Bool +joinLe x y = y == x \/ y + +infix 4 `joinGe` +-- | The partial ordering induced by the join-semilattice structure. +-- +-- Normally when /a/ implements 'Ord' we should have: +-- @ 'joinGe' x y = x '>=' y @ +-- +joinGe :: Lattice a => a -> a -> Bool +joinGe x y = x == x \/ y + +-- | Partial version of 'Data.Ord.compare'. +-- +-- Normally when /a/ implements 'Preorder' we should have: +-- @ 'pcompareJoin' x y = 'pcompare' x y @ +-- +pcompareJoin :: Lattice a => a -> a -> Maybe Ordering +pcompareJoin x y + | x == y = Just EQ + | joinLe x y && x /= y = Just LT + | joinGe x y && x /= y = Just GT + | otherwise = Nothing + +infix 4 `meetLe` +-- | The partial ordering induced by the meet-semilattice structure. +-- +-- Normally when /a/ implements 'Preorder' we should have: +-- @ 'meetLe' x y = x '<~' y @ +-- +meetLe :: Lattice a => a -> a -> Bool +meetLe x y = x == x /\ y + +infix 4 `meetGe` +-- | The partial ordering induced by the meet-semilattice structure. +-- +-- Normally when /a/ implements 'Preorder' we should have: +-- @ 'meetGe' x y = x '>~' y @ +-- +meetGe :: Lattice a => a -> a -> Bool +meetGe x y = y == x /\ y + +-- | Partial version of 'Data.Ord.compare'. +-- +-- Normally when /a/ implements 'Preorder' we should have: +-- @ 'pcompareJoin' x y = 'pcompare' x y @ +-- +pcompareMeet :: Lattice a => a -> a -> Maybe Ordering +pcompareMeet x y + | x == y = Just EQ + | meetLe x y && x /= y = Just LT + | meetGe x y && x /= y = Just GT + | otherwise = Nothing + +-- | \( \forall a \in R: a \/ a = a \) +-- +-- @ 'idempotent_join' = 'absorbative' 'true' @ +-- +-- See < https:\\en.wikipedia.org/wiki/Band_(mathematics) >. +-- +-- This is a required property. +-- +idempotent_join :: Lattice r => r -> Bool +idempotent_join = idempotent_join_on (~~) + +idempotent_join_on :: Semilattice 'L r => Rel r b -> r -> b +idempotent_join_on (~~) r = (\/) r r ~~ r + +-- | \( \forall a, b, c \in R: (a \/ b) \/ c = a \/ (b \/ c) \) +-- +-- This is a required property. +-- +associative_join :: Lattice r => r -> r -> r -> Bool +associative_join = associative_on (~~) (\/) + +associative_join_on :: Semilattice 'L r => Rel r b -> r -> r -> r -> b +associative_join_on (=~) = associative_on (=~) (\/) + +-- | \( \forall a, b, c: (a \# b) \# c \doteq a \# (b \# c) \) +-- +associative_on :: Rel r b -> (r -> r -> r) -> (r -> r -> r -> b) +associative_on (~~) (#) a b c = ((a # b) # c) ~~ (a # (b # c)) + +-- | \( \forall a, b \in R: a \/ b = b \/ a \) +-- +-- This is a required property. +-- +commutative_join :: Lattice r => r -> r -> Bool +commutative_join = commutative_join_on (~~) + +commutative_join_on :: Semilattice 'L r => Rel r b -> r -> r -> b +commutative_join_on (=~) = commutative_on (=~) (\/) + + +-- | \( \forall a, b: a \# b \doteq b \# a \) +-- +commutative_on :: Rel r b -> (r -> r -> r) -> r -> r -> b +commutative_on (=~) (#) a b = (a # b) =~ (b # a) + +-- | \( \forall a, b \in R: a /\ b \/ b = b \) +-- +-- Absorbativity is a generalized form of idempotency: +-- +-- @ +-- 'absorbative' 'true' a = a \/ a = a +-- @ +-- +-- This is a required property. +-- +absorbative_on :: Lattice r => Rel r Bool -> r -> r -> Bool +absorbative_on (=~) x y = (x /\ y \/ y) =~ y + +-- | \( \forall a, b \in R: a \/ b /\ b = b \) +-- +-- Absorbativity is a generalized form of idempotency: +-- +-- @ +-- 'absorbative'' 'false' a = a \/ a = a +-- @ +-- +-- This is a required property. +-- +absorbative_on' :: Lattice r => Rel r Bool -> r -> r -> Bool +absorbative_on' (=~) x y = ((x \/ y) /\ y) =~ y + +distributive :: Lattice r => r -> r -> r -> Bool +distributive = distributive_on (~~) (/\) (\/) + +codistributive :: Lattice r => r -> r -> r -> Bool +codistributive = distributive_on (~~) (\/) (/\) + +distributive_on :: Rel r b -> (r -> r -> r) -> (r -> r -> r) -> (r -> r -> r -> b) +distributive_on (=~) (#) (%) a b c = ((a # b) % c) =~ ((a % c) # (b % c)) + +distributive_on' :: Rel r b -> (r -> r -> r) -> (r -> r -> r) -> (r -> r -> r -> b) +distributive_on' (=~) (#) (%) a b c = (c % (a # b)) =~ ((c % a) # (c % b)) + +-- | @ 'glb' x x y = x @ +-- +-- See < https:\\en.wikipedia.org/wiki/Median_algebra >. +majority_glb :: Lattice r => r -> r -> Bool +majority_glb x y = glb x y y ~~ y + +-- | @ 'glb' x y z = 'glb' z x y @ +-- +commutative_glb :: Lattice r => r -> r -> r -> Bool +commutative_glb x y z = glb x y z ~~ glb z x y + +-- | @ 'glb' x y z = 'glb' x z y @ +-- +commutative_glb' :: Lattice r => r -> r -> r -> Bool +commutative_glb' x y z = glb x y z ~~ glb x z y + +-- | @ 'glb' ('glb' x w y) w z = 'glb' x w ('glb' y w z) @ +-- +associative_glb :: Lattice r => r -> r -> r -> r -> Bool +associative_glb x y z w = glb (glb x w y) w z ~~ glb x w (glb y w z) + +distributive_glb :: (Bounded r, Lattice r) => r -> r -> r -> Bool +distributive_glb x y z = glb x y z ~~ lub x y z + +interval_glb :: Lattice r => r -> r -> r -> Bool +interval_glb x y z = glb x y z ~~ y ==> (x <~ y && y <~ z) || (z <~ y && y <~ x) + +-- | \( \forall a, b, c: a \leq b \Rightarrow a \/ (c /\ b) \eq (a \/ c) /\ b \) +-- +-- See < https:\\en.wikipedia.org/wiki/Distributivity_(order_theory)#Distributivity_for_semilattices > +-- +modular :: Lattice r => r -> r -> r -> Bool +modular a b c = a \/ (c /\ b) ~~ (a \/ c) /\ b + + +-} diff --git a/src/Data/Order.hs b/src/Data/Order.hs new file mode 100644 --- /dev/null +++ b/src/Data/Order.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# Language DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Order ( + -- * Constraint kinds + Order + , Total + -- * Preorders + , Preorder(..) + , pcomparing + -- * DerivingVia + , Base(..), N5(..) + -- * Re-exports + , Ordering(..) + , Down(..) + , Positive +) where + +import safe Control.Applicative +import safe Control.Monad.Trans.Select +import safe Control.Monad.Trans.Cont +import safe Data.Bool +import safe Data.Complex +import safe Data.Either +import safe Data.Foldable (foldl') +import safe Data.Functor.Identity +import safe Data.Functor.Contravariant +import safe Data.Int +import safe Data.List.NonEmpty +import safe Data.Maybe +import safe Data.Ord (Down(..)) +import safe Data.Semigroup +import safe Data.Universe.Class (Finite(..)) +import safe Data.Word +import safe Data.Void +import safe GHC.Real +import safe Numeric.Natural +import safe Prelude hiding (Ord(..), Bounded, until) +import safe qualified Data.IntMap as IntMap +import safe qualified Data.IntSet as IntSet +import safe qualified Data.Map as Map +import safe qualified Data.Set as Set +import safe qualified Data.Ord as Ord +import safe qualified Data.Eq as Eq +import safe qualified Data.Finite as F + + +-- | An < https://en.wikipedia.org/wiki/Order_theory#Partially_ordered_sets order > on /a/. +-- +-- Note: ideally this would be a subclass of /Preorder/. +-- +-- We instead use a constraint kind in order to retain compatibility with the +-- downstream users of /Eq/. +-- +type Order a = (Eq.Eq a, Preorder a) + +-- | A < https://en.wikipedia.org/wiki/Total_order total order > on /a/. +-- +-- Note: ideally this would be a subclass of /PartialOrder/, without instances +-- for /Float/, /Double/, /Rational/, etc. +-- +-- We instead use a constraint kind in order to retain compatibility with the +-- downstream users of /Ord/. +-- +type Total a = (Ord.Ord a, Preorder a) + +------------------------------------------------------------------------------- +-- Preorders +------------------------------------------------------------------------------- + +-- | A < https://en.wikipedia.org/wiki/Preorder preorder > on /a/. +-- +-- A preorder relation '<~' must satisfy the following two axioms: +-- +-- \( \forall x: x \leq x \) (reflexivity) +-- +-- \( \forall a, b, c: ((a \leq b) \wedge (b \leq c)) \Rightarrow (a \leq c) \) (transitivity) +-- +-- Given a preorder on /a/ one may define an equivalence relation '~~' such that +-- /a ~~ b/ if and only if /a <~ b/ and /b <~ a/. +-- +-- If no partion induced by '~~' contains more than a single element, then /a/ +-- is a partial order and we may define an 'Eq' instance such that the +-- following holds: +-- +-- @ +-- x '==' y = x '~~' y +-- x '<=' y = x '<' y '||' x '~~' y +-- @ +-- +-- Minimal complete definition: either 'pcompare' or '<~'. Using 'pcompare' can +-- be more efficient for complex types. +-- +class Preorder a where + {-# MINIMAL (<~) | pcompare #-} + + infix 4 <~, >~, <, >, ?~, ~~, /~, `pcompare`, `pmax`, `pmin` + + -- | A non-strict preorder order relation on /a/. + -- + -- Is /x/ less than or equal to /y/? + -- + -- Is /x/ less than or equal to /y/? + -- + -- '<~' is reflexive, anti-symmetric, and transitive. + -- + -- > x <~ y = x < y || x ~~ y + -- > x <~ y = maybe False (<~ EQ) (pcompare x y) + -- + -- for all /x/, /y/ in /a/. + -- + (<~) :: a -> a -> Bool + x <~ y = maybe False (Ord.<= EQ) (pcompare x y) + + -- | A converse non-strict preorder relation on /a/. + -- + -- Is /x/ greater than or equal to /y/? + -- + -- Is /x/ greater than or equal to /y/? + -- + -- '>~' is reflexive, anti-symmetric, and transitive. + -- + -- > x >~ y = x > y || x ~~ y + -- > x >~ y = maybe False (>~ EQ) (pcompare x y) + -- + -- for all /x/, /y/ in /a/. + -- + (>~) :: a -> a -> Bool + (>~) = flip (<~) + + -- | A strict preorder relation on /a/. + -- + -- Is /x/ less than /y/? + -- + -- Is /x/ less than /y/? + -- + -- '<' is irreflexive, asymmetric, and transitive. + -- + -- > x < y = x <~ y && not (y <~ x) + -- > x < y = maybe False (< EQ) (pcompare x y) + -- + -- When '<~' is antisymmetric then /a/ is a partial + -- order and we have: + -- + -- > x < y = x <~ y && x /~ y + -- + -- for all /x/, /y/ in /a/. + -- + (<) :: a -> a -> Bool + x < y = maybe False (Ord.< EQ) (pcompare x y) + + -- | A converse strict preorder relation on /a/. + -- + -- Is /x/ greater than /y/? + -- + -- Is /x/ greater than /y/? + -- + -- '>' is irreflexive, asymmetric, and transitive. + -- + -- > x > y = x >~ y && not (y >~ x) + -- > x > y = maybe False (> EQ) (pcompare x y) + -- + -- When '<~' is antisymmetric then /a/ is a partial + -- order and we have: + -- + -- > x > y = x >~ y && x /~ y + -- + -- for all /x/, /y/ in /a/. + -- + (>) :: a -> a -> Bool + (>) = flip (<) + + -- | An equivalence relation on /a/. + -- + -- Are /x/ and /y/ comparable? + -- + -- Are /x/ and /y/ comparable? + -- + -- '?~' is reflexive, symmetric, and transitive. + -- + -- If /a/ implements 'Ord' then we should have @x ?~ y = True@. + -- + (?~) :: a -> a -> Bool + x ?~ y = maybe False (const True) (pcompare x y) + + -- | An equivalence relation on /a/. + -- + -- Are /x/ and /y/ equivalent? + -- + -- Are /x/ and /y/ equivalent? + -- + -- '~~' is reflexive, symmetric, and transitive. + -- + -- > x ~~ y = x <~ y && y <~ x + -- > x ~~ y = maybe False (~~ EQ) (pcompare x y) + -- + -- Use this as a lawful substitute for '==' when comparing + -- floats, doubles, or rationals. + -- + (~~) :: a -> a -> Bool + x ~~ y = maybe False (Eq.== EQ) (pcompare x y) + + -- | Negation of '~~'. + -- + -- Are /x/ and /y/ not equivalent? + -- + (/~) :: a -> a -> Bool + x /~ y = not $ x ~~ y + + -- | A similarity relation on /a/. + -- + -- Are /x/ and /y/ either equivalent or incomparable? + -- + -- 'similar' is reflexive and symmetric, but not necessarily transitive. + -- + -- Note this is only equivalent to '==' in a total order: + -- + -- > similar (0/0 :: Float) 5 = True + -- + -- If /a/ implements 'Ord' then we should have @('~~') = 'similar' = ('==')@. + -- + similar :: a -> a -> Bool + similar x y = maybe True (Eq.== EQ) (pcompare x y) + + -- | A partial version of 'Data.Ord.compare'. + -- + -- > x < y = maybe False (< EQ) $ pcompare x y + -- > x > y = maybe False (> EQ) $ pcompare x y + -- > x <~ y = maybe False (<~ EQ) $ pcompare x y + -- > x >~ y = maybe False (>~ EQ) $ pcompare x y + -- > x ~~ y = maybe False (~~ EQ) $ pcompare x y + -- > x ?~ y = maybe False (const True) $ pcompare x y + -- > similar x y = maybe True (~~ EQ) $ pcompare x y + -- + -- If /a/ implements 'Ord' then we should have @'pcompare' x y = 'Just' '$' 'compare' x y@. + -- + pcompare :: a -> a -> Maybe Ordering + pcompare x y + | x <~ y = Just $ if y <~ x then EQ else LT + | y <~ x = Just GT + | otherwise = Nothing + + -- | A partial version of 'Data.Ord.max'. + -- + -- Returns the left-hand argument in the case of equality. + -- + pmax :: a -> a -> Maybe a + pmax x y = do + o <- pcompare x y + case o of + GT -> Just x + EQ -> Just x + LT -> Just y + + -- | A partial version of 'Data.Ord.min'. + -- + -- Returns the left-hand argument in the case of equality. + -- + pmin :: a -> a -> Maybe a + pmin x y = do + o <- pcompare x y + case o of + GT -> Just y + EQ -> Just x + LT -> Just x + +-- | A partial version of 'Data.Order.Total.comparing'. +-- +-- > pcomparing p x y = pcompare (p x) (p y) +-- +-- The partial application /pcomparing f/ induces a lawful preorder for +-- any total function /f/. +-- +pcomparing :: Preorder a => (b -> a) -> b -> b -> Maybe Ordering +pcomparing p x y = pcompare (p x) (p y) + +--------------------------------------------------------------------- +-- DerivingVia +--------------------------------------------------------------------- + +newtype Base a = Base { getBase :: a } deriving stock (Eq.Eq, Ord.Ord, Show, Functor) + deriving Applicative via Identity + + +instance Ord.Ord a => Preorder (Base a) where + x <~ y = getBase $ liftA2 (Ord.<=) x y + x >~ y = getBase $ liftA2 (Ord.>=) x y + pcompare x y = Just . getBase $ liftA2 Ord.compare x y + +--instance Preorder Void where _ <~ _ = True +deriving via (Base Void) instance Preorder Void +deriving via (Base ()) instance Preorder () +deriving via (Base Bool) instance Preorder Bool +deriving via (Base Ordering) instance Preorder Ordering +deriving via (Base Char) instance Preorder Char +deriving via (Base Word) instance Preorder Word +deriving via (Base Word8) instance Preorder Word8 +deriving via (Base Word16) instance Preorder Word16 +deriving via (Base Word32) instance Preorder Word32 +deriving via (Base Word64) instance Preorder Word64 +deriving via (Base Natural) instance Preorder Natural +deriving via (Base Int) instance Preorder Int +deriving via (Base Int8) instance Preorder Int8 +deriving via (Base Int16) instance Preorder Int16 +deriving via (Base Int32) instance Preorder Int32 +deriving via (Base Int64) instance Preorder Int64 +deriving via (Base Integer) instance Preorder Integer +deriving via (Base (F.Finite n)) instance Preorder (F.Finite n) + +--TODO move to Order and derive Preorder as well +newtype N5 a = N5 { getN5 :: a } deriving stock (Eq, Show, Functor) + deriving Applicative via Identity + +instance (Ord.Ord a, Fractional a) => Preorder (N5 a) where + x <~ y = getN5 $ liftA2 n5Le x y + +-- N5 lattice ordering: NInf <= NaN <= PInf +n5Le :: (Ord.Ord a, Fractional a) => a -> a -> Bool +n5Le x y | x Eq./= x && y Eq./= y = True + | x Eq./= x = y == 1/0 + | y Eq./= y = x == -1/0 + | otherwise = x Ord.<= y + +deriving via (N5 Float) instance Preorder Float +deriving via (N5 Double) instance Preorder Double + + +--------------------------------------------------------------------- +-- Instances +--------------------------------------------------------------------- + + + +-- N5 lattice ordering: NInf <= NaN <= PInf +{- +pinf = 1 :% 0 +ninf = (-1) :% 0 +anan = 0 :% 0 + +λ> pcompareRat anan pinf +Just LT +λ> pcompareRat pinf anan +Just GT +λ> pcompareRat anan anan +Just EQ +λ> pcompareRat anan (3 :% 5) +Nothing +-} +pcompareRat :: Rational -> Rational -> Maybe Ordering +pcompareRat (0:%0) (x:%0) = Just $ Ord.compare 0 x +pcompareRat (x:%0) (0:%0) = Just $ Ord.compare x 0 +pcompareRat (x:%0) (y:%0) = Just $ Ord.compare (signum x) (signum y) +pcompareRat (0:%0) _ = Nothing +pcompareRat _ (0:%0) = Nothing +pcompareRat _ (x:%0) = Just $ Ord.compare 0 x -- guard against div-by-zero exceptions +pcompareRat (x:%0) _ = Just $ Ord.compare x 0 +pcompareRat x y = Just $ Ord.compare x y + +-- | Positive rationals, extended with an absorbing zero. +-- +-- 'Positive' is the canonical < https://en.wikipedia.org/wiki/Semifield#Examples semifield >. +-- +type Positive = Ratio Natural + +-- N5 lattice comparison +pcomparePos :: Positive -> Positive -> Maybe Ordering +pcomparePos (0:%0) (x:%0) = Just $ Ord.compare 0 x +pcomparePos (x:%0) (0:%0) = Just $ Ord.compare x 0 +pcomparePos (_:%0) (_:%0) = Just EQ -- all non-nan infs are equal +pcomparePos (0:%0) (0:%_) = Just $ GT +pcomparePos (0:%_) (0:%0) = Just $ LT +pcomparePos (0:%0) _ = Nothing +pcomparePos _ (0:%0) = Nothing +pcomparePos (x:%y) (x':%y') = Just $ Ord.compare (x*y') (x'*y) + +instance Preorder Rational where + pcompare = pcompareRat + +instance Preorder Positive where + pcompare = pcomparePos + +instance (Preorder a, Num a) => Preorder (Complex a) where + pcompare = pcomparing $ \(x :+ y) -> x^2 + y^2 + +instance Preorder a => Preorder (Down a) where + (Down x) <~ (Down y) = y <~ x + pcompare (Down x) (Down y) = pcompare y x + +instance Preorder a => Preorder (Dual a) where + (Dual x) <~ (Dual y) = y <~ x + pcompare (Dual x) (Dual y) = pcompare y x + +instance Preorder a => Preorder (Max a) where + Max a <~ Max b = a <~ b + +instance Preorder a => Preorder (Min a) where + Min a <~ Min b = a <~ b + +instance Preorder Any where + Any x <~ Any y = x <~ y + +instance Preorder All where + All x <~ All y = y <~ x + +instance Preorder a => Preorder (Identity a) where + pcompare (Identity x) (Identity y) = pcompare x y + +instance Preorder a => Preorder (Maybe a) where + Nothing <~ _ = True + Just{} <~ Nothing = False + Just a <~ Just b = a <~ b + +instance Preorder a => Preorder [a] where + {-# SPECIALISE instance Preorder [Char] #-} + --[] <~ _ = True + --(_:_) <~ [] = False + --(x:xs) <~ (y:ys) = x <~ y && xs <~ ys + + pcompare [] [] = Just EQ + pcompare [] (_:_) = Just LT + pcompare (_:_) [] = Just GT + pcompare (x:xs) (y:ys) = case pcompare x y of + Just EQ -> pcompare xs ys + other -> other + +instance Preorder a => Preorder (NonEmpty a) where + (x :| xs) <~ (y :| ys) = x <~ y && xs <~ ys + +instance (Preorder a, Preorder b) => Preorder (Either a b) where + Right a <~ Right b = a <~ b + Right _ <~ _ = False + + Left a <~ Left b = a <~ b + Left _ <~ _ = True + +instance (Preorder a, Preorder b) => Preorder (a, b) where + (a,b) <~ (i,j) = a <~ i && b <~ j + +instance (Preorder a, Preorder b, Preorder c) => Preorder (a, b, c) where + (a,b,c) <~ (i,j,k) = a <~ i && b <~ j && c <~ k + +instance (Preorder a, Preorder b, Preorder c, Preorder d) => Preorder (a, b, c, d) where + (a,b,c,d) <~ (i,j,k,l) = a <~ i && b <~ j && c <~ k && d <~ l + +instance (Preorder a, Preorder b, Preorder c, Preorder d, Preorder e) => Preorder (a, b, c, d, e) where + (a,b,c,d,e) <~ (i,j,k,l,m) = a <~ i && b <~ j && c <~ k && d <~ l && e <~ m + +--instance (Foldable1 f, Representable f, Preorder a) => Preorder (Co f a) where +-- Co f <~ Co g = and $ liftR2 (<~) f g + +instance (Ord.Ord k, Preorder a) => Preorder (Map.Map k a) where + (<~) = Map.isSubmapOfBy (<~) + +instance Ord.Ord a => Preorder (Set.Set a) where + (<~) = Set.isSubsetOf + +instance Preorder a => Preorder (IntMap.IntMap a) where + (<~) = IntMap.isSubmapOfBy (<~) + +instance Preorder IntSet.IntSet where + (<~) = IntSet.isSubsetOf + +-- | TODO: short-circuiting version. +-- +-- >>> const 3 <~ (const 4 :: Int8 -> Int8) +-- True +-- >>> const 3 <~ (id :: Int8 -> Int8) +-- False +instance (Finite a, Preorder b) => Preorder (a -> b) where + pcompare f g = foldl' acc (Just EQ) [f x `pcompare` g x | x <- universeF] + where acc old new = do + m' <- new + n' <- old + case (m', n') of + (x , EQ) -> Just x + (EQ, y ) -> Just y + (x , y ) -> if x == y then Just x else Nothing + +instance (Finite a, Preorder a) => Preorder (Endo a) where + pcompare (Endo f) (Endo g) = pcompare f g + +instance (Finite a, Preorder b) => Preorder (Op b a) where + --universe = coerce (universe :: [b -> a]) + --universe = map Op universe + pcompare (Op f) (Op g) = pcompare f g + +instance (Finite a) => Preorder (Predicate a) where + --universe = map (Predicate . flip S.member) universe + --universe = map Op universe + pcompare (Predicate f) (Predicate g) = pcompare f g + +-- | +-- >>> cont ($ 1) == (cont ($ 2) :: Cont Bool Int8) +-- False +-- >>> cont ($ 1) == (cont ($ 2) :: Cont () Int8) +-- True +instance (Total a, Preorder r, Finite r) => Preorder (Cont r a) where + (ContT x) <~ (ContT y) = x `contLe` y + +instance (Total a, Preorder r, Finite r) => Preorder (Select r a) where + (SelectT x) <~ (SelectT y) = x `contLe` y + +contLe :: forall a b c. (Finite b, Ord.Ord a, Preorder a, Preorder b, Preorder c) => ((a -> b) -> c) -> ((a -> b) -> c) -> Bool +contLe x y = if (universeF :: [b]) ~~ [] then True else point $ counter Map.empty + where + --point :: Preorder b => a -> Bool + point ar = x ar <~ y ar + + --counter :: (Finite b, Ord.Ord a, Preorder c) => Map.Map a b -> a -> b + counter acc a = case Map.lookup a acc of + Just b -> b + + Nothing -> case [b | b <- universeF + , let acc' = Map.insert a b acc + func a' | a' < a = counter acc a' + | otherwise = counter acc' a' + , not . point $ func + ] of + (b:_) -> b + [] -> Prelude.head universeF -- Return a failed counter-example to be pruned by 'point' + + +{- +exm1, exm2, exm3 :: Cont Bool Integer +exm1 = cont $ \ib -> (ib 7 && ib 4) || ib 8 +exm2 = cont $ \ib -> (ib 7 || ib 8) && (ib 4 || ib 8) +exm3 = cont $ \ib -> (ib 7 || ib 8) && ib 4 + +-- exm1 ~~ exm2 >~ exm3 +ex1 = (exm1 ~~ exm2, exm1 ~~ exm3, exm2 ~~ exm3) --(True, False, False) +ex2 = (exm1 ~~ exm2, exm1 >~ exm3, exm2 >~ exm3) --(True, True, True) +ex3 = (exm1 ~~ exm2 \/ exm3) -- True + +-- exm2 >~ exm3 +-- λ> runCont exm2 diff +-- True +-- λ> runCont exm3 diff +-- False +diff :: Integer -> Bool +diff i = if i ~~ 7 || i ~~ 8 then True else False +-} + +--------------------------------------------------------------------- +-- Orphan Instances +--------------------------------------------------------------------- + +instance (Finite a, Eq b) => Eq (a -> b) where + f == g = and [f x == g x | x <- universeF] + +deriving via (a -> a) instance (Finite a, Eq a) => Eq (Endo a) +deriving via (a -> b) instance (Finite a, Eq b) => Eq (Op b a) +deriving via (Op Bool a) instance (Finite a) => Eq (Predicate a) diff --git a/src/Data/Order/Extended.hs b/src/Data/Order/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Data/Order/Extended.hs @@ -0,0 +1,99 @@ +{-# Language Safe #-} +{-# Language DeriveFunctor #-} +{-# Language DeriveGeneric #-} + +module Data.Order.Extended ( + -- * Lattice extensions + type Lifted + , type Lowered + , Extended(..) + , extended + --, retract + -- * Lattice Extensions + , liftMaybe + , liftEitherL + , liftEitherR + , liftExtended +) where + +import safe Data.Order +import safe Data.Order.Syntax +import safe GHC.Generics +import safe Prelude hiding (Eq(..), Ord(..),Bounded) + +type Lifted = Either () + +type Lowered a = Either a () + +-- | Add a bottom and top to a lattice. +-- +-- The top is the absorbing element for the join, and the bottom is the absorbing +-- element for the meet. +-- +data Extended a = Bottom | Extended a | Top + deriving ( Eq, Ord, Show, Generic, Functor, Generic1 ) + +-- | Eliminate an 'Extended'. +extended :: b -> b -> (a -> b) -> Extended a -> b +extended b _ _ Bottom = b +extended _ t _ Top = t +extended _ _ f (Extended x) = f x + +------------------------------------------------------------------------------- +-- Lattice extensions +------------------------------------------------------------------------------- + + +{- +lifts :: Minimal a => Eq a => (a -> b) -> a -> Lifted b +lifts = liftEitherL (== minimal) + +lifted :: Minimal b => (a -> b) -> Lifted a -> b +lifted f = either (const minimal) f + +lowered :: Maximal b => (a -> b) -> Lowered a -> b +lowered f = either f (const maximal) + +lowers :: Maximal a => Eq a => (a -> b) -> a -> Lowered b +lowers = liftEitherR (== maximal) +-} + +liftMaybe :: (a -> Bool) -> (a -> b) -> a -> Maybe b +liftMaybe p f = g where + g i | p i = Nothing + | otherwise = Just $ f i + +liftEitherL :: (a -> Bool) -> (a -> b) -> a -> Lifted b +liftEitherL p f = g where + g i | p i = Left () + | otherwise = Right $ f i + +liftEitherR :: (a -> Bool) -> (a -> b) -> a -> Lowered b +liftEitherR p f = g where + g i | p i = Right () + | otherwise = Left $ f i + +liftExtended :: (a -> Bool) -> (a -> Bool) -> (a -> b) -> a -> Extended b +liftExtended p q f = g where + g i | p i = Bottom + | q i = Top + | otherwise = Extended $ f i + +--------------------------------------------------------------------- +-- Instances +--------------------------------------------------------------------- + +instance Preorder a => Preorder (Extended a) where + _ <~ Top = True + Top <~ _ = False + Bottom <~ _ = True + _ <~ Bottom = False + Extended x <~ Extended y = x <~ y + +{- +instance Universe a => Universe (Extended a) where + universe = Top : Bottom : map Extended universe +instance Finite a => Finite (Extended a) where + universeF = Top : Bottom : map Extended universeF + cardinality = fmap (2 +) (retag (cardinality :: Tagged a Natural)) +-} diff --git a/src/Data/Order/Interval.hs b/src/Data/Order/Interval.hs new file mode 100644 --- /dev/null +++ b/src/Data/Order/Interval.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE Safe #-} + +module Data.Order.Interval ( + Interval() + , imap + , (...) + , iempty + , singleton + , contains + , endpts + --, above + --, below + --, interval + -- * Floating point intervals + , open32 + , open32L + , open32R + , open64 + , open64L + , open64R +) where + +import safe Data.Bifunctor (bimap) +import safe Data.Order +import safe Data.Order.Syntax +import safe Prelude hiding (Ord(..), Eq(..), Bounded, until) +import safe qualified Data.Eq as Eq +import safe qualified Data.Connection.Float as F32 +import safe qualified Data.Connection.Double as F64 + +--------------------------------------------------------------------- +-- Intervals +--------------------------------------------------------------------- + +-- | An interval in a poset /P/. +-- +-- An interval in a poset /P/ is a subset /I/ of /P/ with the following property: +-- +-- \( \forall x, y \in I, z \in P: x \leq z \leq y \Rightarrow z \in I \) +-- +data Interval a = Empty | Interval !a !a deriving Show + +-- | Map over an interval. +-- +-- /Note/ this is not a functor, as a non-monotonic map +-- may cause the interval to collapse to the iempty interval. +-- +imap :: Preorder b => (a -> b) -> Interval a -> Interval b +imap f = maybe iempty (uncurry (...)) . fmap (bimap f f) . endpts + +infix 3 ... + +-- | Construct an interval from a pair of points. +-- +-- /Note/: Endpoints are preorder-sorted. If /pcompare x y = Nothing/ +-- then the resulting interval will be empty. +-- +(...) :: Preorder a => a -> a -> Interval a +x ... y = case pcompare x y of + Just LT -> Interval x y + Just EQ -> Interval x y + _ -> Empty +{-# INLINE (...) #-} + +-- | The iempty interval. +-- +-- >>> iempty +-- Empty +-- +iempty :: Interval a +iempty = Empty +{-# INLINE iempty #-} + +-- | Construct an interval containing a single point. +-- +-- >>> singleton 1 +-- 1 ... 1 +-- +singleton :: a -> Interval a +singleton a = Interval a a +{-# INLINE singleton #-} + +-- | Obtain the endpoints of an interval. +-- +endpts :: Interval a -> Maybe (a, a) +endpts Empty = Nothing +endpts (Interval x y) = Just (x, y) +{-# INLINE endpts #-} + +contains :: Preorder a => Interval a -> a -> Bool +contains Empty _ = False +contains (Interval x y) p = x <~ p && p <~ y + +{- + + +-- | \( X_\geq(x) = \{ y \in X | y \geq x \} \) +-- +-- Construct the upper set of an element /x/. +-- +-- This function is monotone: +-- +-- > x <~ y <=> above x <~ above y +-- +-- by the Yoneda lemma for preorders. +-- +above :: Maximal a => a -> Interval a +above x = x ... maximal +{-# INLINE above #-} + +-- | \( X_\leq(x) = \{ y \in X | y \leq x \} \) +-- +-- Construct the lower set of an element /x/. +-- +-- This function is antitone: +-- +-- > x <~ y <=> below x >~ below y +-- +below :: Minimal a => a -> Interval a +below x = minimal ... x +{-# INLINE below #-} + + +-} + +--------------------------------------------------------------------- +-- Floating point intervals +--------------------------------------------------------------------- + + +-- | Construnct an open interval. +-- +-- >>> contains 1 $ open32 1 2 +-- False +-- >>> contains 2 $ open32 1 2 +-- False +-- +open32 :: Float -> Float -> Interval Float +open32 x y = F32.shift 1 x ... F32.shift (-1) y + +-- | Construnct a half-open interval. +-- +-- >>> contains 1 $ open32L 1 2 +-- False +-- >>> contains 2 $ open32L 1 2 +-- True +-- +open32L :: Float -> Float -> Interval Float +open32L x y = F32.shift 1 x ... y + +-- | Construnct a half-open interval. +-- +-- >>> contains 1 $ open32R 1 2 +-- True +-- >>> contains 2 $ open32R 1 2 +-- False +-- +open32R :: Float -> Float -> Interval Float +open32R x y = x ... F32.shift (-1) y + +-- | Construnct an open interval. +-- +-- >>> contains 1 $ open64 1 2 +-- False +-- >>> contains 2 $ open64 1 2 +-- False +-- +open64 :: Double -> Double -> Interval Double +open64 x y = F64.shift 1 x ... F64.shift (-1) y + +-- | Construnct a half-open interval. +-- +-- >>> contains 1 $ open64L 1 2 +-- False +-- >>> contains 2 $ open64L 1 2 +-- True +-- +open64L :: Double -> Double -> Interval Double +open64L x y = F64.shift 1 x ... y + +-- | Construnct a half-open interval. +-- +-- >>> contains 1 $ open64R 1 2 +-- True +-- >>> contains 2 $ open64R 1 2 +-- False +-- +open64R :: Double -> Double -> Interval Double +open64R x y = x ... F64.shift (-1) y + +{- +-- | Generate a list of the contents on an interval. +-- +-- Returns the list of values in the interval defined by a bounding pair. +-- +-- Lawful variant of 'enumFromTo'. +-- +indexFromTo :: Interval Float -> [Float] +indexFromTo i = case endpts i of + Nothing -> [] + Just (x, y) -> flip unfoldr x $ \i -> if i ~~ y then Nothing else Just (i, shift 1 i) +-} + +--------------------------------------------------------------------- +-- Instances +--------------------------------------------------------------------- + +instance Eq a => Eq (Interval a) where + Empty == Empty = True + Empty == _ = False + _ == Empty = False + Interval x y == Interval x' y' = x == x' && y == y' + +-- | A < https://en.wikipedia.org/wiki/Containment_order containment order > +-- +instance Preorder a => Preorder (Interval a) where + Empty <~ _ = True + _ <~ Empty = False + Interval x y <~ Interval x' y' = x' <~ x && y <~ y' + +{- +instance Bounded 'L a => Connection k (Maybe a) (Interval a) where + conn = Conn f g h where + f = maybe iempty singleton + g = maybe Nothing (Just . uncurry (\/)) . endpts + h = maybe iempty $ \x -> minimal ... x + +instance Lattice a => Connection k (Interval a) (Maybe a) where + conn = Conn f g h where + f = maybe Nothing (Just . uncurry (\/)) . endpts + g = maybe iempty singleton + h = maybe Nothing (Just . uncurry (/\)) . endpts +-} + + +{- +instance Lattice a => Lattice (Interval a) where + (\/) = joinInterval + (/\) = meetInterval + +joinInterval Empty i = i +joinInterval i Empty = i +joinInterval (I x y) (I x' y') = I (x /\ x') (y \/ y') + +instance Bounded a => Bounded (Interval a) where + bottom = Empty + top = bottom ... top +-} diff --git a/src/Data/Order/Property.hs b/src/Data/Order/Property.hs new file mode 100644 --- /dev/null +++ b/src/Data/Order/Property.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE DataKinds #-} +-- | See . +module Data.Order.Property ( + type Rel + , (==>), (<=>) + , xor, xor3 + -- * Orders + , preorder + , order + -- ** Non-strict preorders + , antisymmetric_le + , reflexive_le + , transitive_le + , connex_le + -- ** Strict preorders + , asymmetric_lt + , transitive_lt + , irreflexive_lt + , semiconnex_lt + , trichotomous_lt + -- ** Semiorders + , chain_22 + , chain_31 + -- * Equivalence relations + , symmetric_eq + , reflexive_eq + , transitive_eq + -- * Properties of generic relations + , reflexive + , irreflexive + , coreflexive + , quasireflexive + , transitive + , euclideanL + , euclideanR + , connex + , semiconnex + , trichotomous + , symmetric + , asymmetric + , antisymmetric +) where + +import Data.Connection.Conn +import Data.Order +import Data.Order.Syntax +import Data.Lattice hiding (not) +import Prelude hiding (Ord(..), Eq(..)) + +-- | See . +-- +-- Note that these properties do not exhaust all of the possibilities. +-- +-- As an example over the natural numbers, the relation \(a \# b \) defined by +-- \( a > 2 \) is neither symmetric nor antisymmetric, let alone asymmetric. +type Rel r b = r -> r -> b + +infix 1 ==> + +(==>) :: Bool -> Bool -> Bool +(==>) x y = not x || y + +infix 0 <=> + +(<=>) :: Bool -> Bool -> Bool +(<=>) x y = (x ==> y) && (y ==> x) + + + +xor3 :: Bool -> Bool -> Bool -> Bool +xor3 a b c = (a `xor` (b `xor` c)) && not (a && b && c) + +-- | Check a 'Preorder' is internally consistent. +-- +-- This is a required property. +-- +preorder :: Preorder r => r -> r -> Bool +preorder x y = + ((x <~ y) == le x y) && + ((x >~ y) == ge x y) && + ((x ?~ y) == cp x y) && + ((x ~~ y) == eq x y) && + ((x /~ y) == ne x y) && + ((x < y) == lt x y) && + ((x > y) == gt x y) && + (similar x y == sm x y) && + (pcompare x y == pcmp x y) + + where + le x1 y1 = x1 < y1 || x1 ~~ y1 + + ge = flip le + + cp x1 y1 = x1 <~ y1 || x1 >~ y1 + + eq x1 y1 = x1 <~ y1 && x1 >~ y1 + + ne x1 y1 = not $ eq x1 y1 + + lt x1 y1 = x1 <~ y1 && x1 /~ y1 + + gt = flip lt + + sm x1 y1 = not (x1 < y1) && not (x1 > y1) + + pcmp x1 y1 + | x1 <~ y1 = Just $ if y1 <~ x1 then EQ else LT + | y1 <~ x1 = Just GT + | otherwise = Nothing + + +-- | Check that an 'Order' is internally consistent. +-- +-- This is a required property. +-- +order :: Order r => r -> r -> Bool +order x y = + ((x <= y) == le x y) && + ((x >= y) == ge x y) && + ((x == y) == eq x y) && + ((x /= y) == ne x y) + + where + le x1 y1 = maybe False (<~ EQ) $ pcompare x1 y1 + + ge x1 y1 = maybe False (>~ EQ) $ pcompare x1 y1 + + eq x1 y1 = maybe False (~~ EQ) $ pcompare x1 y1 + + ne x1 y1 = not $ x1 ~~ y1 + +--------------------------------------------------------------------- +-- Non-strict preorders +--------------------------------------------------------------------- + +-- | \( \forall a, b: (a \leq b) \wedge (b \leq a) \Rightarrow a = b \) +-- +-- '<~' is an antisymmetric relation. +-- +-- This is a required property. +-- +antisymmetric_le :: Preorder r => r -> r -> Bool +antisymmetric_le = antisymmetric (~~) (<~) + +-- | \( \forall a: (a \leq a) \) +-- +-- '<~' is a reflexive relation. +-- +-- This is a required property. +-- +reflexive_le :: Preorder r => r -> Bool +reflexive_le = reflexive (<~) + +-- | \( \forall a, b, c: ((a \leq b) \wedge (b \leq c)) \Rightarrow (a \leq c) \) +-- +-- '<~' is an transitive relation. +-- +-- This is a required property. +-- +transitive_le :: Preorder r => r -> r -> r -> Bool +transitive_le = transitive (<~) + +-- | \( \forall a, b: ((a \leq b) \vee (b \leq a)) \) +-- +-- '<~' is a connex relation. +-- +connex_le :: Preorder r => r -> r -> Bool +connex_le = connex (<~) + +--------------------------------------------------------------------- +-- Strict preorders +--------------------------------------------------------------------- + +-- | \( \forall a, b: (a \lt b) \Rightarrow \neg (b \lt a) \) +-- +-- 'lt' is an asymmetric relation. +-- +-- This is a required property. +-- +asymmetric_lt :: Preorder r => r -> r -> Bool +asymmetric_lt = asymmetric (<) + +-- | \( \forall a: \neg (a \lt a) \) +-- +-- 'lt' is an irreflexive relation. +-- +-- This is a required property. +-- +irreflexive_lt :: Preorder r => r -> Bool +irreflexive_lt = irreflexive (<) + +-- | \( \forall a, b, c: ((a \lt b) \wedge (b \lt c)) \Rightarrow (a \lt c) \) +-- +-- 'lt' is a transitive relation. +-- +-- This is a required property. +-- +transitive_lt :: Preorder r => r -> r -> r -> Bool +transitive_lt = transitive (<) + +-- | \( \forall a, b: \neg (a = b) \Rightarrow ((a \lt b) \vee (b \lt a)) \) +-- +-- 'lt' is a semiconnex relation. +-- +semiconnex_lt :: Preorder r => r -> r -> Bool +semiconnex_lt = semiconnex (~~) (<) + +-- | \( \forall a, b, c: ((a \lt b) \vee (a = b) \vee (b \lt a)) \wedge \neg ((a \lt b) \wedge (a = b) \wedge (b \lt a)) \) +-- +-- In other words, exactly one of \(a \lt b\), \(a = b\), or \(b \lt a\) holds. +-- +-- If 'lt' is a trichotomous relation then the set is totally ordered. +-- +trichotomous_lt :: Preorder r => r -> r -> Bool +trichotomous_lt = trichotomous (~~) (<) + +--------------------------------------------------------------------- +-- Semiorders +--------------------------------------------------------------------- + +-- | \( \forall x, y, z, w: x \lt y \wedge y \sim z \wedge z \lt w \Rightarrow x \lt w \) +-- +-- A < https://en.wikipedia.org/wiki/Semiorder semiorder > does not allow 2-2 chains. +-- +chain_22 :: Preorder r => r -> r -> r -> r -> Bool +chain_22 x y z w = x < y && similar y z && z < w ==> x < w + +-- \( \forall x, y, z, w: x \lt y \wedge y \lt z \wedge y \sim w \Rightarrow \neg (x \sim w \wedge z \sim w) \) (3-1 chain) +-- +-- A < https://en.wikipedia.org/wiki/Semiorder semiorder > does not allow 3-1 chains. +-- +-- /Note/: This library models floats, doubles, rationals etc +-- as < https://en.wikipedia.org/wiki/Modular_lattice#Examples N5 > lattices, +-- which do not possess the 3-1 chain property and are not semiorders. +-- +chain_31 :: Preorder r => r -> r -> r -> r -> Bool +chain_31 x y z w = x < y && y < z && similar y w ==> not (similar x w && similar z w) + +--------------------------------------------------------------------- +-- Equivalence relations +--------------------------------------------------------------------- + +-- | \( \forall a, b: (a = b) \Leftrightarrow (b = a) \) +-- +-- '~~' is a symmetric relation. +-- +-- This is a required property. +-- +symmetric_eq :: Preorder r => r -> r -> Bool +symmetric_eq = symmetric (~~) + +-- | \( \forall a: (a = a) \) +-- +-- '~~' is a reflexive relation. +-- +-- This is a required property +-- +reflexive_eq :: Preorder r => r -> Bool +reflexive_eq = reflexive (~~) + +-- | \( \forall a, b, c: ((a = b) \wedge (b = c)) \Rightarrow (a = c) \) +-- +-- '~~' is a transitive relation. +-- +-- This is a required property. +-- +transitive_eq :: Preorder r => r -> r -> r -> Bool +transitive_eq = transitive (~~) + +--------------------------------------------------------------------- +-- Properties of general relations +--------------------------------------------------------------------- + +-- | \( \forall a: (a \# a) \) +-- +-- For example, ≥ is a reflexive relation but > is not. +-- +reflexive :: Rel r b -> r -> b +reflexive (#) a = a # a + +-- | \( \forall a: \neg (a \# a) \) +-- +-- For example, > is an irreflexive relation, but ≥ is not. +-- +irreflexive :: Rel r Bool -> r -> Bool +irreflexive (#) a = not $ a # a + +-- | \( \forall a, b: ((a \# b) \wedge (b \# a)) \Rightarrow (a \equiv b) \) +-- +-- For example, the relation over the integers in which each odd number is +-- related to itself is a coreflexive relation. The equality relation is the +-- only example of a relation that is both reflexive and coreflexive, and any +-- coreflexive relation is a subset of the equality relation. +-- +coreflexive :: Rel r Bool -> Rel r Bool -> r -> r -> Bool +coreflexive (%) (#) a b = (a # b) && (b # a) ==> (a % b) + +-- | \( \forall a, b: (a \# b) \Rightarrow ((a \# a) \wedge (b \# b)) \) +-- +quasireflexive :: Rel r Bool -> r -> r -> Bool +quasireflexive (#) a b = (a # b) ==> (a # a) && (b # b) + +-- | \( \forall a, b, c: ((a \# b) \wedge (a \# c)) \Rightarrow (b \# c) \) +-- +-- For example, /=/ is a right Euclidean relation because if /x = y/ and /x = z/ then /y = z/. +-- +euclideanR :: Rel r Bool -> r -> r -> r -> Bool +euclideanR (#) a b c = (a # b) && (a # c) ==> b # c + +-- | \( \forall a, b, c: ((b \# a) \wedge (c \# a)) \Rightarrow (b \# c) \) +-- +-- For example, /=/ is a left Euclidean relation because if /x = y/ and /x = z/ then /y = z/. +-- +euclideanL :: Rel r Bool -> r -> Rel r Bool +euclideanL (#) a b c = (b # a) && (c # a) ==> b # c + +-- | \( \forall a, b, c: ((a \# b) \wedge (b \# c)) \Rightarrow (a \# c) \) +-- +-- For example, "is ancestor of" is a transitive relation, while "is parent of" is not. +-- +transitive :: Rel r Bool -> r -> r -> r -> Bool +transitive (#) a b c = (a # b) && (b # c) ==> a # c + +-- | \( \forall a, b: ((a \# b) \vee (b \# a)) \) +-- +-- For example, ≥ is a connex relation, while 'divides evenly' is not. +-- +-- A connex relation cannot be symmetric, except for the universal relation. +-- +connex :: Rel r Bool -> r -> r -> Bool +connex (#) a b = (a # b) || (b # a) + +-- | \( \forall a, b: \neg (a \equiv b) \Rightarrow ((a \# b) \vee (b \# a)) \) +-- +-- A binary relation is semiconnex if it relates all pairs of _distinct_ elements in some way. +-- +-- A relation is connex if and only if it is semiconnex and reflexive. +-- +semiconnex :: Rel r Bool -> Rel r Bool -> r -> r -> Bool +semiconnex (%) (#) a b = not (a % b) ==> connex (#) a b + +-- | \( \forall a, b, c: ((a \# b) \vee (a \doteq b) \vee (b \# a)) \wedge \neg ((a \# b) \wedge (a \doteq b) \wedge (b \# a)) \) +-- +-- In other words, exactly one of \(a \# b\), \(a \doteq b\), or \(b \# a\) holds. +-- +-- For example, > is a trichotomous relation, while ≥ is not. +-- +-- Note that @ trichotomous (>) @ should hold for any 'Ord' instance. +-- +trichotomous :: Rel r Bool -> Rel r Bool -> r -> r -> Bool +trichotomous (%) (#) a b = xor3 (a # b) (a % b) (b # a) + +-- | \( \forall a, b: (a \# b) \Leftrightarrow (b \# a) \) +-- +-- For example, "is a blood relative of" is a symmetric relation, because +-- A is a blood relative of B if and only if B is a blood relative of A. +-- +symmetric :: Rel r Bool -> r -> r -> Bool +symmetric (#) a b = (a # b) <=> (b # a) + +-- | \( \forall a, b: (a \# b) \Rightarrow \neg (b \# a) \) +-- +-- For example, > is an asymmetric relation, but ≥ is not. +-- +-- A relation is asymmetric if and only if it is both antisymmetric and irreflexive. +-- +asymmetric :: Rel r Bool -> r -> r -> Bool +asymmetric (#) a b = (a # b) ==> not (b # a) + +-- | \( \forall a, b: (a \# b) \wedge (b \# a) \Rightarrow a \equiv b \) +-- +-- For example, ≥ is an antisymmetric relation; so is >, but vacuously +-- (the condition in the definition is always false). +-- +antisymmetric :: Rel r Bool -> Rel r Bool -> r -> r -> Bool +antisymmetric (%) (#) a b = (a # b) && (b # a) ==> (a % b) diff --git a/src/Data/Order/Syntax.hs b/src/Data/Order/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/Order/Syntax.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ConstraintKinds #-} +-- | Utilities for custom preludes and RebindableSyntax. +module Data.Order.Syntax ( + -- * Partial orders + Order + , (==),(/=) + , (<=),(>=) + -- * Total orders + , Total + , min ,max + , compare + , comparing + -- * Re-exports + , Eq.Eq() + , Ord.Ord() +) where + +import safe Control.Exception +import safe Data.Order +import safe qualified Data.Eq as Eq +import safe qualified Data.Ord as Ord + +import Prelude hiding (Eq(..),Ord(..)) + +------------------------------------------------------------------------------- +-- Partial orders +------------------------------------------------------------------------------- + + +infix 4 ==, /=, <=, >= + +-- | A wrapper around /==/ that forces /NaN == NaN/. +-- +(==) :: Eq.Eq a => a -> a -> Bool +(==) x y = if x Eq./= x && y Eq./= y then True else x Eq.== y + +(/=) :: Eq.Eq a => a -> a -> Bool +(/=) x y = not (x == y) + +(<=) :: Order a => a -> a -> Bool +(<=) x y = x < y || x == y + +(>=) :: Order a => a -> a -> Bool +(>=) x y = x > y || x == y + +------------------------------------------------------------------------------- +-- Total orders +------------------------------------------------------------------------------- + + +infix 4 `min`, `max`, `compare`, `comparing` + +-- | Find the minimum of two values. +-- +-- > min x y == if x <= y then x else y = True +-- +-- /Note/: this function will throw a /ArithException/ on floats and rationals +-- if one of the arguments is finite and the other is /NaN/. +-- +min :: Total a => a -> a -> a +min x y = case compare x y of + GT -> y + _ -> x + +-- | Find the minimum of two values. +-- +-- > max x y == if x >= y then x else y = True +-- +-- /Note/: this function will throw a /ArithException/ on floats and rationals +-- if one of the arguments is finite and the other is /NaN/. +-- +max :: Total a => a -> a -> a +max x y = case compare x y of + LT -> y + _ -> x + +-- | Compare two values in a total order. +-- +-- > x < y = compare x y == LT +-- > x > y = compare x y == GT +-- > x == y = compare x y == EQ +-- +-- >>> compare (1/0 :: Double) 0 +-- GT +-- >>> compare (-1/0 :: Double) 0 +-- LT +-- >>> compare (1/0 :: Double) (0/0) +-- GT +-- >>> compare (-1/0 :: Double) (0/0) +-- LT +-- +-- /Note/: this function will throw a /ArithException/ on floats and rationals +-- if one of the arguments is finite and the other is /NaN/: +-- +-- >>> compare (0/0 :: Double) 0 +-- *** Exception: divide by zero +-- +compare :: Total a => a -> a -> Ordering +compare x y = case pcompare x y of + Just o -> o + Nothing -> throw DivideByZero + +-- | Compare on the range of a function. +-- +-- > comparing p x y = compare (p x) (p y) +-- +comparing :: Total a => (b -> a) -> b -> b -> Ordering +comparing p x y = compare (p x) (p y) diff --git a/src/Data/Prd.hs b/src/Data/Prd.hs deleted file mode 100644 --- a/src/Data/Prd.hs +++ /dev/null @@ -1,690 +0,0 @@ --- {-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE CPP #-} -module Data.Prd ( - Down(..) - , Ord(min, max, compare) - , module Data.Prd -) where - -import Data.Function -import Data.Int as Int (Int, Int8, Int16, Int32, Int64) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe -import Data.Monoid hiding (First, Last) -import Data.Ord (Ord, Down(..), compare, min, max) -import Data.Ratio -import Data.Word (Word, Word8, Word16, Word32, Word64) -import GHC.Real hiding (Fractional(..), div, (^^), (^), (%)) -import Numeric.Natural ---import Data.Semigroup -import Data.Semigroup.Additive -import Data.Semigroup.Multiplicative -import Data.Semiring -import Data.Semifield (Field, Semifield, anan, pinf, ninf) -import Data.Fixed -import qualified Data.Semigroup as S -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Prelude as P - - -import Prelude hiding (Ord(..), Fractional(..),Num(..)) - -infix 4 <=, >=, <, >, =~, ~~, !~, /~, ?~, `pgt`, `pge`, `peq`, `pne`, `ple`, `plt` - --- | A partial order on /a/. --- --- A poset relation '<=' must satisfy the following three partial order axioms: --- --- \( \forall x: x \leq x \) (reflexivity) --- --- \( \forall a, b: (a \leq b) \Leftrightarrow \neg (b \leq a) \) (anti-symmetry) --- --- \( \forall a, b, c: ((a \leq b) \wedge (b \leq c)) \Rightarrow (a \leq c) \) (transitivity) --- --- If a prior equality relation is available, then a valid @Prd a@ instance may be derived from a semiorder relation 'lt' as: --- --- @ --- x '<=' y '==' 'lt' x y '||' x '==' y --- @ --- --- If /a/ is derived from a semiorder then the definition of 'lt' must satisfy the three semiorder axioms: --- --- \( \forall x, y: x \lt y \Rightarrow \neg y \lt x \) (asymmetry) --- --- \( \forall x, y, z, w: x \lt y \wedge y \sim z \wedge z \lt w \Rightarrow x \lt w \) (2-2 chain) --- --- \( \forall x, y, z, w: x \lt y \wedge y \lt z \wedge y \sim w \Rightarrow \neg (x \sim w \wedge z \sim w) \) (3-1 chain) --- --- The poset axioms on '<=' then follow from the first & second axioms on 'lt', --- however the converse is not true. While the first semiorder axiom on 'lt' follows, the second --- and third semiorder axioms forbid partial orders of four items forming two disjoint chains: --- --- * the second axiom forbids two chains of two items each (the (2+2) free poset) --- * the third axiom forbids a three-item chain with one unrelated item --- --- See also the wikipedia definitions of --- and . --- -class Prd a where - {-# MINIMAL (<=) | pcompare #-} - - -- | Non-strict partial order relation on /a/. - -- - -- '<=' is reflexive, anti-symmetric, and transitive. - -- - -- Furthermore we have: - -- - -- @ - -- x '<=' y ≡ 'maybe' 'False' ('<=' 'EQ') ('pcompare' x y) - -- x '<=' y ≡ x '<' y '||' x '=~' y - -- @ - -- for all /x/, /y/ in /a/. - -- - (<=) :: a -> a -> Bool - x <= y = maybe False (P.<= EQ) $ pcompare x y - - -- | Converse non-strict partial order relation on /a/. - -- - -- '>=' is reflexive, anti-symmetric, and transitive. - -- - -- Furthermore we have: - -- - -- @ - -- x '>=' y ≡ 'maybe' 'False' ('>=' 'EQ') ('pcompare' x y) - -- x '>=' y ≡ x '>' y '||' x '=~' y - -- @ - -- for all /x/, /y/ in /a/. - -- - (>=) :: a -> a -> Bool - (>=) = flip (<=) - - -- | Strict partial order relation on /a/. - -- - -- '<' is irreflexive, asymmetric, and transitive. - -- - -- Furthermore we have: - -- - -- @ - -- x '<' y ≡ 'maybe' 'False' ('<' 'EQ') ('pcompare' x y) - -- x '<' y ≡ x '?~' y '==>' x '<=' y '&&' x '\~' y - -- @ - -- for all /x/, /y/ in /a/. - -- - (<) :: a -> a -> Bool - x < y = maybe False (P.< EQ) $ pcompare x y - - -- | Converse strict partial order relation on /a/. - -- - -- '>' is irreflexive, asymmetric, and transitive. - -- - -- Furthermore we have: - -- - -- @ - -- x '>' y ≡ 'maybe' 'False' ('>' 'EQ') ('pcompare' x y) - -- x '>' y ≡ x '?~' y '==>' x '>=' y '&&' x '\~' y - -- @ - -- for all /x/, /y/ in /a/. - -- - (>) :: Prd a => a -> a -> Bool - x > y = maybe False (P.> EQ) $ pcompare x y - - -- | Comparability relation on /a/. - -- - -- '?~' is reflexive, symmetric, and transitive. - -- - -- Furthermore we have: - -- - -- @ - -- x '=~' y ≡ 'maybe' 'False' ('const' 'True') ('pcompare' x y) - -- x '=~' y ≡ x '<=' y '||' x '>=' y - -- @ - -- for all /x/, /y/ in /a/. - -- - -- If /a/ implements 'Ord' then we must have: - -- - -- @x '?~' y ≡ 'True'@ - -- for all /x/, /y/ in /a/. - -- - (?~) :: a -> a -> Bool - x ?~ y = maybe False (const True) $ pcompare x y - - -- | Equivalence relation on /a/. - -- - -- '=~' is reflexive, symmetric, and transitive: - -- - -- Furthermore we have: - -- - -- @ - -- x '=~' y ≡ 'maybe' 'False' ('=~' 'EQ') ('pcompare' x y) - -- x '=~' y ≡ x '<=' y '&&' x '>=' y - -- @ - -- for all /x/, /y/ in /a/. - -- - -- If /a/ implements 'Eq' then it is recommended to use the - -- same definitions for '==' and '=~'. - -- - (=~) :: a -> a -> Bool - x =~ y = maybe False (== EQ) $ pcompare x y - - -- | Negation of '=~'. - -- - (/~) :: a -> a -> Bool - x /~ y = not $ x =~ y - - -- | Similarity relation on /a/. - -- - -- '~~' is reflexive and symmetric, but not necessarily transitive. - -- - -- Furthermore we have: - -- - -- @ - -- x '>=' y ≡ 'maybe' 'True' ('=~' 'EQ') ('pcompare' x y) - -- x '~~' y ≡ 'not' (x '<' y) '&&' 'not' (x '<' y) - -- @ - -- for all /x/, /y/ in /a/. - -- - -- If /a/ implements 'Ord' then we must have: - -- - -- @x '~~' y ≡ x '=~' y @ - -- for all /x/, /y/ in /a/. - -- - (~~) :: a -> a -> Bool - x ~~ y = not (x < y) && not (x > y) - - -- | Negation of '~~'. - -- - (!~) :: a -> a -> Bool - x !~ y = not $ x ~~ y - - -- | Partial version of 'compare'. - -- - pcompare :: a -> a -> Maybe Ordering - pcompare x y - | x <= y = Just $ if y <= x then EQ else LT - | y <= x = Just GT - | otherwise = Nothing - - -type Bound a = (Minimal a, Maximal a) - --- | A minimal element of a partially ordered set. --- --- @ 'minimal' '?~' a '==>' 'minimal' '<=' a @ --- --- Note that 'minimal' needn't be comparable to all values in /a/. --- --- When /a/ is a 'Field' we should have: @ 'minimal' '==' 'ninf' @. --- --- See < https://en.wikipedia.org/wiki/Maximal_and_minimal_elements >. --- -class Prd a => Minimal a where - minimal :: a - --- | A maximal element of a partially ordered set. --- --- @ 'maximal' '?~' a '==>' 'maximal' '>=' a @ --- --- Note that 'maximal' needn't be comparable to all values in /a/. --- --- When /a/ is a 'Semifield' we should have @ 'maximal' = 'pinf' @. --- --- See < https://en.wikipedia.org/wiki/Maximal_and_minimal_elements >. --- -class Prd a => Maximal a where - maximal :: a - --- | Version of 'pcompare' that uses a semiorder relation and '=='. --- --- See . --- -pcompareEq :: Eq a => (a -> a -> Bool) -> a -> a -> Maybe Ordering -pcompareEq lt x y - | lt x y = Just LT - | x == y = Just EQ - | lt y x = Just GT - | otherwise = Nothing - --- | Version of 'pcompare' that uses 'compare'. --- -pcompareOrd :: Ord a => a -> a -> Maybe Ordering -pcompareOrd x y = Just $ x `compare` y - --- | A partial version of ('=~') --- --- Returns 'Nothing' instead of 'False' when the two values are not comparable. --- -peq :: Prd a => a -> a -> Maybe Bool -peq x y = do - o <- pcompare x y - case o of - EQ -> Just True - _ -> Just False - --- | A partial version of ('/~') --- --- Returns 'Nothing' instead of 'False' when the two values are not comparable. --- -pne :: Prd a => a -> a -> Maybe Bool -pne x y = do - o <- pcompare x y - case o of - EQ -> Just False - _ -> Just True - --- | A partial version of ('<=') --- --- Returns 'Nothing' instead of 'False' when the two values are not comparable. --- -ple :: Prd a => a -> a -> Maybe Bool -ple x y = do - o <- pcompare x y - case o of - GT -> Just False - _ -> Just True - --- | A partial version of ('>=') --- --- Returns 'Nothing' instead of 'False' when the two values are not comparable. --- -pge :: Prd a => a -> a -> Maybe Bool -pge x y = do - o <- pcompare x y - case o of - LT -> Just False - _ -> Just True - --- | A partial version of ('<') --- --- Returns 'Nothing' instead of 'False' when the two values are not comparable. --- --- @lt x y == maybe False id $ plt x y@ --- -plt :: Prd a => a -> a -> Maybe Bool -plt x y = do - o <- pcompare x y - case o of - LT -> Just True - _ -> Just False - --- | A partial version of ('>') --- --- Returns 'Nothing' instead of 'False' when the two values are not comparable. --- --- @gt x y == maybe False id $ pgt x y@ --- -pgt :: Prd a => a -> a -> Maybe Bool -pgt x y = do - o <- pcompare x y - case o of - GT -> Just True - _ -> Just False - --- | A partial version of 'Data.Ord.max'. --- --- Returns the right argument in the case of equality. --- -pmax :: Prd a => a -> a -> Maybe a -pmax x y = do - o <- pcompare x y - case o of - GT -> Just x - _ -> Just y - --- | A partial version of 'Data.Ord.min'. --- --- Returns the right argument in the case of equality. --- -pmin :: Prd a => a -> a -> Maybe a -pmin x y = do - o <- pcompare x y - case o of - GT -> Just y - _ -> Just x - -pabs :: (Additive-Group) a => Prd a => a -> a -pabs x = if zero <= x then x else negate x - -sign :: (Additive-Monoid) a => Prd a => a -> Maybe Ordering -sign x = pcompare x zero - -finite :: Prd a => Semifield a => a -> Bool -finite = (/~ anan) * (/~ pinf) - -finite' :: Prd a => Field a => a -> Bool -finite' = finite * (/~ ninf) - -extend :: (Prd a, Semifield a, Semifield b) => (a -> b) -> a -> b -extend f x | x =~ anan = anan - | x =~ pinf = pinf - | otherwise = f x - -extend' :: (Prd a, Field a, Field b) => (a -> b) -> a -> b -extend' f x | x =~ ninf = ninf - | otherwise = extend f x - ---------------------------------------------------------------------- --- Instances ---------------------------------------------------------------------- - -instance Prd a => Prd [a] where - {-# SPECIALISE instance Prd [Char] #-} - [] <= _ = True - (_:_) <= [] = False - (x:xs) <= (y:ys) = x <= y && xs <= ys - -{- - pcompare [] [] = Just EQ - pcompare [] (_:_) = Just LT - pcompare (_:_) [] = Just GT - pcompare (x:xs) (y:ys) = case pcompare x y of - Just EQ -> pcompare xs ys - other -> other --} - -instance Prd a => Prd (NonEmpty a) where - (x :| xs) <= (y :| ys) = x <= y && xs <= ys - -instance Prd a => Prd (Down a) where - (Down x) <= (Down y) = y <= x - pcompare (Down x) (Down y) = pcompare y x - --- Canonically ordered. -instance Prd a => Prd (Dual a) where - (Dual x) <= (Dual y) = y <= x - pcompare (Dual x) (Dual y) = pcompare y x - -instance Prd a => Prd (S.Max a) where - S.Max a <= S.Max b = a <= b - -instance Prd a => Prd (S.Min a) where - S.Min a <= S.Min b = a <= b - -instance Prd Any where - Any x <= Any y = x <= y - -instance Prd All where - All x <= All y = y <= x - -instance Prd Float where - x <= y | x /= x && y /= y = True - | x /= x || y /= y = False - | otherwise = x P.<= y - - x =~ y | x /= x && y /= y = True - | x /= x || y /= y = False - | otherwise = x == y - - x ?~ y | x /= x && y /= y = True - | x /= x || y /= y = False - | otherwise = True - - pcompare x y | x /= x && y /= y = Just EQ - | x /= x || y /= y = Nothing - | otherwise = pcompareOrd x y - -instance Prd Double where - x <= y | x /= x && y /= y = True - | x /= x || y /= y = False - | otherwise = x P.<= y - - x =~ y | x /= x && y /= y = True - | x /= x || y /= y = False - | otherwise = x == y - - x ?~ y | x /= x && y /= y = True - | x /= x || y /= y = False - | otherwise = True - - pcompare x y | x /= x && y /= y = Just EQ - | x /= x || y /= y = Nothing - | otherwise = pcompareOrd x y - -instance Prd (Ratio Integer) where - pcompare (x:%y) (x':%y') | (x == 0 && y == 0) && (x' == 0 && y' == 0) = Just EQ - | (x == 0 && y == 0) || (x' == 0 && y' == 0) = Nothing - | y == 0 && y' == 0 = Just $ compare (signum x) (signum x') - | y == 0 = pcompareOrd x 0 - | y' == 0 = pcompareOrd 0 x' - | otherwise = pcompareOrd (x%y) (x'%y') - ---TODO add prop tests -instance Prd (Ratio Natural) where - pcompare (x:%y) (x':%y') | (x == 0 && y == 0) && (x' == 0 && y' == 0) = Just EQ - | (x == 0 && y == 0) || (x' == 0 && y' == 0) = Nothing - | y == 0 && y' == 0 = Just EQ - | y == 0 = Just GT - | y' == 0 = Just LT - | otherwise = pcompareOrd (x*y') (x'*y) - --- Canonical semigroup ordering -instance Prd a => Prd (Maybe a) where - Just a <= Just b = a <= b - Just{} <= Nothing = False - Nothing <= _ = True - --- Canonical semigroup ordering -instance (Prd a, Prd b) => Prd (Either a b) where - Right a <= Right b = a <= b - Right _ <= _ = False - - Left e <= Left f = e <= f - Left _ <= _ = True - --- Canonical semigroup ordering -instance (Prd a, Prd b) => Prd (a, b) where - (a,b) <= (i,j) = a <= i && b <= j - -instance (Prd a, Prd b, Prd c) => Prd (a, b, c) where - (a,b,c) <= (i,j,k) = a <= i && b <= j && c <= k - -instance (Prd a, Prd b, Prd c, Prd d) => Prd (a, b, c, d) where - (a,b,c,d) <= (i,j,k,l) = a <= i && b <= j && c <= k && d <= l - -instance (Prd a, Prd b, Prd c, Prd d, Prd e) => Prd (a, b, c, d, e) where - (a,b,c,d,e) <= (i,j,k,l,m) = a <= i && b <= j && c <= k && d <= l && e <= m - -instance Ord a => Prd (Set.Set a) where - (<=) = Set.isSubsetOf - -instance (Ord k, Prd a) => Prd (Map.Map k a) where - (<=) = Map.isSubmapOfBy (<=) - -instance Prd a => Prd (IntMap.IntMap a) where - (<=) = IntMap.isSubmapOfBy (<=) - -instance Prd IntSet.IntSet where - (<=) = IntSet.isSubsetOf - -#define derivePrd(ty) \ -instance Prd ty where { \ - (<=) = (P.<=) \ -; {-# INLINE (<=) #-} \ -; (>=) = (P.>=) \ -; {-# INLINE (>=) #-} \ -; (<) = (P.<) \ -; {-# INLINE (<) #-} \ -; (>) = (P.>) \ -; {-# INLINE (>) #-} \ -; (=~) = (P.==) \ -; {-# INLINE (=~) #-} \ -; (~~) = (P.==) \ -; {-# INLINE (~~) #-} \ -; pcompare = pcompareOrd \ -; {-# INLINE pcompare #-} \ -} - -derivePrd(()) -derivePrd(Bool) -derivePrd(Char) -derivePrd(Ordering) - -derivePrd(Int) -derivePrd(Int8) -derivePrd(Int16) -derivePrd(Int32) -derivePrd(Int64) -derivePrd(Integer) - -derivePrd(Word) -derivePrd(Word8) -derivePrd(Word16) -derivePrd(Word32) -derivePrd(Word64) -derivePrd(Natural) - -derivePrd(Uni) -derivePrd(Deci) -derivePrd(Centi) -derivePrd(Milli) -derivePrd(Micro) -derivePrd(Nano) -derivePrd(Pico) - -------------------------------------------------------------------------------- --- Minimal -------------------------------------------------------------------------------- - -instance Minimal Float where minimal = ninf - -instance Minimal Double where minimal = ninf - -instance Minimal Natural where minimal = 0 - -instance Minimal (Ratio Natural) where minimal = 0 - -instance Minimal IntSet.IntSet where - minimal = IntSet.empty - -instance Prd a => Minimal (IntMap.IntMap a) where - minimal = IntMap.empty - -instance Ord a => Minimal (Set.Set a) where - minimal = Set.empty - -instance (Ord k, Prd a) => Minimal (Map.Map k a) where - minimal = Map.empty - -instance (Minimal a, Minimal b) => Minimal (a, b) where - minimal = (minimal, minimal) - -instance (Minimal a, Prd b) => Minimal (Either a b) where - minimal = Left minimal - -instance Prd a => Minimal (Maybe a) where - minimal = Nothing - -instance Maximal a => Minimal (Down a) where - minimal = Down maximal - -instance Maximal a => Minimal (Dual a) where - minimal = Dual maximal - -#define deriveMinimal(ty) \ -instance Minimal ty where { \ - minimal = minBound \ -; {-# INLINE minimal #-} \ -} - - -deriveMinimal(()) -deriveMinimal(Bool) -deriveMinimal(Ordering) - -deriveMinimal(Int) -deriveMinimal(Int8) -deriveMinimal(Int16) -deriveMinimal(Int32) -deriveMinimal(Int64) - -deriveMinimal(Word) -deriveMinimal(Word8) -deriveMinimal(Word16) -deriveMinimal(Word32) -deriveMinimal(Word64) - -------------------------------------------------------------------------------- --- Maximal -------------------------------------------------------------------------------- - -#define deriveMaximal(ty) \ -instance Maximal ty where { \ - maximal = maxBound \ -; {-# INLINE maximal #-} \ -} - - -deriveMaximal(()) -deriveMaximal(Bool) -deriveMaximal(Ordering) - -deriveMaximal(Int) -deriveMaximal(Int8) -deriveMaximal(Int16) -deriveMaximal(Int32) -deriveMaximal(Int64) - -deriveMaximal(Word) -deriveMaximal(Word8) -deriveMaximal(Word16) -deriveMaximal(Word32) -deriveMaximal(Word64) - -instance Maximal Float where maximal = pinf - -instance Maximal Double where maximal = pinf - -instance (Maximal a, Maximal b) => Maximal (a, b) where - maximal = (maximal, maximal) - -instance (Prd a, Maximal b) => Maximal (Either a b) where - maximal = Right maximal - -instance Maximal a => Maximal (Maybe a) where - maximal = Just maximal - -instance Minimal a => Maximal (Dual a) where - maximal = Dual minimal - -instance Minimal a => Maximal (Down a) where - maximal = Down minimal - -------------------------------------------------------------------------------- --- Iterators -------------------------------------------------------------------------------- - -{-# INLINE until #-} -until :: (a -> Bool) -> (a -> a -> Bool) -> (a -> a) -> a -> a -until pre rel f seed = go seed - where go x | x' `rel` x = x - | pre x = x - | otherwise = go x' - where x' = f x - -{-# INLINE while #-} -while :: (a -> Bool) -> (a -> a -> Bool) -> (a -> a) -> a -> a -while pre rel f seed = go seed - where go x | x' `rel` x = x - | not (pre x') = x - | otherwise = go x' - where x' = f x - --- | Greatest (resp. least) fixed point of a monitone (resp. antitone) function. --- --- Does not check that the function is monitone (resp. antitone). --- --- See also < http://en.wikipedia.org/wiki/Kleene_fixed-point_theorem >. --- -{-# INLINE fixed #-} -fixed :: (a -> a -> Bool) -> (a -> a) -> a -> a -fixed = while (\_ -> True) diff --git a/src/Data/Prd/Nan.hs b/src/Data/Prd/Nan.hs deleted file mode 100644 --- a/src/Data/Prd/Nan.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Prd.Nan where - -import Control.Applicative -import Data.Prd -import Data.Connection -import Data.Semiring -import Data.Semifield -import GHC.Generics (Generic, Generic1) - -import Prelude hiding (Ord(..), Num(..), Fractional(..)) - --- | A type with an additional incomparable element allowing for the possibility of undefined values. --- Isomorphic to /Maybe a/ but with a different 'Prd' instance. -data Nan a = Nan | Def a deriving ( Show, Generic, Generic1, Functor, Foldable, Traversable) - -{- - -instance Field a => Field (Nan a) where - -u + Nan = Nan + u = Nan − Nan = Nan -u · Nan = Nan · u = Nan Nan−1 = Nan -Nan u ⇔ u = Nan u Nan ⇔ u = Nan --} - -nan :: b -> (a -> b) -> Nan a -> b -nan _ f (Def y) = f y -nan x _ Nan = x - -nan' :: Semifield b => (a -> b) -> Nan a -> b -nan' f = nan anan f - -isDef :: Nan a -> Bool -isDef Nan = False -isDef _ = True - -mapNan :: (a -> b) -> Nan a -> Nan b -mapNan f = nan Nan $ Def . f - -joinNan :: Nan (Nan a) -> Nan a -joinNan Nan = Nan -joinNan (Def Nan) = Nan -joinNan (Def (Def a)) = Def a --- collectNan = joinNan . liftNan id - -liftNan :: Prd a => Semifield a => (a -> b) -> a -> Nan b -liftNan f x | x =~ anan = Nan - | otherwise = Def (f x) - --- Lift all exceptional values -liftAll :: (RealFloat a, Prd a, Bound b) => (a -> b) -> a -> Nan b -liftAll f x | isNaN x = Nan - | isInf x = Def maximal - | isInf (-x) = Def minimal - | otherwise = Def (f x) - -isInf :: (RealFloat a, Prd a) => a -> Bool -isInf x = isInfinite x && x > 0 - -defnan :: Prd a => Prd b => Conn a b -> Conn (Nan a) (Nan b) -defnan (Conn f g) = Conn (fmap f) (fmap g) - -defnan' :: Prd a => Prd b => Trip a b -> Trip (Nan a) (Nan b) -defnan' (Trip f g h) = Trip (fmap f) (fmap g) (fmap h) - ---nanfld :: Prd a => Field a => Trip (Nan a) a --- Field a => Field (Nan a) --- /Caution/ this is only legal if (Nan a) has no nans. -{- -fldnan :: Prd a => Field a => Trip a (Nan a) -fldnan = Trip f g f where - f a = if a =~ zero / zero then Nan else Def a - g = nan (zero / zero) id --} - -fldord :: Prd a => Field a => Trip a (Nan Ordering) -fldord = Trip f g h where - g (Def GT) = pinf - g (Def LT) = ninf - g (Def EQ) = zero - g Nan = anan - - f x | x =~ anan = Nan - | x =~ ninf = Def LT - | x <= zero = Def EQ - | otherwise = Def GT - - h x | x =~ anan = Nan - | x =~ pinf = Def GT - | x >= zero = Def EQ - | otherwise = Def LT - -instance Prd a => Prd (Nan a) where - Nan <= Nan = True - _ <= Nan = False - Nan <= _ = False - Def a <= Def b = a <= b - -instance Applicative Nan where - pure = Def - Nan <*> _ = Nan - Def f <*> x = f <$> x - -instance (Additive-Semigroup) a => Semigroup (Additive (Nan a)) where - Additive a <> Additive b = Additive $ liftA2 (+) a b - --- MinPlus Dioid -instance (Additive-Monoid) a => Monoid (Additive (Nan a)) where - mempty = Additive $ pure zero - -instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (Nan a)) where - Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (*) a b - --- MinPlus Dioid -instance (Multiplicative-Monoid) a => Monoid (Multiplicative (Nan a)) where - mempty = Multiplicative $ pure one - --- Presemiring with a absorbing element. -instance Presemiring a => Presemiring (Nan a) diff --git a/src/Data/Prd/Property.hs b/src/Data/Prd/Property.hs deleted file mode 100644 --- a/src/Data/Prd/Property.hs +++ /dev/null @@ -1,193 +0,0 @@ --- | See . -module Data.Prd.Property ( - -- * Typeclass consistency - consistent - -- * Equivalence relations - , symmetric - , reflexive_eq - , transitive_eq - -- * Partial orders - -- ** Non-strict partial orders - , antisymmetric - , reflexive_le - , transitive_le - -- ** Connex non-strict partial orders - , connex - -- ** Strict partial orders - , asymmetric - , transitive_lt - , irreflexive_lt - -- ** Semiconnex strict partial orders - , semiconnex - , trichotomous - -- ** Semiorders - , chain_22 - , chain_31 -) where - -import Data.Prd -import Test.Logic -import Prelude hiding (Ord(..)) - -import qualified Prelude as P -import qualified Test.Relation as R - --- | Check that 'Prd' methods are internally consistent. --- --- This is a required property. --- -consistent :: Prd r => r -> r -> Bool -consistent x y = - ((x <= y) == le x y) && - ((x >= y) == ge x y) && - ((x < y) == lt x y) && - ((x > y) == gt x y) && - ((x ?~ y) == cp x y) && - ((x =~ y) == eq x y) && - ((x /~ y) == ne x y) && - ((x ~~ y) == sm x y) && - ((x !~ y) == ns x y) && - (pcompare x y == pcmp x y) - - where - le x1 y1 = maybe False (P.<= EQ) $ pcompare x1 y1 - - ge x1 y1 = maybe False (P.>= EQ) $ pcompare x1 y1 - - lt x1 y1 = maybe False (P.< EQ) $ pcompare x1 y1 - - gt x1 y1 = maybe False (P.> EQ) $ pcompare x1 y1 - - cp x1 y1 = maybe False (const True) $ pcompare x1 y1 - - eq x1 y1 = maybe False (== EQ) $ pcompare x1 y1 - - ne x1 y1 = not $ x1 =~ y1 - - sm x1 y1 = not (x1 < y1) && not (x1 > y1) - - ns x1 y1 = not $ x1 ~~ y1 - - pcmp x1 y1 - | x1 <= y1 = Just $ if y1 <= x1 then EQ else LT - | y1 <= x1 = Just GT - | otherwise = Nothing - - --- | \( \forall a, b: (a = b) \Leftrightarrow (b = a) \) --- --- '=~' is a symmetric relation. --- --- This is a required property. --- -symmetric :: Prd r => r -> r -> Bool -symmetric = R.symmetric (=~) - --- | \( \forall a: (a = a) \) --- --- '=~' is a reflexive relation. --- --- This is a required property. --- -reflexive_eq :: Prd r => r -> Bool -reflexive_eq = R.reflexive (=~) - --- | \( \forall a, b, c: ((a = b) \wedge (b = c)) \Rightarrow (a = c) \) --- --- '=~' is a transitive relation. --- --- This is a required property. --- -transitive_eq :: Prd r => r -> r -> r -> Bool -transitive_eq = R.transitive (=~) - --- | \( \forall a, b: (a \leq b) \wedge (b \leq a) \Rightarrow a = b \) --- --- '<=' is an antisymmetric relation. --- --- This is a required property. --- -antisymmetric :: Prd r => r -> r -> Bool -antisymmetric = R.antisymmetric_on (=~) (<=) - --- | \( \forall a: (a \leq a) \) --- --- '<=' is a reflexive relation. --- --- This is a required property. --- -reflexive_le :: Prd r => r -> Bool -reflexive_le = R.reflexive (<=) - --- | \( \forall a, b, c: ((a \leq b) \wedge (b \leq c)) \Rightarrow (a \leq c) \) --- --- '<=' is an transitive relation. --- --- This is a required property. --- -transitive_le :: Prd r => r -> r -> r -> Bool -transitive_le = R.transitive (<=) - --- | \( \forall a, b: ((a \leq b) \vee (b \leq a)) \) --- --- '<=' is a connex relation. --- -connex :: Prd r => r -> r -> Bool -connex = R.connex (<=) - --- | \( \forall a, b: (a \lt b) \Rightarrow \neg (b \lt a) \) --- --- 'lt' is an asymmetric relation. --- --- This is a required property. --- -asymmetric :: Eq r => Prd r => r -> r -> Bool -asymmetric = R.asymmetric (<) - --- | \( \forall a: \neg (a \lt a) \) --- --- 'lt' is an irreflexive relation. --- --- This is a required property. --- -irreflexive_lt :: Eq r => Prd r => r -> Bool -irreflexive_lt = R.irreflexive (<) - --- | \( \forall a, b, c: ((a \lt b) \wedge (b \lt c)) \Rightarrow (a \lt c) \) --- --- 'lt' is a transitive relation. --- --- This is a required property. --- -transitive_lt :: Eq r => Prd r => r -> r -> r -> Bool -transitive_lt = R.transitive (<) - --- | \( \forall a, b: \neg (a = b) \Rightarrow ((a \lt b) \vee (b \lt a)) \) --- --- 'lt' is a semiconnex relation. --- -semiconnex :: Eq r => Prd r => r -> r -> Bool -semiconnex = R.semiconnex_on (=~) (<) - --- | \( \forall a, b, c: ((a \lt b) \vee (a = b) \vee (b \lt a)) \wedge \neg ((a \lt b) \wedge (a = b) \wedge (b \lt a)) \) --- --- In other words, exactly one of \(a \lt b\), \(a = b\), or \(b \lt a\) holds. --- --- If 'lt' is a trichotomous relation then the set is totally ordered. --- -trichotomous :: Eq r => Prd r => r -> r -> Bool -trichotomous = R.trichotomous_on (=~) (<) - --- | \( \forall x, y, z, w: x \lt y \wedge y \sim z \wedge z \lt w \Rightarrow x \lt w \) --- --- A semiorder does not allow 2-2 chains. --- -chain_22 :: Eq r => Prd r => r -> r -> r -> r -> Bool -chain_22 x y z w = x < y && y ~~ z && z < w ==> x < w - --- \( \forall x, y, z, w: x \lt y \wedge y \lt z \wedge y \sim w \Rightarrow \neg (x \sim w \wedge z \sim w) \) (3-1 chain) --- --- A semiorder does not allow 3-1 chains. --- -chain_31 :: Eq r => Prd r => r -> r -> r -> r -> Bool -chain_31 x y z w = x < y && y < z && y ~~ w ==> not (x ~~ w && z ~~ w) diff --git a/src/Data/Semigroup/Join.hs b/src/Data/Semigroup/Join.hs deleted file mode 100644 --- a/src/Data/Semigroup/Join.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Semigroup.Join where - -import Control.Applicative -import Data.Bool -import Data.Maybe -import Data.Either -import Data.Prd -import Data.Semigroup -import Data.Semigroup.Additive -import Data.Semigroup.Meet -import GHC.Generics (Generic) - -import Numeric.Natural -import Data.Word -import Data.Int -import Data.Fixed - -import Prelude ( Eq(..), Ord(..), Show, Ordering(..), Applicative(..), Functor(..), Monoid(..), Semigroup(..), (.), ($), (<$>), Integer) -import qualified Prelude as P - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet - -infixr 5 ∨ - --- | Join operation on a semilattice. --- --- >>> (> (0::Int)) ∧ ((< 10) ∨ (== 15)) $ 10 --- False --- --- >>> IntSet.fromList [1..5] ∧ IntSet.fromList [2..5] --- fromList [2,3,4,5] -(∨) :: (Join-Semigroup) a => a -> a -> a -a ∨ b = unJoin (Join a <> Join b) -{-# INLINE (∨) #-} - -bottom :: (Join-Monoid) a => a -bottom = unJoin mempty -{-# INLINE bottom #-} - -type JoinSemilattice a = (Prd a, (Join-Semigroup) a) - --- | The partial ordering induced by the join-semilattice structure. --- --- --- Normally when /a/ implements 'Prd' we should have: --- @ 'joinLeq' x y ≡ x '<=' y @ --- -joinLeq :: Eq a => (Join-Semigroup) a => a -> a -> Bool -joinLeq x y = x ∨ y == y - --- | The partial ordering induced by the join-semilattice structure. --- --- Normally when /a/ implements 'Prd' we should have: --- @ 'joinGeq' x y ≡ x '>=' y @ --- -joinGeq :: Eq a => (Join-Semigroup) a => a -> a -> Bool -joinGeq x y = x ∨ y == x - --- | Partial version of 'Data.Ord.compare'. --- --- Normally when /a/ implements 'Prd' we should have: --- @ 'pcompareJoin' x y ≡ 'pcompare' x y @ --- -pcompareJoin :: Eq a => (Join-Semigroup) a => a -> a -> Maybe Ordering -pcompareJoin x y - | x == y = Just EQ - | x ∨ y == y && x /= y = Just LT - | x ∨ y == x && x /= y = Just GT - | otherwise = Nothing - --- | A commutative 'Semigroup' under '∨'. -newtype Join a = Join { unJoin :: a } deriving (Eq, Generic, Ord, Show, Functor) - -instance Applicative Join where - pure = Join - Join f <*> Join a = Join (f a) - --- >>> Down True ∨ Down False --- Down False -instance (Meet-Semigroup) a => Semigroup (Join (Down a)) where - (<>) = liftA2 . liftA2 $ (∧) - --- >>> bottom :: Down Bool --- Down True -instance (Meet-Monoid) a => Monoid (Join (Down a)) where - mempty = pure . pure $ top - --- >>> Down True ∧ Down False --- Down True -instance (Join-Semigroup) a => Semigroup (Meet (Down a)) where - (<>) = liftA2 . liftA2 $ (∨) - --- >>> top :: Down Bool --- Down False -instance (Join-Monoid) a => Monoid (Meet (Down a)) where - mempty = pure . pure $ bottom - - -instance Semigroup (Max a) => Semigroup (Join (Max a)) where - (<>) = liftA2 (<>) - -instance (Join-Semigroup) (Max a) => Semigroup (Additive (Max a)) where - (<>) = liftA2 (∨) - -instance (Join-Monoid) (Max a) => Monoid (Additive (Max a)) where - mempty = pure bottom - --- workaround for poorly specified entailment: instance (Ord a, Bounded a) => Monoid (Max a) -instance (Minimal a, Semigroup (Max a)) => Monoid (Join (Max a)) where - mempty = pure $ Max minimal - ---------------------------------------------------------------------- --- Idempotent and selective instances ---------------------------------------------------------------------- - -{- -instance Ord a => Semigroup (Join (Down a)) where - (<>) = liftA2 . liftA2 $ (∨) - -instance (Join-Monoid) a => Monoid (Join (Down a)) where - mempty = pure . pure $ bottom --} - - -{- -instance (Join-Semigroup) a => Semigroup (Join (Dual a)) where - (<>) = liftA2 . liftA2 $ flip (∨) - -instance (Join-Monoid) a => Monoid (Join (Dual a)) where - mempty = pure . pure $ bottom - - - -instance (Join-Semigroup) a => Semigroup (Join (Down a)) where - (<>) = liftA2 . liftA2 $ (∨) - -instance (Join-Monoid) a => Monoid (Join (Down a)) where - --Join (Down a) <> Join (Down b) - mempty = pure . pure $ bottom - -instance Semigroup (Max a) => Semigroup (Join (Max a)) where - (<>) = liftA2 (<>) - --- MinPlus Predioid --- >>> Min 1 `mul` Min 2 :: Min Int --- Min {getMin = 3} -instance (Join-Semigroup) a => Semigroup (Multiplicative (Min a)) where - Multiplicative a <> Multiplicative b = Multiplicative $ liftA2 (∨) a b - --- MinPlus Dioid -instance (Join-Monoid) a => Monoid (Multiplicative (Min a)) where - mempty = Multiplicative $ pure bottom --} - - ---instance ((Join-Semigroup) a, Minimal a) => Monoid (Join a) where --- mempty = Join minimal - --- instance (Meet-Monoid) (Down a) => Monoid (Meet (Down a)) where mempty = Down <$> mempty - -instance ((Join-Semigroup) a, (Join-Semigroup) b) => Semigroup (Join (a, b)) where - Join (x1, y1) <> Join (x2, y2) = Join (x1 ∨ x2, y1 ∨ y2) - -instance (Join-Semigroup) a => Semigroup (Join (Maybe a)) where - Join (Just x) <> Join (Just y) = Join . Just $ x ∨ y - Join (x@Just{}) <> _ = Join x - Join Nothing <> y = y - -instance (Join-Semigroup) a => Monoid (Join (Maybe a)) where - mempty = Join Nothing - -instance ((Join-Semigroup) a, (Join-Semigroup) b) => Semigroup (Join (Either a b)) where - Join (Right x) <> Join (Right y) = Join . Right $ x ∨ y - - Join(x@Right{}) <> _ = Join x - Join (Left x) <> Join (Left y) = Join . Left $ x ∨ y - Join (Left _) <> y = y - -instance Ord a => Semigroup (Join (Set.Set a)) where - (<>) = liftA2 Set.union - -instance (Ord k, (Join-Semigroup) a) => Semigroup (Join (Map.Map k a)) where - (<>) = liftA2 (Map.unionWith (∨)) - -instance (Join-Semigroup) a => Semigroup (Join (IntMap.IntMap a)) where - (<>) = liftA2 (IntMap.unionWith (∨)) - -instance Semigroup (Join IntSet.IntSet) where - (<>) = liftA2 IntSet.union - -instance Monoid (Join IntSet.IntSet) where - mempty = Join IntSet.empty - -instance (Join-Semigroup) a => Monoid (Join (IntMap.IntMap a)) where - mempty = Join IntMap.empty - -instance Ord a => Monoid (Join (Set.Set a)) where - mempty = Join Set.empty - -instance (Ord k, (Join-Semigroup) a) => Monoid (Join (Map.Map k a)) where - mempty = Join Map.empty - - -#define deriveJoinSemigroup(ty) \ -instance Semigroup (Join ty) where { \ - a <> b = (P.max) <$> a <*> b \ -; {-# INLINE (<>) #-} \ -} - -deriveJoinSemigroup(()) -deriveJoinSemigroup(Bool) - -deriveJoinSemigroup(Int) -deriveJoinSemigroup(Int8) -deriveJoinSemigroup(Int16) -deriveJoinSemigroup(Int32) -deriveJoinSemigroup(Int64) -deriveJoinSemigroup(Integer) - -deriveJoinSemigroup(Word) -deriveJoinSemigroup(Word8) -deriveJoinSemigroup(Word16) -deriveJoinSemigroup(Word32) -deriveJoinSemigroup(Word64) -deriveJoinSemigroup(Natural) - -deriveJoinSemigroup(Uni) -deriveJoinSemigroup(Deci) -deriveJoinSemigroup(Centi) -deriveJoinSemigroup(Milli) -deriveJoinSemigroup(Micro) -deriveJoinSemigroup(Nano) -deriveJoinSemigroup(Pico) - - -#define deriveJoinMonoid(ty) \ -instance Monoid (Join ty) where { \ - mempty = pure minimal \ -; {-# INLINE mempty #-} \ -} - -deriveJoinMonoid(()) -deriveJoinMonoid(Bool) - -deriveJoinMonoid(Int) -deriveJoinMonoid(Int8) -deriveJoinMonoid(Int16) -deriveJoinMonoid(Int32) -deriveJoinMonoid(Int64) - -deriveJoinMonoid(Word) -deriveJoinMonoid(Word8) -deriveJoinMonoid(Word16) -deriveJoinMonoid(Word32) -deriveJoinMonoid(Word64) -deriveJoinMonoid(Natural) diff --git a/src/Data/Semigroup/Meet.hs b/src/Data/Semigroup/Meet.hs deleted file mode 100644 --- a/src/Data/Semigroup/Meet.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Semigroup.Meet ( - type (-) - , module Data.Semigroup.Meet -) where - -import Control.Applicative -import Data.Bool -import Data.Either -import Data.Fixed -import Data.Int -import Data.Maybe -import Data.Prd -import Data.Ratio -import Data.Semigroup -import Data.Semigroup.Additive -import Data.Semigroup.Multiplicative -import Data.Word -import GHC.Generics (Generic) -import Numeric.Natural -import Prelude - ( Eq(..), Ord, Show, Ordering(..), Applicative(..), Functor(..) - , Monoid(..), Semigroup(..), (.), ($), (<$>), Integer) - -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Prelude as P - -infixr 6 ∧ - --- | Meet operation on a semilattice. --- --- >>> (> (0::Int)) ∧ ((< 10) ∨ (== 15)) $ 15 --- True --- -(∧) :: (Meet-Semigroup) a => a -> a -> a -a ∧ b = unMeet (Meet a <> Meet b) -{-# INLINE (∧) #-} - -top :: (Meet-Monoid) a => a -top = unMeet mempty -{-# INLINE top #-} - --- | The partial ordering induced by the meet-semilattice structure. --- --- Normally when /a/ implements 'Prd' we should have: --- @ 'meetLeq' x y ≡ x '<=' y @ --- -meetLeq :: Eq a => (Meet-Semigroup) a => a -> a -> Bool -meetLeq x y = x ∧ y == x - --- | The partial ordering induced by the meet-semilattice structure. --- --- Normally when /a/ implements 'Prd' we should have: --- @ 'meetGeq' x y ≡ x '>=' y @ --- -meetGeq :: Eq a => (Meet-Semigroup) a => a -> a -> Bool -meetGeq x y = x ∧ y == y - --- | Partial version of 'Data.Ord.compare'. --- --- Normally when /a/ implements 'Prd' we should have: --- @ 'pcompareJoin' x y ≡ 'pcompare' x y @ --- -pcompareMeet :: Eq a => (Meet-Semigroup) a => a -> a -> Maybe Ordering -pcompareMeet x y - | x == y = Just EQ - | x ∧ y == x && x /= y = Just LT - | x ∧ y == y && x /= y = Just GT - | otherwise = Nothing - -type MeetSemilattice a = (Prd a, (Meet-Semigroup) a) - -newtype Meet a = Meet { unMeet :: a } deriving (Eq, Generic, Ord, Show, Functor) - -instance Applicative Meet where - pure = Meet - Meet f <*> Meet a = Meet (f a) - --- >>> Min 1 ∧ Min 2 :: Min Int --- Min {getMin = 1} -instance Semigroup (Min a) => Semigroup (Meet (Min a)) where - (<>) = liftA2 (<>) - -instance (Meet-Semigroup) (Min a) => Semigroup (Additive (Min a)) where - (<>) = liftA2 (∧) - -instance (Meet-Monoid) (Min a) => Monoid (Additive (Min a)) where - mempty = pure top - --- workaround for poorly specified entailment: instance (Ord a, Bounded a) => Monoid (Min a) --- >>> zero :: Min Natural --- Min {getMin = 0} -instance (Maximal a, Semigroup (Min a)) => Monoid (Meet (Min a)) where - mempty = pure $ Min maximal - ---------------------------------------------------------------------- --- Semigroup Instances ---------------------------------------------------------------------- - ---instance ((Meet-Semigroup) a, Maximal a) => Monoid (Meet a) where --- mempty = Meet maximal - - --- MaxTimes Predioid - -instance (Meet-Semigroup) a => Semigroup (Meet (Max a)) where - Meet a <> Meet b = Meet $ liftA2 (∧) a b - --- MaxTimes Dioid -instance (Meet-Monoid) a => Monoid (Meet (Max a)) where - mempty = Meet $ pure top - -instance ((Meet-Semigroup) a, (Meet-Semigroup) b) => Semigroup (Meet (a, b)) where - Meet (x1, y1) <> Meet (x2, y2) = Meet (x1 ∧ x2, y1 ∧ y2) - -instance (Meet-Semigroup) b => Semigroup (Meet (a -> b)) where - (<>) = liftA2 . liftA2 $ (∧) - {-# INLINE (<>) #-} - -instance (Meet-Monoid) b => Monoid (Meet (a -> b)) where - mempty = pure . pure $ top - -instance (Meet-Semigroup) a => Semigroup (Meet (Maybe a)) where - Meet Nothing <> _ = Meet Nothing - Meet (Just{}) <> Meet Nothing = Meet Nothing - Meet (Just x) <> Meet (Just y) = Meet . Just $ x ∧ y - - -- Mul a <> Mul b = Mul $ liftA2 (∧) a b - -instance (Meet-Monoid) a => Monoid (Meet (Maybe a)) where - mempty = Meet $ pure top - -instance ((Meet-Semigroup) a, (Meet-Semigroup) b) => Semigroup (Meet (Either a b)) where - Meet (Right x) <> Meet (Right y) = Meet . Right $ x ∧ y - Meet (Right{}) <> y = y - Meet (Left x) <> Meet (Left y) = Meet . Left $ x ∧ y - Meet (x@Left{}) <> _ = Meet x - -instance Ord a => Semigroup (Meet (Set.Set a)) where - (<>) = liftA2 Set.intersection - -instance (Ord k, (Meet-Semigroup) a) => Semigroup (Meet (Map.Map k a)) where - (<>) = liftA2 (Map.intersectionWith (∧)) - -instance (Meet-Semigroup) a => Semigroup (Meet (IntMap.IntMap a)) where - (<>) = liftA2 (IntMap.intersectionWith (∧)) - -instance Semigroup (Meet IntSet.IntSet) where - (<>) = liftA2 IntSet.intersection - -{- -instance (Ord k, (Meet-Monoid) k, (Meet-Monoid) a) => Monoid (Meet (Map.Map k a)) where - mempty = Meet $ Map.singleton top top - -instance (Meet-Monoid) a => Monoid (Meet (IntMap.IntMap a)) where - mempty = Meet $ IntMap.singleton 0 top --TODO check --} - -{- - - -instance Monoid a => Semiring (Seq.Seq a) where - (*) = liftA2 (<>) - {-# INLINE (*) #-} - - fromBoolean = fromBooleanDef $ Seq.singleton mempty - -instance (Ord k, Monoid k, Monoid a) => Semiring (Map.Map k a) where - xs * ys = foldMap (flip Map.map xs . (<>)) ys - {-# INLINE (*) #-} - - fromBoolean = fromBooleanDef $ Map.singleton mempty mempty - -instance Monoid a => Semiring (IntMap.IntMap a) where - xs * ys = foldMap (flip IntMap.map xs . (<>)) ys - {-# INLINE (*) #-} - - fromBoolean = fromBooleanDef $ IntMap.singleton 0 mempty --} - -{- -instance Semigroup (Meet ()) where - _ <> _ = pure () - {-# INLINE (<>) #-} - -instance Monoid (Meet ()) where - mempty = pure () - {-# INLINE mempty #-} - -instance Semigroup (Meet Bool) where - a <> b = (P.&&) <$> a <*> b - {-# INLINE (<>) #-} - -instance Monoid (Meet Bool) where - mempty = pure True - {-# INLINE mempty #-} --} - -#define deriveMeetSemigroup(ty) \ -instance Semigroup (Meet ty) where { \ - a <> b = (P.min) <$> a <*> b \ -; {-# INLINE (<>) #-} \ -} - -deriveMeetSemigroup(()) -deriveMeetSemigroup(Bool) - -deriveMeetSemigroup(Int) -deriveMeetSemigroup(Int8) -deriveMeetSemigroup(Int16) -deriveMeetSemigroup(Int32) -deriveMeetSemigroup(Int64) -deriveMeetSemigroup(Integer) - -deriveMeetSemigroup(Word) -deriveMeetSemigroup(Word8) -deriveMeetSemigroup(Word16) -deriveMeetSemigroup(Word32) -deriveMeetSemigroup(Word64) -deriveMeetSemigroup(Natural) - -deriveMeetSemigroup(Uni) -deriveMeetSemigroup(Deci) -deriveMeetSemigroup(Centi) -deriveMeetSemigroup(Milli) -deriveMeetSemigroup(Micro) -deriveMeetSemigroup(Nano) -deriveMeetSemigroup(Pico) - -deriveMeetSemigroup(Rational) -deriveMeetSemigroup((Ratio Natural)) - -#define deriveMeetMonoid(ty) \ -instance Monoid (Meet ty) where { \ - mempty = pure maximal \ -; {-# INLINE mempty #-} \ -} - -deriveMeetMonoid(()) -deriveMeetMonoid(Bool) - -deriveMeetMonoid(Int) -deriveMeetMonoid(Int8) -deriveMeetMonoid(Int16) -deriveMeetMonoid(Int32) -deriveMeetMonoid(Int64) - -deriveMeetMonoid(Word) -deriveMeetMonoid(Word8) -deriveMeetMonoid(Word16) -deriveMeetMonoid(Word32) -deriveMeetMonoid(Word64) diff --git a/src/Data/Semilattice.hs b/src/Data/Semilattice.hs deleted file mode 100644 --- a/src/Data/Semilattice.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Semilattice ( - type (-) - -- * Join semilattices - , JoinSemilattice - , BoundedJoinSemilattice - , Join(..) - , bottom - , (∨) - , join - , joinWith - , join1 - , joinWith1 - -- * Meet semilattices - , MeetSemilattice - , BoundedMeetSemilattice - , Meet(..) - , top - , (∧) - , meet - , meetWith - , meet1 - , meetWith1 - -- * Lattices - , 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 - - - - -{- ---(a ∧ b) ⊗ c = (a ⊗ c) ∧ (b ⊗ c), c ⊗ (a ∧ b) = (c ⊗ a) ∧ (c ⊗ b) --- (meet x y) ∧ z = x ∧ z `meet` y ∧ z - --- idempotent sup dioids ? complete (join-semi)lattices derived from <=? ---connr-distributivity (the group (E\{ε}, ⊗) is therefore reticulated) --- --- mon zero = const Nothing - --- bounded meet semilattice --- need the codistributive property & absorbtion & commutativity - -If E is a distributive lattice, then (E, ∨, ∧) is a doublyidempotent dioid, the order relation (canonical) of the dioid being defined as: -a ≤ b ⇔ a ∨ b = b. -Conversely, let (E, ⊕, ⊗) be a doubly-idempotent dioid for which ≤, the canonical -order relation relative to the law ⊕ is also a canonical order relation for ⊗: -x ≤ y ⇔ x ⊗ y = x. -Then E is a distributive lattice. --} - - --- Lattice types - - -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) - - --- | Lattices. --- --- A lattice is a partially ordered set in which every two elements have a unique join --- (least upper bound or supremum) and a unique meet (greatest lower bound or infimum). --- --- /Neutrality/ --- --- @ --- x '∨' 'minimal' = x --- x '∧' 'maximal' = x --- @ --- --- /Associativity/ --- --- @ --- x '∨' (y '∨' z) = (x '∨' y) '∨' z --- x '∧' (y '∧' z) = (x '∧' y) '∧' z --- @ --- --- /Commutativity/ --- --- @ --- x '∨' y = y '∨' x --- x '∧' y = y '∧' x --- @ --- --- /Idempotency/ --- --- @ --- x '∨' x = x --- x '∧' x = x --- @ --- --- /Absorption/ --- --- @ --- (x '∨' y) '∧' y = y --- (x '∧' y) '∨' y = y --- @ --- --- See and . --- --- Note that distributivity is _not_ a requirement for a lattice, --- however distributive lattices are idempotent, commutative dioids. --- -class LatticeLaw a => Lattice a - - --- | Birkhoff's self-dual < https://en.wikipedia.org/wiki/Median_algebra ternary median > operation. --- --- If the lattice is distributive then 'glb' has the following properties. --- --- @ --- 'glb' x y y = y --- 'glb' x y z = 'glb' z x y --- 'glb' x y z = 'glb' x z y --- 'glb' ('glb' x w y) w z = 'glb' x w ('glb' y w z) --- @ --- --- >>> glb 1 2 3 :: Int --- 2 --- >>> glb (fromList [1..3]) (fromList [3..5]) (fromList [5..7]) :: Set Int --- fromList [3,5] --- --- See 'Data.Semilattice.Property'. --- -glb :: Lattice a => a -> a -> a -> a -glb = glbWith id - --- | --- >>> glbWith N5 1 9 7 --- N5 {fromN5 = 7.0} --- >>> glbWith N5 1 9 (0/0) --- N5 {fromN5 = 9.0} -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) - --- | The order dual of 'glb'. --- -lub :: Lattice a => a -> a -> a -> a -lub = lubWith id - --- | --- >>> lubWith N5 1 9 7 --- N5 {fromN5 = 7.0} --- >>> lubWith N5 1 9 (0/0) --- N5 {fromN5 = 1.0} -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' :: 'Lattice' a => 'Minimal' a => 'Set' a -> a @ --- -join :: (Join-Monoid) a => Lattice a => Foldable f => f a -> a -join = joinWith id - --- >>> joinWith Just [1..5 :: Int] --- Just 5 --- >>> joinWith N5 [1,5,0/0] --- N5 {fromN5 = Infinity} --- >>> joinWith MaxMin $ [IntSet.fromList [1..5], IntSet.fromList [2..4]] --- MaxMin {unMaxMin = fromList [2,3,4]} -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 - --- | Fold over a collection using the multiplicative operation of an arbitrary semiring. --- --- @ --- 'meet' f = 'Data.foldr'' ((*) . f) 'top' --- @ --- --- --- >>> meetWith Just [1..5 :: Int] --- Just 1 --- >>> meetWith N5 [1,5,0/0] --- N5 {fromN5 = -Infinity} -meetWith :: (Meet-Monoid) a => Foldable t => (b -> a) -> t b -> a -meetWith f = foldr' ((∧) . f) top -{-# INLINE meetWith #-} - --- | The join of a list of join-semilattice elements (of length at least top) -join1 :: Lattice a => Foldable1 f => f a -> a -join1 = joinWith1 id - --- | Fold over a non-empty collection using the join operation of an arbitrary join semilattice. --- -joinWith1 :: Foldable1 t => Lattice a => (b -> a) -> t b -> a -joinWith1 f = unJoin . foldMap1 (Join . f) -{-# INLINE joinWith1 #-} - --- | The meet of a list of meet-semilattice elements (of length at least top) -meet1 :: Lattice a => Foldable1 f => f a -> a -meet1 = meetWith1 id - --- | Fold over a non-empty collection using the multiplicative operation of a semiring. --- --- As the collection is non-empty this does not require a distinct multiplicative unit: --- --- >>> meetWith1 Just $ 1 :| [2..5 :: Int] --- Just 120 --- >>> meetWith1 First $ 1 :| [2..(5 :: Int)] --- First {getFirst = 15} --- >>> meetWith1 First $ Nothing :| [Just (5 :: Int), Just 6, Nothing] --- First {getFirst = Just 11} --- -meetWith1 :: Foldable1 t => Lattice a => (b -> a) -> t b -> a -meetWith1 f = unMeet . foldMap1 (Meet . f) -{-# INLINE meetWith1 #-} - --- | Evaluate a lattice expression. --- --- @ (a11 ∧ .. ∧ a1m) ∨ (a21 ∧ .. ∧ a2n) ∨ ... @ --- --- >>> eval [[1, 2], [3, 4, 5], [6, 7 :: Int]] -- 1 * 2 + 3 * 4 --- 14 --- >>> eval $ sequence [[1, 2], [3, 4 :: Int]] -- 1 + 2 * 3 + 4 --- 21 --- -eval :: BoundedLattice a => Functor f => Foldable f => Foldable g => f (g a) -> a -eval = join . fmap meet - --- >>> evalWith Max [[1..4 :: Int], [0..2 :: Int]] --- Max {getMax = 24} -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 (Max . Down) $ (1 :| [2..5 :: Int]) :| [-5 :| [2..5 :: Int]] --- Max {getMax = Down 9} --- >>> evalWith1 Max $ (1 :| [2..5 :: Int]) :| [-5 :| [2..5 :: Int]] --- Max {getMax = 15} --- -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-multiply two collections. --- --- >>> cross [1,3,5 :: Int] [2,4] --- 4 --- --- >>> cross [1,2,3 :: Int] [] --- -9223372036854775808 --- -cross :: Foldable f => Applicative f => LowerBoundedLattice a => f a -> f a -> a -cross a b = join $ liftA2 (∧) a b -{-# INLINE cross #-} - --- | Cross-multiply two non-empty collections. --- -cross1 :: Foldable1 f => Apply f => Lattice a => f a -> f a -> a -cross1 a b = join1 $ liftF2 (∧) a b -{-# INLINE cross1 #-} - - - --- Lattices -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) diff --git a/src/Data/Semilattice/MaxMin.hs b/src/Data/Semilattice/MaxMin.hs deleted file mode 100644 --- a/src/Data/Semilattice/MaxMin.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Data.Semilattice.MaxMin where - -import Control.Applicative -import Data.Prd -import Data.Semilattice - -import Prelude hiding ((<=)) - -newtype MaxMin a = MaxMin { unMaxMin :: a } deriving (Show, Functor) - -instance Applicative MaxMin where - pure = MaxMin - MaxMin f <*> MaxMin a = MaxMin (f a) - -instance Prd a => Prd (MaxMin a) where - MaxMin a <= MaxMin b = a <= b - -instance Prd a => Eq (MaxMin a) where - (==) = (=~) - -instance Ord a => Semigroup (Join (MaxMin a)) where - (<>) = liftA2 . liftA2 $ max - -instance (Ord a, Minimal a) => Monoid (Join (MaxMin a)) where - mempty = pure . pure $ minimal - -instance Ord a => Semigroup (Meet (MaxMin a)) where - (<>) = liftA2 . liftA2 $ min - -instance (Ord a, Maximal a) => Monoid (Meet (MaxMin a)) where - mempty = pure . pure $ maximal - -instance (Ord a, Bound a) => Lattice (MaxMin a) diff --git a/src/Data/Semilattice/N5.hs b/src/Data/Semilattice/N5.hs deleted file mode 100644 --- a/src/Data/Semilattice/N5.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Data.Semilattice.N5 where - -import Control.Applicative -import Data.Prd -import Data.Prd.Nan -import Data.Connection -import Data.Semilattice -import Data.Semiring -import Data.Semifield - -import Prelude hiding (Num(..), Ord(..), Fractional(..), Bounded) - --- | Lift a 'Semifield' into a non-modular lattice. --- --- See --- -newtype N5 a = N5 { unN5 :: a } deriving (Show, Functor) - -n5 :: (Minimal a, Semifield a, Minimal b, Semifield b) => Conn a b -> Conn (N5 a) (N5 b) -n5 (Conn f g) = Conn (fmap f) (fmap g) - -n5' :: Semifield a => Minimal a => Bound b => Trip a (Nan b) -> Trip (N5 a) b -n5' t = Trip f g h where - Conn f g = n5l . tripl $ t - Conn _ h = n5r . tripr $ t - -n5l :: Semifield a => Minimal a => Maximal b => Conn a (Nan b) -> Conn (N5 a) b -n5l (Conn f g) = Conn f' g' where - f' (N5 x) = nan maximal id $ f x - g' = N5 . g . Def - -n5r :: Semifield b => Minimal a => Minimal b => Conn (Nan a) b -> Conn a (N5 b) -n5r (Conn f g) = Conn f' g' where - f' = N5 . f . Def - g' (N5 x) = nan minimal id $ g x - -{- -untf64 :: Conn (Bottom Unit) (N5 Double) -untf64 = Conn f g where - f = maybe (N5 ninf) (N5 . unUnit) - g (N5 x) | x >= 0 = Just . Unit $ min 1 x - | otherwise = Nothing - -nan :: b -> (a -> b) -> Nan a -> b - -extended :: Field b => (a -> b) -> Extended a -> b -extended f = nan' $ bounded ninf f pinf - -liftNan :: Prd a => Semifield a => (a -> b) -> a -> Nan b -liftNan f x | x =~ anan = Nan - | otherwise = Def (f x) --} - -joinN5 :: Minimal a => Semifield a => N5 a -> N5 a -> N5 a -joinN5 (N5 x) (N5 y) = case pcompare x y of - Just LT -> N5 y - Just EQ -> N5 x - Just GT -> N5 x - Nothing -> N5 pinf - -meetN5 :: Minimal a => Semifield a => N5 a -> N5 a -> N5 a -meetN5 (N5 x) (N5 y) = case pcompare x y of - Just LT -> N5 x - Just EQ -> N5 x - Just GT -> N5 y - Nothing -> N5 minimal - - -instance (Minimal a, Semifield a) => Prd (N5 a) where - - -- | - -- @ 'anan' '<=' 'pinf' @ - -- @ 'anan' '>=' 'ninf' @ - pcompare (N5 x) (N5 y) | x =~ y = Just EQ - | x =~ minimal = Just LT - | y =~ minimal = Just GT - | x =~ pinf = Just GT - | y =~ pinf = Just LT - | otherwise = pcompare x y - -instance (Minimal a, Semifield a) => Eq (N5 a) where - (==) = (=~) - -instance (Minimal a, Semifield a) => Minimal (N5 a) where - minimal = N5 minimal - -instance (Bound a, Semifield a) => Maximal (N5 a) where - maximal = N5 maximal - -instance (Minimal a, Semifield a) => Semigroup (Meet (N5 a)) where - (<>) = liftA2 meetN5 - -instance (Minimal a, Semifield a) => Monoid (Meet (N5 a)) where - mempty = Meet $ N5 pinf - -instance (Minimal a, Semifield a) => Semigroup (Join (N5 a)) where - (<>) = liftA2 joinN5 - -instance (Minimal a, Semifield a) => Monoid (Join (N5 a)) where - mempty = Join $ N5 minimal - -instance (Minimal a, Semifield a) => Lattice (N5 a) - -instance (Additive-Semigroup) a => Semigroup (Additive (N5 a)) where - (<>) = liftA2 (+) - -instance (Additive-Monoid) a => Monoid (Additive (N5 a)) where - mempty = pure zero - -instance (Additive-Group) a => Magma (Additive (N5 a)) where - (<<) = liftA2 (-) - -instance (Additive-Group) a => Quasigroup (Additive (N5 a)) -instance (Additive-Group) a => Loop (Additive (N5 a)) -instance (Additive-Group) a => Group (Additive (N5 a)) - -instance (Multiplicative-Semigroup) a => Semigroup (Multiplicative (N5 a)) where - (<>) = liftA2 (*) - -instance (Multiplicative-Monoid) a => Monoid (Multiplicative (N5 a)) where - mempty = pure one - -instance (Multiplicative-Group) a => Magma (Multiplicative (N5 a)) where - (<<) = liftA2 (/) - -instance (Multiplicative-Group) a => Quasigroup (Multiplicative (N5 a)) -instance (Multiplicative-Group) a => Loop (Multiplicative (N5 a)) -instance (Multiplicative-Group) a => Group (Multiplicative (N5 a)) - -instance Presemiring a => Presemiring (N5 a) -instance Semiring a => Semiring (N5 a) -instance Ring a => Ring (N5 a) -instance Semifield a => Semifield (N5 a) -instance Field a => Field (N5 a) diff --git a/src/Data/Semilattice/Property.hs b/src/Data/Semilattice/Property.hs deleted file mode 100644 --- a/src/Data/Semilattice/Property.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# Language AllowAmbiguousTypes #-} - -module Data.Semilattice.Property ( - -- * Properties of join lattices - monotone_join - , idempotent_join - , idempotent_join_on - , associative_join - , associative_join_on - , commutative_join - , commutative_join_on - , neutral_join - , neutral_join_on - , distributive_join - -- * Properties of meet semilattices - , monotone_meet - , idempotent_meet - , idempotent_meet_on - , associative_meet - , associative_meet_on - , commutative_meet - , commutative_meet_on - , neutral_meet - , neutral_meet_on - , distributive_meet - -- * Properties of lattices - , absorbative - , absorbative' - , annihilative_join - , annihilative_meet - , distributive - , codistributive - , majority_glb - , commutative_glb - , commutative_glb' - , associative_glb - --, distributive_finite_on - --, distributive_finite1_on - --, distributive_cross_on - --, distributive_cross1_on - -- * Properties of semilattice & lattice morphisms - , morphism_join - , morphism_join_on - , morphism_join' - , morphism_join_on' - , morphism_meet - , morphism_meet_on - , morphism_meet' - , morphism_meet_on' - , morphism_distributive -) where - ---import Data.Semigroup.Property as Prop -import Data.Prd hiding ((~~)) -import Data.Semigroup -import Data.Semigroup.Join -import Data.Semigroup.Meet -import Data.Semilattice -import Test.Function as Prop -import Test.Logic (Rel, (==>)) -import qualified Test.Operation as Prop - -import Prelude hiding (Ord(..), Num(..), sum) - ------------------------------------------------------------------------------------- --- Properties of join semilattices - --- | \( \forall a, b, c: b \leq c \Rightarrow b ∨ a \leq c ∨ a \) --- --- This is a required property. --- -monotone_join :: JoinSemilattice r => r -> r -> r -> Bool -monotone_join x = Prop.monotone_on (<=) (<=) (∨ x) - --- | \( \forall a \in R: a ∨ a = a \) --- --- @ 'idempotent_join' = 'absorbative' 'top' @ --- --- See < https://en.wikipedia.org/wiki/Band_(mathematics) >. --- --- This is a required property. --- -idempotent_join :: JoinSemilattice r => r -> Bool -idempotent_join = idempotent_join_on (=~) - -idempotent_join_on :: (Join-Semigroup) r => Rel r b -> r -> b -idempotent_join_on (~~) r = (∨) r r ~~ r - --- | \( \forall a, b, c \in R: (a ∨ b) ∨ c = a ∨ (b ∨ c) \) --- --- This is a required property. --- -associative_join :: JoinSemilattice r => r -> r -> r -> Bool -associative_join = Prop.associative_on (=~) (∨) - -associative_join_on :: (Join-Semigroup) r => Rel r b -> r -> r -> r -> b -associative_join_on (~~) = Prop.associative_on (~~) (∨) - --- | \( \forall a, b \in R: a ∨ b = b ∨ a \) --- --- This is a required property. --- -commutative_join :: JoinSemilattice r => r -> r -> Bool -commutative_join = commutative_join_on (=~) - -commutative_join_on :: (Join-Semigroup) r => Rel r b -> r -> r -> b -commutative_join_on (~~) = Prop.commutative_on (~~) (∨) - --- | \( \forall a \in R: (bottom ∨ a) = a \) --- --- This is a required property for bounded join semilattices. --- -neutral_join :: BoundedJoinSemilattice r => r -> Bool -neutral_join = neutral_join_on (=~) - -neutral_join_on :: (Join-Monoid) r => Rel r b -> r -> b -neutral_join_on (~~) = Prop.neutral_on (~~) (∨) bottom - --- | \( \forall a, b, c: c \leq a ∨ b \Rightarrow \exists a',b': c = a' ∨ b' \) --- --- See < https://en.wikipedia.org/wiki/Distributivity_(order_theory)#Distributivity_for_semilattices > --- --- This is a required property for distributive join semilattices. --- -distributive_join :: JoinSemilattice r => r -> r -> r -> r -> r -> Bool -distributive_join c a b a' b' = c <= a ∨ b ==> a' <= a && b' <= b && c <= a' ∨ b' - ------------------------------------------------------------------------------------- --- Properties of meet semilattices - --- | \( \forall a, b, c: b \leq c \Rightarrow b ∧ a \leq c ∧ a \) --- --- This is a required property. --- -monotone_meet :: MeetSemilattice r => r -> r -> r -> Bool -monotone_meet x = Prop.monotone_on (<=) (<=) (∧ x) - --- | \( \forall a, b, c \in R: (a * b) * c = a * (b * c) \) --- --- This is a required property. --- -associative_meet :: MeetSemilattice r => r -> r -> r -> Bool -associative_meet = associative_meet_on (=~) - -associative_meet_on :: (Meet-Semigroup) r => Rel r b -> r -> r -> r -> b -associative_meet_on (~~) = Prop.associative_on (~~) (∧) - --- | \( \forall a, b \in R: a ∧ b = b ∧ a \) --- --- This is a required property. --- -commutative_meet :: MeetSemilattice r => r -> r -> Bool -commutative_meet = commutative_meet_on (=~) - -commutative_meet_on :: (Meet-Semigroup) r => Rel r b -> r -> r -> b -commutative_meet_on (~~) = Prop.commutative_on (~~) (∧) - --- | \( \forall a \in R: a ∧ a = a \) --- --- @ 'idempotent_meet' = 'absorbative' 'bottom' @ --- --- See < https://en.wikipedia.org/wiki/Band_(mathematics) >. --- --- This is a required property. --- -idempotent_meet :: MeetSemilattice r => r -> Bool -idempotent_meet = idempotent_meet_on (=~) - -idempotent_meet_on :: (Meet-Semigroup) r => Rel r b -> r -> b -idempotent_meet_on (~~) r = (∧) r r ~~ r - --- | \( \forall a \in R: (bottom ∧ a) = a \) --- --- This is a required property for bounded meet semilattices. --- -neutral_meet :: BoundedMeetSemilattice r => r -> Bool -neutral_meet = neutral_meet_on (=~) - -neutral_meet_on :: (Meet-Monoid) r => Rel r b -> r -> b -neutral_meet_on (~~) = Prop.neutral_on (~~) (∧) top - --- | \( \forall a, b, c: c \leq a ∨ b \Rightarrow \exists a',b': c = a' ∧ b' \) --- --- See < https://en.wikipedia.org/wiki/Distributivity_(order_theory)#Distributivity_for_semilattices > --- --- This is a required property for distributive meet semilattices. --- -distributive_meet :: MeetSemilattice r => r -> r -> r -> r -> r -> Bool -distributive_meet c a b a' b' = c >= a ∧ b ==> a' >= a && b' >= b && c >= a' ∧ b' - ------------------------------------------------------------------------------------- --- Properties of lattices - --- | \( \forall a, b \in R: a ∧ b ∨ b = b \) --- --- Absorbativity is a generalized form of idempotency: --- --- @ --- 'absorbative' 'top' a = a ∨ a = a --- @ --- --- This is a required property. --- -absorbative :: Lattice r => r -> r -> Bool -absorbative x y = (x ∧ y ∨ y) =~ y - --- | \( \forall a, b \in R: a ∨ b ∧ b = b \) --- --- Absorbativity is a generalized form of idempotency: --- --- @ --- 'absorbative'' 'bottom' a = a ∨ a = a --- @ --- --- This is a required property. --- -absorbative' :: Lattice r => r -> r -> Bool -absorbative' x y = (x ∨ y ∧ y) =~ y - --- | \( \forall a \in R: (top ∨ a) = top \) --- --- If /R/ is a lattice then its top element must be annihilative. --- --- This is a required property. --- -annihilative_join :: UpperBoundedLattice r => r -> Bool -annihilative_join r = Prop.annihilative_on (=~) (∨) top r - --- | \( \forall a \in R: (bottom ∧ a) = bottom \) --- --- If /R/ is a lattice then its bottom element must be annihilative. --- --- For 'Semiring' instances this property translates to: --- --- @ --- 'zero' '*' a = 'zero' --- @ --- --- For 'Alternative' instances this property translates to: --- --- @ --- 'empty' '*>' a = 'empty' --- @ --- --- This is a required property. --- -annihilative_meet :: LowerBoundedLattice r => r -> Bool -annihilative_meet r = Prop.annihilative_on (=~) (∧) bottom r - ------------------------------------------------------------------------------------- --- Properties of distributive lattices - -distributive :: Lattice r => r -> r -> r -> Bool -distributive = Prop.distributive_on (=~) (∧) (∨) - --- | \( \forall a, b, c \in R: c ∨ (a ∧ b) \equiv (c ∨ a) ∧ (c ∨ b) \) --- --- A right-codistributive semiring has a right-annihilative meet: --- --- @ 'codistributive' 'top' a 'bottom' = 'top' '=~' 'top' '∨' a @ --- --- idempotent mulitiplication: --- --- @ 'codistributive' 'bottom' 'bottom' a = a '=~' a '∧' a @ --- --- and idempotent addition: --- --- @ 'codistributive' a 'bottom' a = a '=~' a '∨' a @ --- --- Furthermore if /R/ is commutative then it is a right-distributive lattice. --- -codistributive :: Lattice r => r -> r -> r -> Bool -codistributive = Prop.distributive_on' (=~) (∧) (∨) - --- | @ 'glb' x x y = x @ --- -majority_glb :: Lattice r => r -> r -> Bool -majority_glb x y = glb x y y =~ y - --- | @ 'glb' x y z = 'glb' z x y @ --- -commutative_glb :: Lattice r => r -> r -> r -> Bool -commutative_glb x y z = glb x y z =~ glb z x y - --- | @ 'glb' x y z = 'glb' x z y @ --- -commutative_glb' :: Lattice r => r -> r -> r -> Bool -commutative_glb' x y z = glb x y z =~ glb x z y - --- | @ 'glb' ('glb' x w y) w z = 'glb' x w ('glb' y w z) @ --- -associative_glb :: Lattice r => r -> r -> r -> r -> Bool -associative_glb x y z w = glb (glb x w y) w z =~ glb x w (glb y w z) - ------------------------------------------------------------------------------------- --- Properties of semilattice & lattice morphisms - --- | \( \forall a, b: f(a ∨ b) = f(a) ∨ f(b) \) --- --- Given two join-semilattices (S, ∨) and (T, ∨), a homomorphism is a monotone function /f: S → T/ such that --- --- @ f (x '∨' y) '=~' f x '∨' f y @ --- --- This is a required property for join semilattice morphisms. --- -morphism_join :: JoinSemilattice r => JoinSemilattice s => (r -> s) -> r -> r -> Bool -morphism_join = morphism_join_on (=~) - -morphism_join_on :: (Join-Semigroup) r => (Join-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b -morphism_join_on (~~) f x y = (f $ x ∨ y) ~~ (f x ∨ f y) - --- | \( \forall a, b: f(bottom) = bottom \) --- --- This is a required property for bounded join semilattice morphisms. --- -morphism_join' :: BoundedJoinSemilattice r => BoundedJoinSemilattice s => (r -> s) -> Bool -morphism_join' = morphism_join_on' (=~) - -morphism_join_on' :: (Join-Monoid) r => (Join-Monoid) s => Rel s b -> (r -> s) -> b -morphism_join_on' (~~) f = (f bottom) ~~ bottom - --- | \( \forall a, b: f(a ∧ b) = f(a) ∧ f(b) \) --- --- The obvious dual replacing '∧' with '∨' and 'bottom' with 'top' transforms this --- definition of a join-semilattice homomorphism into its meet-semilattice equivalent. --- --- This is a required property for meet semilattice morphisms. --- -morphism_meet :: MeetSemilattice r => MeetSemilattice s => (r -> s) -> r -> r -> Bool -morphism_meet = morphism_meet_on (=~) - -morphism_meet_on :: (Meet-Semigroup) r => (Meet-Semigroup) s => Rel s b -> (r -> s) -> r -> r -> b -morphism_meet_on (~~) f x y = (f $ x ∧ y) ~~ (f x ∧ f y) - --- | \( \forall a, b: f(top) = top \) --- --- This is a required property for bounded meet semilattice morphisms. --- -morphism_meet' :: BoundedMeetSemilattice r => BoundedMeetSemilattice s => (r -> s) -> Bool -morphism_meet' = morphism_meet_on' (=~) - -morphism_meet_on' :: (Meet-Monoid) r => (Meet-Monoid) s => Rel s b -> (r -> s) -> b -morphism_meet_on' (~~) f = (f top) ~~ top - --- | Distributive lattice morphisms are compatible with 'glb'. --- -morphism_distributive :: Prd r => Prd s => Lattice r => Lattice s => (r -> s) -> r -> r -> r -> Bool -morphism_distributive f x y z = f (glb x y z) =~ glb (f x) (f y) (f z) diff --git a/src/Data/Semilattice/Top.hs b/src/Data/Semilattice/Top.hs deleted file mode 100644 --- a/src/Data/Semilattice/Top.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Semilattice.Top where - -import Data.Prd -import Data.Prd.Nan -import Data.Semilattice -import Data.Semifield -import GHC.Generics (Generic, Generic1) - -import Prelude hiding (Ord(..), Bounded) - -type Bottom a = Maybe a -type Bounded a = Bottom (Top a) -type Lifted a = Nan (Top a) -type Lowered a = Nan (Bottom a) -type Extended a = Nan (Bounded a) - -data Top a = Fin a | Top - deriving (Show, Generic, Generic1, Functor, Foldable, Traversable) - --- analagous to Maybe Semigroup instance -instance Semigroup a => Semigroup (Top a) where - Top <> _ = Top - _ <> Top = Top - Fin x <> Fin y = Fin $ x <> y - -instance Monoid a => Monoid (Top a) where - mempty = Fin mempty - -instance Prd a => Prd (Top a) where - _ <= Top = True - Top <= _ = False - Fin a <= Fin b = a <= b - -instance Minimal a => Minimal (Top a) where - minimal = Fin minimal - -instance Prd a => Maximal (Top a) where - maximal = Top - --- analagous to Maybe (Meet-Semigroup) instance -instance (Join-Semigroup) a => Semigroup (Join (Top a)) where - Join Top <> _ = Join Top - Join (Fin{}) <> Join Top = Join Top - Join (Fin x) <> Join (Fin y) = Join . Fin $ x ∨ y - --- analagous to Maybe (Meet-Monoid) instance -instance (Join-Monoid) a => Monoid (Join (Top a)) where - mempty = Join $ Fin bottom - -instance (Meet-Semigroup) a => Semigroup (Meet (Top a)) where - Meet (Fin x) <> Meet (Fin y) = Meet . Fin $ x ∧ y - Meet (x@Fin{}) <> _ = Meet x - Meet Top <> y = y - -instance (Meet-Semigroup) a => Monoid (Meet (Top a)) where - mempty = Meet Top - -instance Lattice a => Lattice (Top a) - -{- - -instance Covered (Top Float) where - Bounded x <. Bounded y = shiftf 1 x == y - -instance Graded (Top Float) where - rank (Bounded x) | ind x = 0 - | otherwise = r where - x' = floatInt32 x - y' = floatInt32 ninf - r = fromIntegral . abs $ x' - y' --} - - -isTop :: Bounded a -> Bool -isTop = bounded False (const False) True - -isBottom :: Bounded a -> Bool -isBottom = bounded True (const False) False - -isFin :: Bounded a -> Bool -isFin = bounded False (const True) False - -fin :: a -> Bounded a -fin = Just . Fin - -toTop :: Prd a => LowerBoundedLattice b => (a -> b) -> Bounded a -> Top b -toTop f = bounded (Fin bottom) (Fin . f) Top - -toBottom :: Prd a => UpperBoundedLattice b => (a -> b) -> Bounded a -> Bottom b -toBottom f = bounded Nothing (Just . f) (Just top) - -topped :: (a -> b) -> b -> Top a -> b -topped f _ (Fin a) = f a -topped _ b Top = b - -lifted :: Semifield b => (a -> b) -> Lifted a -> b -lifted f = nan' $ topped f pinf - -bounded :: b -> (a -> b) -> b -> Bounded a -> b -bounded b _ _ Nothing = b -bounded _ f _ (Just (Fin a)) = f a -bounded _ _ b (Just Top) = b - --- | Interpret @'Bounded' a@ using the 'BoundedLattice' of @a@. --- --- This map is monotone when /f/ is. --- -bounded' :: BoundedLattice b => (a -> b) -> Bounded a -> b -bounded' f = bounded bottom f top - -extended :: b -> b -> (a -> b) -> b -> Extended a -> b -extended x y f z = nan x $ bounded y f z - -extended' :: Field b => (a -> b) -> Extended a -> b -extended' f = extended anan ninf f pinf - --- this is a monotone map -liftTop :: Maximal a => (a -> b) -> a -> Top b -liftTop f = g where - g i | i =~ maximal = Top - | otherwise = Fin $ f i - -liftTop' :: Maximal a => (a -> b) -> a -> Bounded b -liftTop' f a = Just $ liftTop f a - --- This map is a lattice morphism when /f/ is. -liftBottom :: Minimal a => (a -> b) -> a -> Bottom b -liftBottom f = g where - g i | i =~ minimal = Nothing - | otherwise = Just $ f i - -liftBottom' :: Minimal a => (a -> b) -> a -> Bounded b -liftBottom' f = liftBottom (Fin . f) - --- this is a monotone map -liftBounded :: Bound a => (a -> b) -> a -> Bounded b -liftBounded f = liftBottom (liftTop f) - --- Lift all exceptional values -liftExtended :: Bound a => Field a => (a -> b) -> a -> Extended b -liftExtended f = liftNan (liftBounded f) diff --git a/src/Numeric/Prelude.hs b/src/Numeric/Prelude.hs deleted file mode 100644 --- a/src/Numeric/Prelude.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE RebindableSyntax #-} -module Numeric.Prelude - ( -- * Combinators - id, - (.), - ($), - ($!), - (&), - const, - flip, - on, - seq, - -- * Primitive types - -- ** Bool - Bool (..), - bool, - (&&), - (||), - not, - otherwise, - ifThenElse, - -- ** Char - Char, - -- ** Int - Integer, - Int, - Int8, - Int16, - Int32, - Int64, - -- ** Word - Natural, - Word, - Word8, - Word16, - Word32, - Word64, - -- ** Rational - Ratio(..), - -- ** Floating - Float, - Double, - fmod, floor, ceil, trunc, round, - sqrt, cbrt, pow, log, exp, ldexp, - pi, sin, cos, tan, - asin, acos, atan, atan2, - sinh, cosh, tanh, - asinh, acosh, atanh, - -- * Numerical Typeclasses - -- ** Eq - Eq (..), - -- ** Orders - Prd (..), - Ordering (..), - min, max, - compare, - comparing, - -- ** Connections - TripRatio(..), - ConnInteger(..), - fromRational, - fromInteger, - floor16, ceil16, round16, trunc16, - floor32, ceil32, round32, trunc32, - -- ** Magmas - Semigroup (..), - Monoid (..), - mreplicate, - Magma(..), - Quasigroup, - Loop, - Group(..), - -- ** Semirings - Semiring, - Ring, - (+), (-), (*), (^), - zero, one, - abs, - negate, - signum, - sum, - product, - -- ** Semifields - Semifield, - Field, - (/), (^^), - pinf, ninf, anan, - recip, - -- * Data structures - -- ** Either - Either (..), - either, - -- ** Maybe - Maybe (..), - fromMaybe, - maybe, - -- ** Tuple - fst, - snd, - curry, - uncurry, - -- * Algebraic structures - -- ** Functor - Functor (..), - (<$>), - ($>), - void, - -- ** Bifunctor - Bifunctor (..), - -- ** Applicative - Applicative (..), - (<**>), - liftA3, - -- ** Alternative - Alternative (..), - asum, - -- ** Traversable - Traversable (..), - for, - -- ** Monad - Monad ((>>=), (>>), return), - (=<<), - forM, - forM_, - mapM_, - when, - -- ** MonadPlus - MonadPlus (..), - guard, - msum, - -- ** Foldable - Foldable (foldMap, fold), - foldl', foldr', - for_, - traverse_, - -- ** Show - Show (..), - -- *** ShowS - ShowS, - showString, - ) where - -import Control.Applicative ((<**>), Alternative (..), Applicative (..), empty, liftA3) -import Control.Monad ((=<<), Monad (..), MonadPlus (..), forM, forM_, guard, mapM_, msum, when) -import Data.Bifunctor (Bifunctor (..), first, second) -import Data.Bool ((&&), Bool (..), bool, not, otherwise, (||)) -import Data.Char (Char) -import Data.Connection.Int (ConnInteger(..), fromInteger) -import Data.Connection.Ratio (TripRatio(..), fromRational) -import Data.Connection.Round (floor16, ceil16, trunc16, round16, floor32, ceil32, trunc32, round32) -import Data.Either (Either (..), either) -import Data.Eq (Eq (..)) -import Data.Float (fmod, floor, ceil, trunc, round, sqrt, cbrt, pow, log, exp, ldexp, sin, cos, tan - , asin, acos, atan, atan2, sinh, cosh, tanh, asinh, acosh, atanh) -import Data.Foldable (Foldable (), asum, fold, foldMap, foldl', foldr', for_, traverse_) -import Data.Function (($), (&), (.), const, flip, id, on) -import Data.Functor (($>), (<$>), Functor (..), void) -import Data.Int (Int, Int16, Int32, Int64, Int8) -import Data.Maybe (Maybe (..), fromMaybe, maybe) -import Data.Monoid (Monoid (..)) -import Data.Ord (Ordering (..), min, max, compare, comparing) -import Data.Prd (Prd (..)) -import Data.Semifield (Semifield, Field, (/), (^^), anan, pinf, ninf, recip) -import Data.Semigroup (Semigroup (..)) -import Data.Semiring (Semiring, Ring, (+), (-), (*), (^), zero, one, abs, negate, signum, sum, product) -import Data.Semiring (Magma(..), Quasigroup, Loop, Group(..), mreplicate) -import Data.Traversable (Traversable (..), for) -import Data.Tuple (curry, fst, snd, uncurry) -import Data.Word (Word, Word16, Word32, Word64, Word8) -import GHC.Real (Ratio(..)) -import Numeric.Natural (Natural) -import Text.Show (Show (..), ShowS, showString) - -import Prelude (($!), Double, Float, Integer, seq) - -pi :: TripRatio Integer b => b -pi = 3.141592653589793238 - --- Used in conjunction with RebindableSyntax. -ifThenElse :: Bool -> a -> a -> a -ifThenElse b x y = bool y x b -{-# INLINE ifThenElse #-} diff --git a/test/Test/Data/Connection.hs b/test/Test/Data/Connection.hs --- a/test/Test/Data/Connection.hs +++ b/test/Test/Data/Connection.hs @@ -1,25 +1,31 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} module Test.Data.Connection where -import Control.Applicative -import Data.Float -import Data.Ord -import Data.Prd -import Data.Prd.Nan -import Data.Ratio -import Data.Semifield -import Data.Semilattice.N5 -import Data.Semilattice.Top +import Control.Applicative hiding (empty) +import Data.Connection +import Data.Connection.Conn +import Data.Connection.Ratio +import Data.Foldable +import Data.Lattice +import Data.Word +import Data.Order +import Data.Order.Extended +import Data.Order.Interval import GHC.Real hiding (Fractional(..), (^^), (^), div) import Hedgehog import Numeric.Natural -import Prelude hiding (Bounded) -import qualified Data.Connection.Property as Prop +import Prelude hiding (Eq(..),Ord(..),Bounded) import qualified Hedgehog.Gen as G import qualified Hedgehog.Range as R +import Data.Connection.Property as Prop +import Data.Lattice.Property +import Data.Order.Property +import Data.Order.Syntax -ri :: (Integral a, Bound a) => Range a -ri = R.linearFrom 0 minimal maximal +ri :: (Integral a, Lattice a) => Range a +ri = R.linearFrom 0 false true ri' :: Range Integer ri' = R.linearFrom 0 (- 2^127) (2^127) @@ -40,46 +46,70 @@ ord = G.element [LT, EQ, GT] f32 :: Gen Float -f32 = gen_fld $ G.float rf +f32 = gen_flt $ G.float rf f64 :: Gen Double -f64 = gen_fld $ G.double rd +f64 = gen_flt $ G.double rd rat :: Gen (Ratio Integer) -rat = gen_fld $ G.realFrac_ (R.linearFracFrom 0 (- 2^127) (2^127)) +rat = G.frequency [(49, gen), (1, G.element [-1 :% 0, 1 :% 0, 0 :% 0])] + where gen = G.realFrac_ (R.linearFracFrom 0 (- 2^127) (2^127)) pos :: Gen (Ratio Natural) -pos = G.frequency [(49, gen), (1, G.element [pinf, anan])] +pos = G.frequency [(49, gen), (1, G.element [1 :% 0, 0 :% 0])] where gen = G.realFrac_ (R.linearFracFrom 0 0 (2^127)) -gen_dwn :: Gen a -> Gen (Down a) -gen_dwn gen = Down <$> gen +-- potentially ineffiecient +gen_ivl :: Preorder a => Gen a -> Gen a -> Gen (Interval a) +gen_ivl g1 g2 = liftA2 (...) g1 g2 -gen_nan :: Gen a -> Gen (Nan a) -gen_nan gen = G.frequency [(9, Def <$> gen), (1, pure Nan)] +--gen_inf :: Bounded a => Gen a -> Gen (Inf a) +--gen_inf g = liftA2 (foldl' $ flip filterL) (fmap inf g) $ G.list (R.constant 0 20) g -gen_pn5 :: Gen a -> Gen (N5 a) -gen_pn5 gen = N5 <$> gen +--gen_sup :: Bounded a => Gen a -> Gen (Sup a) +--gen_sup g = liftA2 (foldl' $ flip filterR) (fmap sup g) $ G.list (R.constant 0 20) g -gen_bot :: Gen a -> Gen (Bottom a) -gen_bot gen = G.frequency [(9, Just <$> gen), (1, pure Nothing)] +gen_maybe :: Gen a -> Gen (Maybe a) +gen_maybe gen = G.frequency [(9, Just <$> gen), (1, pure Nothing)] -gen_top :: Gen a -> Gen (Top a) -gen_top gen = G.frequency [(9, Fin <$> gen), (1, pure Top)] +gen_lifted :: Gen a -> Gen (Lifted a) +gen_lifted gen = G.frequency [(9, Right <$> gen), (1, pure $ Left ())] -gen_bnd :: Gen a -> Gen (Bounded a) -gen_bnd gen = G.frequency [(18, (Just . Fin) <$> gen), (1, pure Nothing), (1, pure $ Just Top)] +gen_lowered :: Gen a -> Gen (Lowered a) +gen_lowered gen = G.frequency [(9, Left <$> gen), (1, pure $ Right ())] -gen_lft :: Gen a -> Gen (Lifted a) -gen_lft = gen_nan . gen_top +gen_extended :: Gen a -> Gen (Extended a) +gen_extended gen = G.frequency [(18, Extended <$> gen), (1, pure Bottom), (1, pure Top)] -gen_ext :: Gen a -> Gen (Extended a) -gen_ext = gen_nan . gen_bnd +gen_flt :: Floating a => Gen a -> Gen a +gen_flt gen = G.frequency [(49, gen), (1, G.element [(-1/0), 1/0, 0/0])] -gen_fld :: Field a => Gen a -> Gen a -gen_fld gen = G.frequency [(49, gen), (1, G.element [ninf, pinf, anan])] +prop_connection_extremal :: Property +prop_connection_extremal = withTests 1000 . property $ do + x <- forAll f32 + x' <- forAll f32 + o <- forAll ord + o' <- forAll ord + r <- forAll rat + r' <- forAll rat + assert $ Prop.adjoint (conn @_ @() @Ordering) () o + assert $ Prop.closed (conn @_ @() @Ordering) () + assert $ Prop.kernel (conn @_ @() @Ordering) o + assert $ Prop.monotonic (conn @_ @() @Ordering) () () o o' + assert $ Prop.idempotent (conn @_ @() @Ordering) () o + assert $ Prop.adjoint (conn @_ @() @Float) () x + assert $ Prop.closed (conn @_ @() @Float) () + assert $ Prop.kernel (conn @_ @() @Float) x + assert $ Prop.monotonic (conn @_ @() @Float) () () x x' + assert $ Prop.idempotent (conn @_ @() @Float) () x + + assert $ Prop.adjoint (conn @_ @() @Rational) () r + assert $ Prop.closed (conn @_ @() @Rational) () + assert $ Prop.kernel (conn @_ @() @Rational) r + assert $ Prop.monotonic (conn @_ @() @Rational) () () r r' + assert $ Prop.idempotent (conn @_ @() @Rational) () r tests :: IO Bool tests = checkParallel $$(discover) diff --git a/test/Test/Data/Connection/Float.hs b/test/Test/Data/Connection/Float.hs --- a/test/Test/Data/Connection/Float.hs +++ b/test/Test/Data/Connection/Float.hs @@ -1,414 +1,127 @@ {-# LANGUAGE TemplateHaskell #-} module Test.Data.Connection.Float where -import Data.Connection +import Data.Connection.Conn import Data.Connection.Float -import Data.Float +import Data.Connection.Double import Data.Int -import Data.Ord -import Data.Prd.Nan -import Data.Semilattice.N5 -import Data.Semilattice.Top import Hedgehog -import Prelude hiding (Bounded) +import Prelude hiding (Ord(..),Bounded, until) import Test.Data.Connection import qualified Data.Connection.Property as Prop import qualified Hedgehog.Gen as G -prop_connection_f32ord :: Property -prop_connection_f32ord = withTests 100 . property $ do - x <- forAll f32 - x' <- forAll f32 - y <- forAll $ gen_nan ord - y' <- forAll $ gen_nan ord - let f32ord = fldord :: Trip Float (Nan Ordering) - - assert $ Prop.connection (tripl f32ord) x y - assert $ Prop.connection (tripr f32ord) y x - assert $ Prop.closed (tripl f32ord) x - assert $ Prop.closed (tripr f32ord) y - assert $ Prop.kernel (tripl f32ord) y - assert $ Prop.kernel (tripr f32ord) x - assert $ Prop.monotonel (tripl f32ord) x x' - assert $ Prop.monotonel (tripr f32ord) y y' - assert $ Prop.monotoner (tripl f32ord) y y' - assert $ Prop.monotoner (tripr f32ord) x x' - assert $ Prop.projectivel (tripl f32ord) x - assert $ Prop.projectivel (tripr f32ord) y - assert $ Prop.projectiver (tripl f32ord) y - assert $ Prop.projectiver (tripr f32ord) x - -prop_connection_n5ford :: Property -prop_connection_n5ford = withTests 100 . property $ do - x <- forAll $ gen_pn5 f32 - x' <- forAll $ gen_pn5 f32 - y <- forAll ord - y' <- forAll ord - - let n5ford = n5' fldord :: Trip (N5 Float) Ordering - - assert $ Prop.connection (tripl n5ford) x y - assert $ Prop.connection (tripr n5ford) y x - assert $ Prop.closed (tripl n5ford) x - assert $ Prop.closed (tripr n5ford) y - assert $ Prop.kernel (tripl n5ford) y - assert $ Prop.kernel (tripr n5ford) x - assert $ Prop.monotonel (tripl n5ford) x x' - assert $ Prop.monotonel (tripr n5ford) y y' - assert $ Prop.monotoner (tripl n5ford) y y' - assert $ Prop.monotoner (tripr n5ford) x x' - assert $ Prop.projectivel (tripl n5ford) x - assert $ Prop.projectivel (tripr n5ford) y - assert $ Prop.projectiver (tripl n5ford) y - assert $ Prop.projectiver (tripr n5ford) x - prop_connection_f32i08 :: Property prop_connection_f32i08 = withTests 1000 . property $ do x <- forAll f32 x' <- forAll f32 - y <- forAll $ gen_ext $ G.integral (ri @Int8) - y' <- forAll $ gen_ext $ G.integral (ri @Int8) - - assert $ Prop.connection (tripl f32i08) x y - assert $ Prop.connection (tripr f32i08) y x - assert $ Prop.closed (tripl f32i08) x - assert $ Prop.closed (tripr f32i08) y - assert $ Prop.kernel (tripl f32i08) y - assert $ Prop.kernel (tripr f32i08) x - assert $ Prop.monotonel (tripl f32i08) x x' - assert $ Prop.monotonel (tripr f32i08) y y' - assert $ Prop.monotoner (tripl f32i08) y y' - assert $ Prop.monotoner (tripr f32i08) x x' - assert $ Prop.projectivel (tripl f32i08) x - assert $ Prop.projectivel (tripr f32i08) y - assert $ Prop.projectiver (tripl f32i08) y - assert $ Prop.projectiver (tripr f32i08) x - -prop_connection_n5fi08 :: Property -prop_connection_n5fi08 = withTests 1000 . property $ do - x <- forAll $ gen_pn5 f32 - x' <- forAll $ gen_pn5 f32 - y <- forAll $ gen_bnd $ G.integral (ri @Int8) - y' <- forAll $ gen_bnd $ G.integral (ri @Int8) - - let n5fi08 = n5' f32i08 :: Trip (N5 Float) (Bounded Int8) + y <- forAll $ gen_extended $ G.integral (ri @Int8) + y' <- forAll $ gen_extended $ G.integral (ri @Int8) - assert $ Prop.connection (tripl n5fi08) x y - assert $ Prop.connection (tripr n5fi08) y x - assert $ Prop.closed (tripl n5fi08) x - assert $ Prop.closed (tripr n5fi08) y - assert $ Prop.kernel (tripl n5fi08) y - assert $ Prop.kernel (tripr n5fi08) x - assert $ Prop.monotonel (tripl n5fi08) x x' - assert $ Prop.monotonel (tripr n5fi08) y y' - assert $ Prop.monotoner (tripl n5fi08) y y' - assert $ Prop.monotoner (tripr n5fi08) x x' - assert $ Prop.projectivel (tripl n5fi08) x - assert $ Prop.projectivel (tripr n5fi08) y - assert $ Prop.projectiver (tripl n5fi08) y - assert $ Prop.projectiver (tripr n5fi08) x + assert $ Prop.adjoint (f32i08) x y + assert $ Prop.closed (f32i08) x + assert $ Prop.kernel (f32i08) y + assert $ Prop.monotonic (f32i08) x x' y y' + assert $ Prop.idempotent (f32i08) x y prop_connection_f32i16 :: Property prop_connection_f32i16 = withTests 1000 . property $ do x <- forAll f32 x' <- forAll f32 - y <- forAll $ gen_ext $ G.integral (ri @Int16) - y' <- forAll $ gen_ext $ G.integral (ri @Int16) - - assert $ Prop.connection (tripl f32i16) x y - assert $ Prop.connection (tripr f32i16) y x - assert $ Prop.closed (tripl f32i16) x - assert $ Prop.closed (tripr f32i16) y - assert $ Prop.kernel (tripl f32i16) y - assert $ Prop.kernel (tripr f32i16) x - assert $ Prop.monotonel (tripl f32i16) x x' - assert $ Prop.monotonel (tripr f32i16) y y' - assert $ Prop.monotoner (tripl f32i16) y y' - assert $ Prop.monotoner (tripr f32i16) x x' - assert $ Prop.projectivel (tripl f32i16) x - assert $ Prop.projectivel (tripr f32i16) y - assert $ Prop.projectiver (tripl f32i16) y - assert $ Prop.projectiver (tripr f32i16) x - -prop_connection_n5fi16 :: Property -prop_connection_n5fi16 = withTests 1000 . property $ do - x <- forAll $ gen_pn5 f32 - x' <- forAll $ gen_pn5 f32 - y <- forAll $ gen_bnd $ G.integral (ri @Int16) - y' <- forAll $ gen_bnd $ G.integral (ri @Int16) - - let n5fi16 = n5' f32i16 :: Trip (N5 Float) (Bounded Int16) - - assert $ Prop.connection (tripl n5fi16) x y - assert $ Prop.connection (tripr n5fi16) y x - assert $ Prop.closed (tripl n5fi16) x - assert $ Prop.closed (tripr n5fi16) y - assert $ Prop.kernel (tripl n5fi16) y - assert $ Prop.kernel (tripr n5fi16) x - assert $ Prop.monotonel (tripl n5fi16) x x' - assert $ Prop.monotonel (tripr n5fi16) y y' - assert $ Prop.monotoner (tripl n5fi16) y y' - assert $ Prop.monotoner (tripr n5fi16) x x' - assert $ Prop.projectivel (tripl n5fi16) x - assert $ Prop.projectivel (tripr n5fi16) y - assert $ Prop.projectiver (tripl n5fi16) y - assert $ Prop.projectiver (tripr n5fi16) x - -prop_connections_f32 :: Property -prop_connections_f32 = withTests 1000 . property $ do - x <- forAll f32 - y <- forAll (gen_nan $ G.integral ri) - x' <- forAll f32 - y' <- forAll (gen_nan $ G.integral ri) - - assert $ Prop.connection f32i32 x y - assert $ Prop.connection i32f32 y x - assert $ Prop.closed f32i32 x - assert $ Prop.closed i32f32 y - assert $ Prop.kernel i32f32 x - assert $ Prop.kernel f32i32 y - assert $ Prop.monotonel f32i32 x x' - assert $ Prop.monotonel i32f32 y y' - assert $ Prop.monotoner f32i32 y y' - assert $ Prop.monotoner i32f32 x x' - assert $ Prop.projectivel f32i32 x - assert $ Prop.projectivel i32f32 y - assert $ Prop.projectiver i32f32 x - assert $ Prop.projectiver f32i32 y - -prop_connection_f64ord :: Property -prop_connection_f64ord = withTests 100 . property $ do - x <- forAll f64 - x' <- forAll f64 - y <- forAll $ gen_nan ord - y' <- forAll $ gen_nan ord - - let f64ord = fldord :: Trip Double (Nan Ordering) - - assert $ Prop.connection (tripl f64ord) x y - assert $ Prop.connection (tripr f64ord) y x - assert $ Prop.closed (tripl f64ord) x - assert $ Prop.closed (tripr f64ord) y - assert $ Prop.kernel (tripl f64ord) y - assert $ Prop.kernel (tripr f64ord) x - assert $ Prop.monotonel (tripl f64ord) x x' - assert $ Prop.monotonel (tripr f64ord) y y' - assert $ Prop.monotoner (tripl f64ord) y y' - assert $ Prop.monotoner (tripr f64ord) x x' - assert $ Prop.projectivel (tripl f64ord) x - assert $ Prop.projectivel (tripr f64ord) y - assert $ Prop.projectiver (tripl f64ord) y - assert $ Prop.projectiver (tripr f64ord) x - -prop_connection_n5dord :: Property -prop_connection_n5dord = withTests 100 . property $ do - x <- forAll $ gen_pn5 f64 - x' <- forAll $ gen_pn5 f64 - y <- forAll ord - y' <- forAll ord - - let n5dord = n5' fldord :: Trip (N5 Double) Ordering + y <- forAll $ gen_extended $ G.integral (ri @Int16) + y' <- forAll $ gen_extended $ G.integral (ri @Int16) - assert $ Prop.connection (tripl n5dord) x y - assert $ Prop.connection (tripr n5dord) y x - assert $ Prop.closed (tripl n5dord) x - assert $ Prop.closed (tripr n5dord) y - assert $ Prop.kernel (tripl n5dord) y - assert $ Prop.kernel (tripr n5dord) x - assert $ Prop.monotonel (tripl n5dord) x x' - assert $ Prop.monotonel (tripr n5dord) y y' - assert $ Prop.monotoner (tripl n5dord) y y' - assert $ Prop.monotoner (tripr n5dord) x x' - assert $ Prop.projectivel (tripl n5dord) x - assert $ Prop.projectivel (tripr n5dord) y - assert $ Prop.projectiver (tripl n5dord) y - assert $ Prop.projectiver (tripr n5dord) x + assert $ Prop.adjoint (f32i16) x y + assert $ Prop.closed (f32i16) x + assert $ Prop.kernel (f32i16) y + assert $ Prop.monotonic (f32i16) x x' y y' + assert $ Prop.idempotent (f32i16) x y prop_connection_f64i08 :: Property prop_connection_f64i08 = withTests 1000 . property $ do x <- forAll f64 x' <- forAll f64 - y <- forAll $ gen_ext $ G.integral (ri @Int8) - y' <- forAll $ gen_ext $ G.integral (ri @Int8) - - assert $ Prop.connection (tripl f64i08) x y - assert $ Prop.connection (tripr f64i08) y x - assert $ Prop.closed (tripl f64i08) x - assert $ Prop.closed (tripr f64i08) y - assert $ Prop.kernel (tripl f64i08) y - assert $ Prop.kernel (tripr f64i08) x - assert $ Prop.monotonel (tripl f64i08) x x' - assert $ Prop.monotonel (tripr f64i08) y y' - assert $ Prop.monotoner (tripl f64i08) y y' - assert $ Prop.monotoner (tripr f64i08) x x' - assert $ Prop.projectivel (tripl f64i08) x - assert $ Prop.projectivel (tripr f64i08) y - assert $ Prop.projectiver (tripl f64i08) y - assert $ Prop.projectiver (tripr f64i08) x - -prop_connection_n5di08 :: Property -prop_connection_n5di08 = withTests 1000 . property $ do - x <- forAll $ gen_pn5 f64 - x' <- forAll $ gen_pn5 f64 - y <- forAll $ gen_bnd $ G.integral (ri @Int8) - y' <- forAll $ gen_bnd $ G.integral (ri @Int8) - - let n5di08 = n5' f64i08 :: Trip (N5 Double) (Bounded Int8) + y <- forAll $ gen_extended $ G.integral (ri @Int8) + y' <- forAll $ gen_extended $ G.integral (ri @Int8) - assert $ Prop.connection (tripl n5di08) x y - assert $ Prop.connection (tripr n5di08) y x - assert $ Prop.closed (tripl n5di08) x - assert $ Prop.closed (tripr n5di08) y - assert $ Prop.kernel (tripl n5di08) y - assert $ Prop.kernel (tripr n5di08) x - assert $ Prop.monotonel (tripl n5di08) x x' - assert $ Prop.monotonel (tripr n5di08) y y' - assert $ Prop.monotoner (tripl n5di08) y y' - assert $ Prop.monotoner (tripr n5di08) x x' - assert $ Prop.projectivel (tripl n5di08) x - assert $ Prop.projectivel (tripr n5di08) y - assert $ Prop.projectiver (tripl n5di08) y - assert $ Prop.projectiver (tripr n5di08) x + assert $ Prop.adjoint (f64i08) x y + assert $ Prop.closed (f64i08) x + assert $ Prop.kernel (f64i08) y + assert $ Prop.monotonic (f64i08) x x' y y' + assert $ Prop.idempotent (f64i08) x y prop_connection_f64i16 :: Property prop_connection_f64i16 = withTests 1000 . property $ do x <- forAll f64 x' <- forAll f64 - y <- forAll $ gen_ext $ G.integral (ri @Int16) - y' <- forAll $ gen_ext $ G.integral (ri @Int16) - - assert $ Prop.connection (tripl f64i16) x y - assert $ Prop.connection (tripr f64i16) y x - assert $ Prop.closed (tripl f64i16) x - assert $ Prop.closed (tripr f64i16) y - assert $ Prop.kernel (tripl f64i16) y - assert $ Prop.kernel (tripr f64i16) x - assert $ Prop.monotonel (tripl f64i16) x x' - assert $ Prop.monotonel (tripr f64i16) y y' - assert $ Prop.monotoner (tripl f64i16) y y' - assert $ Prop.monotoner (tripr f64i16) x x' - assert $ Prop.projectivel (tripl f64i16) x - assert $ Prop.projectivel (tripr f64i16) y - assert $ Prop.projectiver (tripl f64i16) y - assert $ Prop.projectiver (tripr f64i16) x - -prop_connection_n5di16 :: Property -prop_connection_n5di16 = withTests 1000 . property $ do - x <- forAll $ gen_pn5 f64 - x' <- forAll $ gen_pn5 f64 - y <- forAll $ gen_bnd $ G.integral (ri @Int16) - y' <- forAll $ gen_bnd $ G.integral (ri @Int16) - - let n5di16 = n5' f64i16 :: Trip (N5 Double) (Bounded Int16) + y <- forAll $ gen_extended $ G.integral (ri @Int16) + y' <- forAll $ gen_extended $ G.integral (ri @Int16) - assert $ Prop.connection (tripl n5di16) x y - assert $ Prop.connection (tripr n5di16) y x - assert $ Prop.closed (tripl n5di16) x - assert $ Prop.closed (tripr n5di16) y - assert $ Prop.kernel (tripl n5di16) y - assert $ Prop.kernel (tripr n5di16) x - assert $ Prop.monotonel (tripl n5di16) x x' - assert $ Prop.monotonel (tripr n5di16) y y' - assert $ Prop.monotoner (tripl n5di16) y y' - assert $ Prop.monotoner (tripr n5di16) x x' - assert $ Prop.projectivel (tripl n5di16) x - assert $ Prop.projectivel (tripr n5di16) y - assert $ Prop.projectiver (tripl n5di16) y - assert $ Prop.projectiver (tripr n5di16) x + assert $ Prop.adjoint (f64i16) x y + assert $ Prop.closed (f64i16) x + assert $ Prop.kernel (f64i16) y + assert $ Prop.monotonic (f64i16) x x' y y' + assert $ Prop.idempotent (f64i16) x y prop_connection_f64i32 :: Property prop_connection_f64i32 = withTests 1000 . property $ do x <- forAll f64 x' <- forAll f64 - y <- forAll $ gen_ext $ G.integral (ri @Int32) - y' <- forAll $ gen_ext $ G.integral (ri @Int32) - - assert $ Prop.connection (tripl f64i32) x y - assert $ Prop.connection (tripr f64i32) y x - assert $ Prop.closed (tripl f64i32) x - assert $ Prop.closed (tripr f64i32) y - assert $ Prop.kernel (tripl f64i32) y - assert $ Prop.kernel (tripr f64i32) x - assert $ Prop.monotonel (tripl f64i32) x x' - assert $ Prop.monotonel (tripr f64i32) y y' - assert $ Prop.monotoner (tripl f64i32) y y' - assert $ Prop.monotoner (tripr f64i32) x x' - assert $ Prop.projectivel (tripl f64i32) x - assert $ Prop.projectivel (tripr f64i32) y - assert $ Prop.projectiver (tripl f64i32) y - assert $ Prop.projectiver (tripr f64i32) x + y <- forAll $ gen_extended $ G.integral (ri @Int32) + y' <- forAll $ gen_extended $ G.integral (ri @Int32) -prop_connection_n5di32 :: Property -prop_connection_n5di32 = withTests 1000 . property $ do - x <- forAll $ gen_pn5 f64 - x' <- forAll $ gen_pn5 f64 - y <- forAll $ gen_bnd $ G.integral (ri @Int32) - y' <- forAll $ gen_bnd $ G.integral (ri @Int32) + assert $ Prop.adjoint (f64i32) x y + assert $ Prop.closed (f64i32) x + assert $ Prop.kernel (f64i32) y + assert $ Prop.monotonic (f64i32) x x' y y' + assert $ Prop.idempotent (f64i32) x y - let n5di32 = n5' f64i32 :: Trip (N5 Double) (Bounded Int32) +{- - assert $ Prop.connection (tripl n5di32) x y - assert $ Prop.connection (tripr n5di32) y x - assert $ Prop.closed (tripl n5di32) x - assert $ Prop.closed (tripr n5di32) y - assert $ Prop.kernel (tripl n5di32) y - assert $ Prop.kernel (tripr n5di32) x - assert $ Prop.monotonel (tripl n5di32) x x' - assert $ Prop.monotonel (tripr n5di32) y y' - assert $ Prop.monotoner (tripl n5di32) y y' - assert $ Prop.monotoner (tripr n5di32) x x' - assert $ Prop.projectivel (tripl n5di32) x - assert $ Prop.projectivel (tripr n5di32) y - assert $ Prop.projectiver (tripl n5di32) y - assert $ Prop.projectiver (tripr n5di32) x +prop_connections_f32 :: Property +prop_connections_f32 = withTests 1000 . property $ do + x <- forAll f32 + y <- forAll (gen_maybe $ G.integral ri) + x' <- forAll f32 + y' <- forAll (gen_maybe $ G.integral ri) + + assert $ Prop.adjoint f32i32 x y + assert $ Prop.adjoint i32f32 y x + assert $ Prop.closed f32i32 x + assert $ Prop.closed i32f32 y + assert $ Prop.kernel i32f32 x + assert $ Prop.kernel f32i32 y + assert $ Prop.monotonicL f32i32 x x' + assert $ Prop.monotonicL i32f32 y y' + assert $ Prop.monotonicR f32i32 y y' + assert $ Prop.monotonicR i32f32 x x' + assert $ Prop.idempotentL f32i32 x + assert $ Prop.idempotentL i32f32 y + assert $ Prop.idempotentR i32f32 x + assert $ Prop.idempotentR f32i32 y prop_connections_f64 :: Property prop_connections_f64 = withTests 1000 . property $ do x <- forAll f64 - y <- forAll (gen_nan $ G.integral ri) + y <- forAll (gen_maybe $ G.integral ri) x' <- forAll f64 - y' <- forAll (gen_nan $ G.integral ri) - - assert $ Prop.connection f64i64 x y - assert $ Prop.connection i64f64 y x - assert $ Prop.closed f64i64 x - assert $ Prop.closed i64f64 y - assert $ Prop.kernel i64f64 x - assert $ Prop.kernel f64i64 y - assert $ Prop.monotonel f64i64 x x' - assert $ Prop.monotonel i64f64 y y' - assert $ Prop.monotoner f64i64 y y' - assert $ Prop.monotoner i64f64 x x' - assert $ Prop.projectivel f64i64 x - assert $ Prop.projectivel i64f64 y - assert $ Prop.projectiver i64f64 x - assert $ Prop.projectiver f64i64 y - - - -{- -prop_connections_n5d :: Property -prop_connections_n5d = withTests 1000 . property $ do - x <- forAll $ gen_pn5 f64 - y <- forAll (gen_bnd $ G.integral ri) - x' <- forAll $ gen_pn5 f64 - y' <- forAll (gen_bnd $ G.integral ri) + y' <- forAll (gen_maybe $ G.integral ri) - assert $ Prop.connection f64i64 x y - assert $ Prop.connection i64f64 y x + assert $ Prop.adjoint f64i64 x y + assert $ Prop.adjoint i64f64 y x assert $ Prop.closed f64i64 x assert $ Prop.closed i64f64 y assert $ Prop.kernel i64f64 x assert $ Prop.kernel f64i64 y - assert $ Prop.monotonel f64i64 x x' - assert $ Prop.monotonel i64f64 y y' - assert $ Prop.monotoner f64i64 y y' - assert $ Prop.monotoner i64f64 x x' - assert $ Prop.projectivel f64i64 x - assert $ Prop.projectivel i64f64 y - assert $ Prop.projectiver i64f64 x - assert $ Prop.projectiver f64i64 y + assert $ Prop.monotonicL f64i64 x x' + assert $ Prop.monotonicL i64f64 y y' + assert $ Prop.monotonicR f64i64 y y' + assert $ Prop.monotonicR i64f64 x x' + assert $ Prop.idempotentL f64i64 x + assert $ Prop.idempotentL i64f64 y + assert $ Prop.idempotentR i64f64 x + assert $ Prop.idempotentR f64i64 y prop_prd_u32 :: Property prop_prd_u32 = withTests 1000 . property $ do @@ -425,10 +138,6 @@ assert $ Prop.transitive_le x y z assert $ Prop.transitive_eq x y z --} - -{- - gen_sgn :: Gen Signed gen_sgn = Signed <$> f32 @@ -442,12 +151,12 @@ x' <- forAll f32 y' <- Ulp32 <$> forAll (G.integral ri) - assert $ Prop.connection f32u32 x y - assert $ Prop.connection u32f32 y x - assert $ Prop.monotonel f32u32 x x' - assert $ Prop.monotonel u32f32 y y' - assert $ Prop.monotoner f32u32 y y' - assert $ Prop.monotoner u32f32 x x' + assert $ Prop.adjoint f32u32 x y + assert $ Prop.adjoint u32f32 y x + assert $ Prop.monotonicL f32u32 x x' + assert $ Prop.monotonicL u32f32 y y' + assert $ Prop.monotonicR f32u32 y y' + assert $ Prop.monotonicR u32f32 x x' assert $ Prop.closed f32u32 x assert $ Prop.closed u32f32 y assert $ Prop.kernel u32f32 x @@ -460,46 +169,40 @@ y <- forAll $ gen_sgn y' <- forAll $ gen_sgn - assert $ Prop.connection f32sgn x y - assert $ Prop.monotonel f32sgn x x' - assert $ Prop.monotoner f32sgn y y' + assert $ Prop.adjoint f32sgn x y + assert $ Prop.monotonicL f32sgn x x' + assert $ Prop.monotonicR f32sgn y y' assert $ Prop.closed f32sgn x assert $ Prop.kernel f32sgn y - - prop_connections_f32w08 :: Property prop_connections_f32w08 = withTests 10000 . property $ do x <- forAll f32 x' <- forAll f32 - y <- forAll $ gen_nan $ G.integral (ri @Word8) - y' <- forAll $ gen_nan $ G.integral (ri @Word8) + y <- forAll $ gen_n5 $ G.integral (ri @Word8) + y' <- forAll $ gen_n5 $ G.integral (ri @Word8) - assert $ Prop.connection (tripl f32w08) x y - assert $ Prop.connection (tripr f32w08) y x - assert $ Prop.monotonel (tripl f32w08) x x' - assert $ Prop.monotonel (tripr f32w08) y y' - assert $ Prop.monotoner (tripl f32w08) y y' - assert $ Prop.monotoner (tripr f32w08) x x' + assert $ Prop.adjoint (tripl f32w08) x y + assert $ Prop.adjoint (tripr f32w08) y x + assert $ Prop.monotonicL (tripl f32w08) x x' + assert $ Prop.monotonicL (tripr f32w08) y y' + assert $ Prop.monotonicR (tripl f32w08) y y' + assert $ Prop.monotonicR (tripr f32w08) x x' assert $ Prop.closed (tripl f32w08) x assert $ Prop.closed (tripr f32w08) y assert $ Prop.kernel (tripl f32w08) y assert $ Prop.kernel (tripr f32w08) x --} - - -{- prop_connections_f32w64 :: Property prop_connections_f32w64 = withTests 1000 . property $ do x <- forAll f32 y <- forAll f32 x' <- forAll f32 y' <- forAll f32 - z <- forAll (gen_nan $ G.integral @_ @Word64 ri) - w <- forAll (gen_nan $ G.integral @_ @Word64 ri) - z' <- forAll (gen_nan $ G.integral @_ @Word64 ri) - w' <- forAll (gen_nan $ G.integral @_ @Word64 ri) + z <- forAll (gen_n5 $ G.integral @_ @Word64 ri) + w <- forAll (gen_n5 $ G.integral @_ @Word64 ri) + z' <- forAll (gen_n5 $ G.integral @_ @Word64 ri) + w' <- forAll (gen_n5 $ G.integral @_ @Word64 ri) exy <- forAll $ G.element [Left x, Right y] exy' <- forAll $ G.element [Left x', Right y'] ezw <- forAll $ G.element [Left z, Right w] @@ -507,24 +210,22 @@ assert $ Prop.closed (idx @Float) x --TODO in Index.hs assert $ Prop.kernel (idx @Float) z - assert $ Prop.monotonel (idx @Float) x x' - assert $ Prop.monotoner (idx @Float) z z' - assert $ Prop.connection (idx @Float) x z + assert $ Prop.monotonicL (idx @Float) x x' + assert $ Prop.monotonicR (idx @Float) z z' + assert $ Prop.adjoint (idx @Float) x z assert $ Prop.closed (idx @(Float,Float)) (x,y) assert $ Prop.kernel (idx @(Float,Float)) (z,w) - assert $ Prop.monotonel (idx @(Float,Float)) (x,y) (x',y') - assert $ Prop.monotoner (idx @(Float,Float)) (z,w) (z',w') - assert $ Prop.connection (idx @(Float,Float)) (x,y)(z,w) + assert $ Prop.monotonicL (idx @(Float,Float)) (x,y) (x',y') + assert $ Prop.monotonicR (idx @(Float,Float)) (z,w) (z',w') + assert $ Prop.adjoint (idx @(Float,Float)) (x,y)(z,w) - assert $ Prop.closed (idx @(Either Float Float)) exy - assert $ Prop.kernel (idx @(Either Float Float)) ezw - assert $ Prop.monotonel (idx @(Either Float Float)) exy exy' - assert $ Prop.monotoner (idx @(Either Float Float)) ezw ezw' - assert $ Prop.connection (idx @(Either Float Float)) exy ezw + assert $ Prop.closed (idx @(EitheR Float Float)) exy + assert $ Prop.kernel (idx @(EitheR Float Float)) ezw + assert $ Prop.monotonicL (idx @(EitheR Float Float)) exy exy' + assert $ Prop.monotonicR (idx @(EitheR Float Float)) ezw ezw' + assert $ Prop.adjoint (idx @(EitheR Float Float)) exy ezw -} - - tests :: IO Bool diff --git a/test/Test/Data/Connection/Int.hs b/test/Test/Data/Connection/Int.hs --- a/test/Test/Data/Connection/Int.hs +++ b/test/Test/Data/Connection/Int.hs @@ -1,8 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} module Test.Data.Connection.Int where -import Data.Connection import Data.Connection.Int +import Data.Connection.Conn import Data.Int import Data.Word import Hedgehog @@ -11,8 +11,8 @@ import qualified Data.Connection.Property as Prop import qualified Hedgehog.Gen as G -prop_connections :: Property -prop_connections = withTests 1000 . property $ do +prop_connectionsL :: Property +prop_connectionsL = withTests 1000 . property $ do i08 <- forAll $ G.integral (ri @Int8) w08 <- forAll $ G.integral (ri @Word8) @@ -26,8 +26,7 @@ wxx <- forAll $ G.integral (ri @Word) int <- forAll $ G.integral ri' nat <- forAll $ G.integral rn - mnt <- forAll $ gen_bot (G.integral ri') - inf <- forAll $ gen_bnd (G.integral ri') + mnt <- forAll $ gen_maybe (G.integral ri') i08' <- forAll $ G.integral (ri @Int8) w08' <- forAll $ G.integral (ri @Word8) @@ -41,190 +40,118 @@ wxx' <- forAll $ G.integral (ri @Word) int' <- forAll $ G.integral ri' nat' <- forAll $ G.integral rn - mnt' <- forAll $ gen_bot (G.integral ri') - inf' <- forAll $ gen_bnd (G.integral ri') + mnt' <- forAll $ gen_maybe (G.integral ri') - assert $ Prop.connection intnat int nat - assert $ Prop.connection natint nat mnt - assert $ Prop.connection ixxwxx ixx wxx - assert $ Prop.connection i64w64 i64 w64 - assert $ Prop.connection i64w64' i64 w64 - assert $ Prop.connection i32i64 i32 i64 - assert $ Prop.connection i32w32 i32 w32 - assert $ Prop.connection i32w32' i32 w32 - assert $ Prop.connection i16i64 i16 i64 - assert $ Prop.connection i16i32 i16 i32 - assert $ Prop.connection i16w16 i16 w16 - assert $ Prop.connection i16w16' i16 w16 - assert $ Prop.connection i08i64 i08 i64 - assert $ Prop.connection i08i32 i08 i32 - assert $ Prop.connection i08i16 i08 i16 - assert $ Prop.connection i08w08 i08 w08 - assert $ Prop.connection i08w08' i08 w08 - assert $ Prop.connection (tripl i64int) i64 inf - assert $ Prop.connection (tripr i64int) inf i64 - assert $ Prop.connection (tripl i32int) i32 inf - assert $ Prop.connection (tripr i32int) inf i32 - assert $ Prop.connection (tripl i16int) i16 inf - assert $ Prop.connection (tripr i16int) inf i16 - assert $ Prop.connection (tripl i08int) i08 inf - assert $ Prop.connection (tripr i08int) inf i08 + assert $ Prop.adjointL intnat int nat + --assert $ Prop.adjointL natint nat mnt + assert $ Prop.adjointL ixxwxx ixx wxx + assert $ Prop.adjointL i64w64 i64 w64 + assert $ Prop.adjointL i32w32 i32 w32 + assert $ Prop.adjointL i16w16 i16 w16 + assert $ Prop.adjointL i08w08 i08 w08 - assert $ Prop.closed intnat int - assert $ Prop.closed natint nat - assert $ Prop.closed ixxwxx ixx - assert $ Prop.closed i64w64 i64 - assert $ Prop.closed i64w64' i64 - assert $ Prop.closed i32i64 i32 - assert $ Prop.closed i32w32 i32 - assert $ Prop.closed i32w32' i32 - assert $ Prop.closed i16i64 i16 - assert $ Prop.closed i16i32 i16 - assert $ Prop.closed i16w16 i16 - assert $ Prop.closed i16w16' i16 - assert $ Prop.closed i08i64 i08 - assert $ Prop.closed i08i32 i08 - assert $ Prop.closed i08i16 i08 - assert $ Prop.closed i08w08 i08 - assert $ Prop.closed i08w08' i08 - assert $ Prop.closed (tripl i64int) i64 - assert $ Prop.closed (tripr i64int) inf - assert $ Prop.closed (tripl i32int) i32 - assert $ Prop.closed (tripr i32int) inf - assert $ Prop.closed (tripl i16int) i16 - assert $ Prop.closed (tripr i16int) inf - assert $ Prop.closed (tripl i08int) i08 - assert $ Prop.closed (tripr i08int) inf + assert $ Prop.closedL intnat int + --assert $ Prop.closedL natint nat + assert $ Prop.closedL ixxwxx ixx + assert $ Prop.closedL i64w64 i64 + assert $ Prop.closedL i32w32 i32 + assert $ Prop.closedL i16w16 i16 + assert $ Prop.closedL i08w08 i08 - assert $ Prop.kernel intnat nat - assert $ Prop.kernel natint mnt - assert $ Prop.kernel ixxwxx wxx - assert $ Prop.kernel i64w64' w64 - assert $ Prop.kernel i64w64 w64 - assert $ Prop.kernel i32i64 i64 - assert $ Prop.kernel i32w32' w32 - assert $ Prop.kernel i32w32 w32 - assert $ Prop.kernel i16i64 i64 - assert $ Prop.kernel i16i32 i32 - assert $ Prop.kernel i16w16' w16 - assert $ Prop.kernel i16w16 w16 - assert $ Prop.kernel i08i64 i64 - assert $ Prop.kernel i08i32 i32 - assert $ Prop.kernel i08i16 i16 - assert $ Prop.kernel i08w08' w08 - assert $ Prop.kernel i08w08 w08 - assert $ Prop.kernel (tripl i64int) inf - assert $ Prop.kernel (tripr i64int) i64 - assert $ Prop.kernel (tripl i32int) inf - assert $ Prop.kernel (tripr i32int) i32 - assert $ Prop.kernel (tripl i16int) inf - assert $ Prop.kernel (tripr i16int) i16 - assert $ Prop.kernel (tripl i08int) inf - assert $ Prop.kernel (tripr i08int) i08 + assert $ Prop.kernelL intnat nat + --assert $ Prop.kernelL natint mnt + assert $ Prop.kernelL ixxwxx wxx + assert $ Prop.kernelL i64w64 w64 + assert $ Prop.kernelL i32w32 w32 + assert $ Prop.kernelL i16w16 w16 + assert $ Prop.kernelL i08w08 w08 - assert $ Prop.monotonel intnat int int' - assert $ Prop.monotonel natint nat nat' - assert $ Prop.monotonel ixxwxx ixx ixx' - assert $ Prop.monotonel i64w64 i64 i64' - assert $ Prop.monotonel i64w64' i64 i64' - assert $ Prop.monotonel i32i64 i32 i32' - assert $ Prop.monotonel i32w32 i32 i32' - assert $ Prop.monotonel i32w32' i32 i32' - assert $ Prop.monotonel i16i64 i16 i16' - assert $ Prop.monotonel i16i32 i16 i16' - assert $ Prop.monotonel i16w16 i16 i16' - assert $ Prop.monotonel i16w16' i16 i16' - assert $ Prop.monotonel i08i64 i08 i08' - assert $ Prop.monotonel i08i32 i08 i08' - assert $ Prop.monotonel i08i16 i08 i08' - assert $ Prop.monotonel i08w08 i08 i08' - assert $ Prop.monotonel i08w08' i08 i08' - assert $ Prop.monotonel (tripl i64int) i64 i64' - assert $ Prop.monotonel (tripr i64int) inf inf' - assert $ Prop.monotonel (tripl i32int) i32 i32' - assert $ Prop.monotonel (tripr i32int) inf inf' - assert $ Prop.monotonel (tripl i16int) i16 i16' - assert $ Prop.monotonel (tripr i16int) inf inf' - assert $ Prop.monotonel (tripl i08int) i08 i08' - assert $ Prop.monotonel (tripr i08int) inf inf' + assert $ Prop.monotonicL intnat int int' nat nat' + --assert $ Prop.monotonicL natint nat nat' mnt mnt' + assert $ Prop.monotonicL ixxwxx ixx ixx' wxx wxx' + assert $ Prop.monotonicL i64w64 i64 i64' w64 w64' + assert $ Prop.monotonicL i32w32 i32 i32' w32 w32' + assert $ Prop.monotonicL i16w16 i16 i16' w16 w16' + assert $ Prop.monotonicL i08w08 i08 i08' w08 w08' - assert $ Prop.monotoner intnat nat nat' - assert $ Prop.monotoner natint mnt mnt' - assert $ Prop.monotoner ixxwxx wxx wxx' - assert $ Prop.monotoner i64w64 w64 w64' - assert $ Prop.monotoner i64w64' w64 w64' - assert $ Prop.monotoner i32i64 i64 i64' - assert $ Prop.monotoner i32w32 w32 w32' - assert $ Prop.monotoner i32w32' w32 w32' - assert $ Prop.monotoner i16i64 i64 i64' - assert $ Prop.monotoner i16i32 i32 i32' - assert $ Prop.monotoner i16w16 w16 w16' - assert $ Prop.monotoner i16w16' w16 w16' - assert $ Prop.monotoner i08i64 i64 i64' - assert $ Prop.monotoner i08i32 i32 i32' - assert $ Prop.monotoner i08i16 i16 i16' - assert $ Prop.monotoner i08w08 w08 w08' - assert $ Prop.monotoner i08w08' w08 w08' - assert $ Prop.monotoner (tripl i64int) inf inf' - assert $ Prop.monotoner (tripr i64int) i64 i64' - assert $ Prop.monotoner (tripl i32int) inf inf' - assert $ Prop.monotoner (tripr i32int) i32 i32' - assert $ Prop.monotoner (tripl i16int) inf inf' - assert $ Prop.monotoner (tripr i16int) i16 i16' - assert $ Prop.monotoner (tripl i08int) inf inf' - assert $ Prop.monotoner (tripr i08int) i08 i08' + assert $ Prop.idempotentL intnat int nat + -- assert $ Prop.idempotentL natint nat mnt + assert $ Prop.idempotentL ixxwxx ixx wxx + assert $ Prop.idempotentL i64w64 i64 w64 + assert $ Prop.idempotentL i32w32 i32 w32 + assert $ Prop.idempotentL i16w16 i16 w16 + assert $ Prop.idempotentL i08w08 i08 w08 - assert $ Prop.projectivel intnat int - assert $ Prop.projectivel natint nat - assert $ Prop.projectivel ixxwxx ixx - assert $ Prop.projectivel i64w64 i64 - assert $ Prop.projectivel i64w64' i64 - assert $ Prop.projectivel i32i64 i32 - assert $ Prop.projectivel i32w32 i32 - assert $ Prop.projectivel i32w32' i32 - assert $ Prop.projectivel i16i64 i16 - assert $ Prop.projectivel i16i32 i16 - assert $ Prop.projectivel i16w16 i16 - assert $ Prop.projectivel i16w16' i16 - assert $ Prop.projectivel i08i64 i08 - assert $ Prop.projectivel i08i32 i08 - assert $ Prop.projectivel i08i16 i08 - assert $ Prop.projectivel i08w08 i08 - assert $ Prop.projectivel i08w08' i08 - assert $ Prop.projectivel (tripl i64int) i64 - assert $ Prop.projectivel (tripr i64int) inf - assert $ Prop.projectivel (tripl i32int) i32 - assert $ Prop.projectivel (tripr i32int) inf - assert $ Prop.projectivel (tripl i16int) i16 - assert $ Prop.projectivel (tripr i16int) inf - assert $ Prop.projectivel (tripl i08int) i08 - assert $ Prop.projectivel (tripr i08int) inf +prop_connectionsR :: Property +prop_connectionsR = withTests 1000 . property $ do - assert $ Prop.projectiver intnat nat - assert $ Prop.projectiver natint mnt - assert $ Prop.projectiver ixxwxx wxx - assert $ Prop.projectiver i64w64' w64 - assert $ Prop.projectiver i64w64 w64 - assert $ Prop.projectiver i32i64 i64 - assert $ Prop.projectiver i32w32' w32 - assert $ Prop.projectiver i32w32 w32 - assert $ Prop.projectiver i16i64 i64 - assert $ Prop.projectiver i16i32 i32 - assert $ Prop.projectiver i16w16' w16 - assert $ Prop.projectiver i16w16 w16 - assert $ Prop.projectiver i08i64 i64 - assert $ Prop.projectiver i08i32 i32 - assert $ Prop.projectiver i08i16 i16 - assert $ Prop.projectiver i08w08' w08 - assert $ Prop.projectiver i08w08 w08 - assert $ Prop.projectiver (tripl i64int) inf - assert $ Prop.projectiver (tripr i64int) i64 - assert $ Prop.projectiver (tripl i32int) inf - assert $ Prop.projectiver (tripr i32int) i32 - assert $ Prop.projectiver (tripl i16int) inf - assert $ Prop.projectiver (tripr i16int) i16 - assert $ Prop.projectiver (tripl i08int) inf - assert $ Prop.projectiver (tripr i08int) i08 + i08 <- forAll $ G.integral (ri @Int8) + w08 <- forAll $ G.integral (ri @Word8) + i16 <- forAll $ G.integral (ri @Int16) + w16 <- forAll $ G.integral (ri @Word16) + i32 <- forAll $ G.integral (ri @Int32) + w32 <- forAll $ G.integral (ri @Word32) + i64 <- forAll $ G.integral (ri @Int64) + w64 <- forAll $ G.integral (ri @Word64) + ixx <- forAll $ G.integral (ri @Int) + wxx <- forAll $ G.integral (ri @Word) + int <- forAll $ G.integral ri' + nat <- forAll $ G.integral rn + mnt <- forAll $ gen_maybe (G.integral ri') + + i08' <- forAll $ G.integral (ri @Int8) + w08' <- forAll $ G.integral (ri @Word8) + i16' <- forAll $ G.integral (ri @Int16) + w16' <- forAll $ G.integral (ri @Word16) + i32' <- forAll $ G.integral (ri @Int32) + w32' <- forAll $ G.integral (ri @Word32) + i64' <- forAll $ G.integral (ri @Int64) + w64' <- forAll $ G.integral (ri @Word64) + ixx' <- forAll $ G.integral (ri @Int) + wxx' <- forAll $ G.integral (ri @Word) + int' <- forAll $ G.integral ri' + nat' <- forAll $ G.integral rn + mnt' <- forAll $ gen_maybe (G.integral ri') + + assert $ Prop.adjointR (swapR intnat) nat int + -- assert $ Prop.adjointR (swapR natint) mnt nat + assert $ Prop.adjointR (swapR ixxwxx) wxx ixx + assert $ Prop.adjointR (swapR i64w64) w64 i64 + assert $ Prop.adjointR (swapR i32w32) w32 i32 + assert $ Prop.adjointR (swapR i16w16) w16 i16 + assert $ Prop.adjointR (swapR i08w08) w08 i08 + + assert $ Prop.closedR (swapR intnat) nat + --assert $ Prop.closedR (swapR natint) mnt + assert $ Prop.closedR (swapR ixxwxx) wxx + assert $ Prop.closedR (swapR i64w64) w64 + assert $ Prop.closedR (swapR i32w32) w32 + assert $ Prop.closedR (swapR i16w16) w16 + assert $ Prop.closedR (swapR i08w08) w08 + + assert $ Prop.kernelR (swapR intnat) int + --assert $ Prop.kernelR (swapR natint) nat + assert $ Prop.kernelR (swapR ixxwxx) ixx + assert $ Prop.kernelR (swapR i64w64) i64 + assert $ Prop.kernelR (swapR i32w32) i32 + assert $ Prop.kernelR (swapR i16w16) i16 + assert $ Prop.kernelR (swapR i08w08) i08 + + assert $ Prop.monotonicR (swapR intnat) nat nat' int int' + -- assert $ Prop.monotonicR (swapR natint) mnt mnt' nat nat' + assert $ Prop.monotonicR (swapR ixxwxx) wxx wxx' ixx ixx' + assert $ Prop.monotonicR (swapR i64w64) w64 w64' i64 i64' + assert $ Prop.monotonicR (swapR i32w32) w32 w32' i32 i32' + assert $ Prop.monotonicR (swapR i16w16) w16 w16' i16 i16' + assert $ Prop.monotonicR (swapR i08w08) w08 w08' i08 i08' + + assert $ Prop.idempotentR (swapR intnat) nat int + -- assert $ Prop.idempotentR (swapR natint) mnt nat + assert $ Prop.idempotentR (swapR ixxwxx) wxx ixx + assert $ Prop.idempotentR (swapR i64w64) w64 i64 + assert $ Prop.idempotentR (swapR i32w32) w32 i32 + assert $ Prop.idempotentR (swapR i16w16) w16 i16 + assert $ Prop.idempotentR (swapR i08w08) w08 i08 tests :: IO Bool tests = checkParallel $$(discover) diff --git a/test/Test/Data/Connection/Ratio.hs b/test/Test/Data/Connection/Ratio.hs --- a/test/Test/Data/Connection/Ratio.hs +++ b/test/Test/Data/Connection/Ratio.hs @@ -1,40 +1,15 @@ {-# LANGUAGE TemplateHaskell #-} +{-# Language AllowAmbiguousTypes #-} module Test.Data.Connection.Ratio where -import Data.Connection -import Data.Connection.Ratio import Data.Int -import Data.Prd.Nan import Data.Word +import Data.Connection.Ratio import Hedgehog import Test.Data.Connection import qualified Data.Connection.Property as Prop import qualified Hedgehog.Gen as G -prop_connection_ratord :: Property -prop_connection_ratord = withTests 1000 . property $ do - x <- forAll rat - x' <- forAll rat - y <- forAll $ gen_nan ord - y' <- forAll $ gen_nan ord - - let ratord = fldord :: Trip Rational (Nan Ordering) - - assert $ Prop.connection (tripl ratord) x y - assert $ Prop.connection (tripr ratord) y x - assert $ Prop.closed (tripl ratord) x - assert $ Prop.closed (tripr ratord) y - assert $ Prop.kernel (tripl ratord) y - assert $ Prop.kernel (tripr ratord) x - assert $ Prop.monotonel (tripl ratord) x x' - assert $ Prop.monotonel (tripr ratord) y y' - assert $ Prop.monotoner (tripl ratord) y y' - assert $ Prop.monotoner (tripr ratord) x x' - assert $ Prop.projectivel (tripl ratord) x - assert $ Prop.projectivel (tripr ratord) y - assert $ Prop.projectiver (tripl ratord) y - assert $ Prop.projectiver (tripr ratord) x - prop_connection_ratf32 :: Property prop_connection_ratf32 = withTests 1000 . property $ do x <- forAll rat @@ -42,20 +17,11 @@ y <- forAll f32 y' <- forAll f32 - assert $ Prop.connection (tripl ratf32) x y - assert $ Prop.connection (tripr ratf32) y x - assert $ Prop.closed (tripl ratf32) x - assert $ Prop.closed (tripr ratf32) y - assert $ Prop.kernel (tripl ratf32) y - assert $ Prop.kernel (tripr ratf32) x - assert $ Prop.monotoner (tripl ratf32) y y' - assert $ Prop.monotoner (tripr ratf32) x x' - assert $ Prop.monotonel (tripl ratf32) x x' - assert $ Prop.monotonel (tripr ratf32) y y' - assert $ Prop.projectivel (tripl ratf32) x - assert $ Prop.projectivel (tripr ratf32) y - assert $ Prop.projectiver (tripl ratf32) y - assert $ Prop.projectiver (tripr ratf32) x + assert $ Prop.adjoint (ratf32) x y + assert $ Prop.closed (ratf32) x + assert $ Prop.kernel (ratf32) y + assert $ Prop.monotonic (ratf32) x x' y y' + assert $ Prop.idempotent (ratf32) x y prop_connection_ratf64 :: Property prop_connection_ratf64 = withTests 1000 . property $ do @@ -64,240 +30,141 @@ y <- forAll f64 y' <- forAll f64 - assert $ Prop.connection (tripl ratf64) x y - assert $ Prop.connection (tripr ratf64) y x - assert $ Prop.closed (tripl ratf64) x - assert $ Prop.closed (tripr ratf64) y - assert $ Prop.kernel (tripl ratf64) y - assert $ Prop.kernel (tripr ratf64) x - assert $ Prop.monotoner (tripl ratf64) y y' - assert $ Prop.monotoner (tripr ratf64) x x' - assert $ Prop.monotonel (tripl ratf64) x x' - assert $ Prop.monotonel (tripr ratf64) y y' - assert $ Prop.projectivel (tripl ratf64) x - assert $ Prop.projectivel (tripr ratf64) y - assert $ Prop.projectiver (tripl ratf64) y - assert $ Prop.projectiver (tripr ratf64) x + assert $ Prop.adjoint (ratf64) x y + assert $ Prop.closed (ratf64) x + assert $ Prop.kernel (ratf64) y + assert $ Prop.monotonic (ratf64) x x' y y' + assert $ Prop.idempotent (ratf64) x y prop_connection_rati08 :: Property prop_connection_rati08 = withTests 1000 . property $ do x <- forAll rat x' <- forAll rat - y <- forAll $ gen_ext $ G.integral (ri @Int8) - y' <- forAll $ gen_ext $ G.integral (ri @Int8) + y <- forAll $ gen_extended $ G.integral (ri @Int8) + y' <- forAll $ gen_extended $ G.integral (ri @Int8) - assert $ Prop.connection (tripl rati08) x y - assert $ Prop.connection (tripr rati08) y x - assert $ Prop.closed (tripl rati08) x - assert $ Prop.closed (tripr rati08) y - assert $ Prop.kernel (tripl rati08) y - assert $ Prop.kernel (tripr rati08) x - assert $ Prop.monotonel (tripl rati08) x x' - assert $ Prop.monotonel (tripr rati08) y y' - assert $ Prop.monotoner (tripl rati08) y y' - assert $ Prop.monotoner (tripr rati08) x x' - assert $ Prop.projectivel (tripl rati08) x - assert $ Prop.projectivel (tripr rati08) y - assert $ Prop.projectiver (tripl rati08) y - assert $ Prop.projectiver (tripr rati08) x + assert $ Prop.adjoint (rati08) x y + assert $ Prop.closed (rati08) x + assert $ Prop.kernel (rati08) y + assert $ Prop.monotonic (rati08) x x' y y' + assert $ Prop.idempotent (rati08) x y prop_connection_rati16 :: Property prop_connection_rati16 = withTests 1000 . property $ do x <- forAll rat x' <- forAll rat - y <- forAll $ gen_ext $ G.integral (ri @Int16) - y' <- forAll $ gen_ext $ G.integral (ri @Int16) + y <- forAll $ gen_extended $ G.integral (ri @Int16) + y' <- forAll $ gen_extended $ G.integral (ri @Int16) - assert $ Prop.connection (tripl rati16) x y - assert $ Prop.connection (tripr rati16) y x - assert $ Prop.closed (tripl rati16) x - assert $ Prop.closed (tripr rati16) y - assert $ Prop.kernel (tripl rati16) y - assert $ Prop.kernel (tripr rati16) x - assert $ Prop.monotonel (tripl rati16) x x' - assert $ Prop.monotonel (tripr rati16) y y' - assert $ Prop.monotoner (tripl rati16) y y' - assert $ Prop.monotoner (tripr rati16) x x' - assert $ Prop.projectivel (tripl rati16) x - assert $ Prop.projectivel (tripr rati16) y - assert $ Prop.projectiver (tripl rati16) y - assert $ Prop.projectiver (tripr rati16) x + assert $ Prop.adjoint (rati16) x y + assert $ Prop.closed (rati16) x + assert $ Prop.kernel (rati16) y + assert $ Prop.monotonic (rati16) x x' y y' + assert $ Prop.idempotent (rati16) x y prop_connection_rati32 :: Property prop_connection_rati32 = withTests 1000 . property $ do x <- forAll rat x' <- forAll rat - y <- forAll $ gen_ext $ G.integral (ri @Int32) - y' <- forAll $ gen_ext $ G.integral (ri @Int32) + y <- forAll $ gen_extended $ G.integral (ri @Int32) + y' <- forAll $ gen_extended $ G.integral (ri @Int32) - assert $ Prop.connection (tripl rati32) x y - assert $ Prop.connection (tripr rati32) y x - assert $ Prop.closed (tripl rati32) x - assert $ Prop.closed (tripr rati32) y - assert $ Prop.kernel (tripl rati32) y - assert $ Prop.kernel (tripr rati32) x - assert $ Prop.monotonel (tripl rati32) x x' - assert $ Prop.monotonel (tripr rati32) y y' - assert $ Prop.monotoner (tripl rati32) y y' - assert $ Prop.monotoner (tripr rati32) x x' - assert $ Prop.projectivel (tripl rati32) x - assert $ Prop.projectivel (tripr rati32) y - assert $ Prop.projectiver (tripl rati32) y - assert $ Prop.projectiver (tripr rati32) x + assert $ Prop.adjoint (rati32) x y + assert $ Prop.closed (rati32) x + assert $ Prop.kernel (rati32) y + assert $ Prop.monotonic (rati32) x x' y y' + assert $ Prop.idempotent (rati32) x y prop_connection_rati64 :: Property prop_connection_rati64 = withTests 1000 . property $ do x <- forAll rat x' <- forAll rat - y <- forAll $ gen_ext $ G.integral (ri @Int64) - y' <- forAll $ gen_ext $ G.integral (ri @Int64) + y <- forAll $ gen_extended $ G.integral (ri @Int64) + y' <- forAll $ gen_extended $ G.integral (ri @Int64) - assert $ Prop.connection (tripl rati64) x y - assert $ Prop.connection (tripr rati64) y x - assert $ Prop.closed (tripl rati64) x - assert $ Prop.closed (tripr rati64) y - assert $ Prop.kernel (tripl rati64) y - assert $ Prop.kernel (tripr rati64) x - assert $ Prop.monotonel (tripl rati64) x x' - assert $ Prop.monotonel (tripr rati64) y y' - assert $ Prop.monotoner (tripl rati64) y y' - assert $ Prop.monotoner (tripr rati64) x x' - assert $ Prop.projectivel (tripl rati64) x - assert $ Prop.projectivel (tripr rati64) y - assert $ Prop.projectiver (tripl rati64) y - assert $ Prop.projectiver (tripr rati64) x + assert $ Prop.adjoint (rati64) x y + assert $ Prop.closed (rati64) x + assert $ Prop.kernel (rati64) y + assert $ Prop.monotonic (rati64) x x' y y' + assert $ Prop.idempotent (rati64) x y prop_connection_ratint :: Property prop_connection_ratint = withTests 1000 . property $ do x <- forAll rat x' <- forAll rat - y <- forAll $ gen_ext $ G.integral ri' - y' <- forAll $ gen_ext $ G.integral ri' + y <- forAll $ gen_extended $ G.integral ri' + y' <- forAll $ gen_extended $ G.integral ri' - assert $ Prop.connection (tripl ratint) x y - assert $ Prop.connection (tripr ratint) y x - assert $ Prop.closed (tripl ratint) x - assert $ Prop.closed (tripr ratint) y - assert $ Prop.kernel (tripl ratint) y - assert $ Prop.kernel (tripr ratint) x - assert $ Prop.monotonel (tripl ratint) x x' - assert $ Prop.monotonel (tripr ratint) y y' - assert $ Prop.monotoner (tripl ratint) y y' - assert $ Prop.monotoner (tripr ratint) x x' - assert $ Prop.projectivel (tripl ratint) x - assert $ Prop.projectivel (tripr ratint) y - assert $ Prop.projectiver (tripl ratint) y - assert $ Prop.projectiver (tripr ratint) x + assert $ Prop.adjoint (ratint) x y + assert $ Prop.closed (ratint) x + assert $ Prop.kernel (ratint) y + assert $ Prop.monotonic (ratint) x x' y y' + assert $ Prop.idempotent (ratint) x y -prop_connection_ratw08 :: Property -prop_connection_ratw08 = withTests 1000 . property $ do +prop_connection_posw08 :: Property +prop_connection_posw08 = withTests 1000 . property $ do x <- forAll pos x' <- forAll pos - y <- forAll $ gen_lft $ G.integral (ri @Word8) - y' <- forAll $ gen_lft $ G.integral (ri @Word8) + y <- forAll $ gen_lowered $ G.integral (ri @Word8) + y' <- forAll $ gen_lowered $ G.integral (ri @Word8) - assert $ Prop.connection (tripl ratw08) x y - assert $ Prop.connection (tripr ratw08) y x - assert $ Prop.closed (tripl ratw08) x - assert $ Prop.closed (tripr ratw08) y - assert $ Prop.kernel (tripl ratw08) y - assert $ Prop.kernel (tripr ratw08) x - assert $ Prop.monotonel (tripl ratw08) x x' - assert $ Prop.monotonel (tripr ratw08) y y' - assert $ Prop.monotoner (tripl ratw08) y y' - assert $ Prop.monotoner (tripr ratw08) x x' - assert $ Prop.projectivel (tripl ratw08) x - assert $ Prop.projectivel (tripr ratw08) y - assert $ Prop.projectiver (tripl ratw08) y - assert $ Prop.projectiver (tripr ratw08) x + assert $ Prop.adjoint (posw08) x y + assert $ Prop.closed (posw08) x + assert $ Prop.kernel (posw08) y + assert $ Prop.monotonic (posw08) x x' y y' + assert $ Prop.idempotent (posw08) x y -prop_connection_ratw16 :: Property -prop_connection_ratw16 = withTests 1000 . property $ do +prop_connection_posw16 :: Property +prop_connection_posw16 = withTests 1000 . property $ do x <- forAll pos x' <- forAll pos - y <- forAll $ gen_lft $ G.integral (ri @Word16) - y' <- forAll $ gen_lft $ G.integral (ri @Word16) + y <- forAll $ gen_lowered $ G.integral (ri @Word16) + y' <- forAll $ gen_lowered $ G.integral (ri @Word16) - assert $ Prop.connection (tripl ratw16) x y - assert $ Prop.connection (tripr ratw16) y x - assert $ Prop.closed (tripl ratw16) x - assert $ Prop.closed (tripr ratw16) y - assert $ Prop.kernel (tripl ratw16) y - assert $ Prop.kernel (tripr ratw16) x - assert $ Prop.monotonel (tripl ratw16) x x' - assert $ Prop.monotonel (tripr ratw16) y y' - assert $ Prop.monotoner (tripl ratw16) y y' - assert $ Prop.monotoner (tripr ratw16) x x' - assert $ Prop.projectivel (tripl ratw16) x - assert $ Prop.projectivel (tripr ratw16) y - assert $ Prop.projectiver (tripl ratw16) y - assert $ Prop.projectiver (tripr ratw16) x + assert $ Prop.adjoint (posw16) x y + assert $ Prop.closed (posw16) x + assert $ Prop.kernel (posw16) y + assert $ Prop.monotonic (posw16) x x' y y' + assert $ Prop.idempotent (posw16) x y -prop_connection_ratw32 :: Property -prop_connection_ratw32 = withTests 1000 . property $ do +prop_connection_posw32 :: Property +prop_connection_posw32 = withTests 1000 . property $ do x <- forAll pos x' <- forAll pos - y <- forAll $ gen_lft $ G.integral (ri @Word32) - y' <- forAll $ gen_lft $ G.integral (ri @Word32) + y <- forAll $ gen_lowered $ G.integral (ri @Word32) + y' <- forAll $ gen_lowered $ G.integral (ri @Word32) - assert $ Prop.connection (tripl ratw32) x y - assert $ Prop.connection (tripr ratw32) y x - assert $ Prop.closed (tripl ratw32) x - assert $ Prop.closed (tripr ratw32) y - assert $ Prop.kernel (tripl ratw32) y - assert $ Prop.kernel (tripr ratw32) x - assert $ Prop.monotonel (tripl ratw32) x x' - assert $ Prop.monotonel (tripr ratw32) y y' - assert $ Prop.monotoner (tripl ratw32) y y' - assert $ Prop.monotoner (tripr ratw32) x x' - assert $ Prop.projectivel (tripl ratw32) x - assert $ Prop.projectivel (tripr ratw32) y - assert $ Prop.projectiver (tripl ratw32) y - assert $ Prop.projectiver (tripr ratw32) x + assert $ Prop.adjoint (posw32) x y + assert $ Prop.closed (posw32) x + assert $ Prop.kernel (posw32) y + assert $ Prop.monotonic (posw32) x x' y y' + assert $ Prop.idempotent (posw32) x y -prop_connection_ratw64 :: Property -prop_connection_ratw64 = withTests 1000 . property $ do +prop_connection_posw64 :: Property +prop_connection_posw64 = withTests 1000 . property $ do x <- forAll pos x' <- forAll pos - y <- forAll $ gen_lft $ G.integral (ri @Word64) - y' <- forAll $ gen_lft $ G.integral (ri @Word64) + y <- forAll $ gen_lowered $ G.integral (ri @Word64) + y' <- forAll $ gen_lowered $ G.integral (ri @Word64) - assert $ Prop.connection (tripl ratw64) x y - assert $ Prop.connection (tripr ratw64) y x - assert $ Prop.closed (tripl ratw64) x - assert $ Prop.closed (tripr ratw64) y - assert $ Prop.kernel (tripl ratw64) y - assert $ Prop.kernel (tripr ratw64) x - assert $ Prop.monotonel (tripl ratw64) x x' - assert $ Prop.monotonel (tripr ratw64) y y' - assert $ Prop.monotoner (tripl ratw64) y y' - assert $ Prop.monotoner (tripr ratw64) x x' - assert $ Prop.projectivel (tripl ratw64) x - assert $ Prop.projectivel (tripr ratw64) y - assert $ Prop.projectiver (tripl ratw64) y - assert $ Prop.projectiver (tripr ratw64) x + assert $ Prop.adjoint (posw64) x y + assert $ Prop.closed (posw64) x + assert $ Prop.kernel (posw64) y + assert $ Prop.monotonic (posw64) x x' y y' + assert $ Prop.idempotent (posw64) x y -prop_connection_ratnat :: Property -prop_connection_ratnat = withTests 1000 . property $ do +prop_connection_posnat :: Property +prop_connection_posnat = withTests 1000 . property $ do x <- forAll pos x' <- forAll pos - y <- forAll $ gen_lft $ G.integral rn - y' <- forAll $ gen_lft $ G.integral rn + y <- forAll $ gen_lowered $ G.integral rn + y' <- forAll $ gen_lowered $ G.integral rn - assert $ Prop.connection (tripl ratnat) x y - assert $ Prop.connection (tripr ratnat) y x - assert $ Prop.closed (tripl ratnat) x - assert $ Prop.closed (tripr ratnat) y - assert $ Prop.kernel (tripl ratnat) y - assert $ Prop.kernel (tripr ratnat) x - assert $ Prop.monotonel (tripl ratnat) x x' - assert $ Prop.monotonel (tripr ratnat) y y' - assert $ Prop.monotoner (tripl ratnat) y y' - assert $ Prop.monotoner (tripr ratnat) x x' - assert $ Prop.projectivel (tripl ratnat) x - assert $ Prop.projectivel (tripr ratnat) y - assert $ Prop.projectiver (tripl ratnat) y - assert $ Prop.projectiver (tripr ratnat) x + assert $ Prop.adjoint (posnat) x y + assert $ Prop.closed (posnat) x + assert $ Prop.kernel (posnat) y + assert $ Prop.monotonic (posnat) x x' y y' + assert $ Prop.idempotent (posnat) x y tests :: IO Bool tests = checkParallel $$(discover) diff --git a/test/Test/Data/Connection/Word.hs b/test/Test/Data/Connection/Word.hs --- a/test/Test/Data/Connection/Word.hs +++ b/test/Test/Data/Connection/Word.hs @@ -3,15 +3,13 @@ import Data.Int import Data.Word +import Data.Connection.Conn import Data.Connection.Word +import Hedgehog import Test.Data.Connection import qualified Data.Connection.Property as Prop - -import Hedgehog import qualified Hedgehog.Gen as G -import qualified Hedgehog.Range as R - prop_connections :: Property prop_connections = withTests 1000 . property $ do @@ -35,110 +33,80 @@ w64' <- forAll $ G.integral (ri @Word64) nat' <- forAll $ G.integral rn - assert $ Prop.connection w64nat w64 nat - assert $ Prop.connection w64i64 w64 i64 - assert $ Prop.connection w32nat w32 nat - assert $ Prop.connection w32w64 w32 w64 - assert $ Prop.connection w32i32 w32 i32 - assert $ Prop.connection w16nat w16 nat - assert $ Prop.connection w16w64 w16 w64 - assert $ Prop.connection w16w32 w16 w32 - assert $ Prop.connection w16i16 w16 i16 - assert $ Prop.connection w08nat w08 nat - assert $ Prop.connection w08w64 w08 w64 - assert $ Prop.connection w08w32 w08 w32 - assert $ Prop.connection w08w16 w08 w16 - assert $ Prop.connection w08i08 w08 i08 - - assert $ Prop.closed w64nat w64 - assert $ Prop.closed w64i64 w64 - assert $ Prop.closed w32nat w32 - assert $ Prop.closed w32w64 w32 - assert $ Prop.closed w32i32 w32 - assert $ Prop.closed w16nat w16 - assert $ Prop.closed w16w64 w16 - assert $ Prop.closed w16w32 w16 - assert $ Prop.closed w16i16 w16 - assert $ Prop.closed w08nat w08 - assert $ Prop.closed w08w64 w08 - assert $ Prop.closed w08w32 w08 - assert $ Prop.closed w08w16 w08 - assert $ Prop.closed w08i08 w08 - - assert $ Prop.kernel w64nat nat - assert $ Prop.kernel w64i64 i64 - assert $ Prop.kernel w32nat nat - assert $ Prop.kernel w32w64 w64 - assert $ Prop.kernel w32i32 i32 - assert $ Prop.kernel w16nat nat - assert $ Prop.kernel w16w64 w64 - assert $ Prop.kernel w16w32 w32 - assert $ Prop.kernel w16i16 i16 - assert $ Prop.kernel w08nat nat - assert $ Prop.kernel w08w64 w64 - assert $ Prop.kernel w08w32 w32 - assert $ Prop.kernel w08w16 w16 - assert $ Prop.kernel w08i08 i08 + assert $ Prop.adjointL w64nat w64 nat + assert $ Prop.adjointL w64i64 w64 i64 + assert $ Prop.adjointL w32nat w32 nat + assert $ Prop.adjointL w32w64 w32 w64 + assert $ Prop.adjointL w32i32 w32 i32 + assert $ Prop.adjointL w16nat w16 nat + assert $ Prop.adjointL w16w64 w16 w64 + assert $ Prop.adjointL w16w32 w16 w32 + assert $ Prop.adjointL w16i16 w16 i16 + assert $ Prop.adjointL w08nat w08 nat + assert $ Prop.adjointL w08w64 w08 w64 + assert $ Prop.adjointL w08w32 w08 w32 + assert $ Prop.adjointL w08w16 w08 w16 + assert $ Prop.adjointL w08i08 w08 i08 - assert $ Prop.monotonel w64nat w64 w64' - assert $ Prop.monotonel w64i64 w64 w64' - assert $ Prop.monotonel w32nat w32 w32' - assert $ Prop.monotonel w32w64 w32 w32' - assert $ Prop.monotonel w32i32 w32 w32' - assert $ Prop.monotonel w16nat w16 w16' - assert $ Prop.monotonel w16w64 w16 w16' - assert $ Prop.monotonel w16w32 w16 w16' - assert $ Prop.monotonel w16i16 w16 w16' - assert $ Prop.monotonel w08nat w08 w08' - assert $ Prop.monotonel w08w64 w08 w08' - assert $ Prop.monotonel w08w32 w08 w08' - assert $ Prop.monotonel w08w16 w08 w08' - assert $ Prop.monotonel w08i08 w08 w08' + assert $ Prop.closedL w64nat w64 + assert $ Prop.closedL w64i64 w64 + assert $ Prop.closedL w32nat w32 + assert $ Prop.closedL w32w64 w32 + assert $ Prop.closedL w32i32 w32 + assert $ Prop.closedL w16nat w16 + assert $ Prop.closedL w16w64 w16 + assert $ Prop.closedL w16w32 w16 + assert $ Prop.closedL w16i16 w16 + assert $ Prop.closedL w08nat w08 + assert $ Prop.closedL w08w64 w08 + assert $ Prop.closedL w08w32 w08 + assert $ Prop.closedL w08w16 w08 + assert $ Prop.closedL w08i08 w08 - assert $ Prop.monotoner w64nat nat nat' - assert $ Prop.monotoner w64i64 i64 i64' - assert $ Prop.monotoner w32nat nat nat' - assert $ Prop.monotoner w32w64 w64 w64' - assert $ Prop.monotoner w32i32 i32 i32' - assert $ Prop.monotoner w16nat nat nat' - assert $ Prop.monotoner w16w64 w64 w64' - assert $ Prop.monotoner w16w32 w32 w32' - assert $ Prop.monotoner w16i16 i16 i16' - assert $ Prop.monotoner w08nat nat nat' - assert $ Prop.monotoner w08w64 w64 w64' - assert $ Prop.monotoner w08w32 w32 w32' - assert $ Prop.monotoner w08w16 w16 w16' - assert $ Prop.monotoner w08i08 i08 i08' + assert $ Prop.kernelL w64nat nat + assert $ Prop.kernelL w64i64 i64 + assert $ Prop.kernelL w32nat nat + assert $ Prop.kernelL w32w64 w64 + assert $ Prop.kernelL w32i32 i32 + assert $ Prop.kernelL w16nat nat + assert $ Prop.kernelL w16w64 w64 + assert $ Prop.kernelL w16w32 w32 + assert $ Prop.kernelL w16i16 i16 + assert $ Prop.kernelL w08nat nat + assert $ Prop.kernelL w08w64 w64 + assert $ Prop.kernelL w08w32 w32 + assert $ Prop.kernelL w08w16 w16 + assert $ Prop.kernelL w08i08 i08 - assert $ Prop.projectivel w64nat w64 - assert $ Prop.projectivel w64i64 w64 - assert $ Prop.projectivel w32nat w32 - assert $ Prop.projectivel w32w64 w32 - assert $ Prop.projectivel w32i32 w32 - assert $ Prop.projectivel w16nat w16 - assert $ Prop.projectivel w16w64 w16 - assert $ Prop.projectivel w16w32 w16 - assert $ Prop.projectivel w16i16 w16 - assert $ Prop.projectivel w08nat w08 - assert $ Prop.projectivel w08w64 w08 - assert $ Prop.projectivel w08w32 w08 - assert $ Prop.projectivel w08w16 w08 - assert $ Prop.projectivel w08i08 w08 + assert $ Prop.monotonicL w64nat w64 w64' nat nat' + assert $ Prop.monotonicL w64i64 w64 w64' i64 i64' + assert $ Prop.monotonicL w32nat w32 w32' nat nat' + assert $ Prop.monotonicL w32w64 w32 w32' w64 w64' + assert $ Prop.monotonicL w32i32 w32 w32' i32 i32' + assert $ Prop.monotonicL w16nat w16 w16' nat nat' + assert $ Prop.monotonicL w16w64 w16 w16' w64 w64' + assert $ Prop.monotonicL w16w32 w16 w16' w32 w32' + assert $ Prop.monotonicL w16i16 w16 w16' i16 i16' + assert $ Prop.monotonicL w08nat w08 w08' nat nat' + assert $ Prop.monotonicL w08w64 w08 w08' w64 w64' + assert $ Prop.monotonicL w08w32 w08 w08' w32 w32' + assert $ Prop.monotonicL w08w16 w08 w08' w16 w16' + assert $ Prop.monotonicL w08i08 w08 w08' i08 i08' - assert $ Prop.projectiver w64nat nat - assert $ Prop.projectiver w64i64 i64 - assert $ Prop.projectiver w32nat nat - assert $ Prop.projectiver w32w64 w64 - assert $ Prop.projectiver w32i32 i32 - assert $ Prop.projectiver w16nat nat - assert $ Prop.projectiver w16w64 w64 - assert $ Prop.projectiver w16w32 w32 - assert $ Prop.projectiver w16i16 i16 - assert $ Prop.projectiver w08nat nat - assert $ Prop.projectiver w08w64 w64 - assert $ Prop.projectiver w08w32 w32 - assert $ Prop.projectiver w08w16 w16 - assert $ Prop.projectiver w08i08 i08 + assert $ Prop.idempotentL w64nat w64 nat + assert $ Prop.idempotentL w64i64 w64 i64 + assert $ Prop.idempotentL w32nat w32 nat + assert $ Prop.idempotentL w32w64 w32 w64 + assert $ Prop.idempotentL w32i32 w32 i32 + assert $ Prop.idempotentL w16nat w16 nat + assert $ Prop.idempotentL w16w64 w16 w64 + assert $ Prop.idempotentL w16w32 w16 w32 + assert $ Prop.idempotentL w16i16 w16 i16 + assert $ Prop.idempotentL w08nat w08 nat + assert $ Prop.idempotentL w08w64 w08 w64 + assert $ Prop.idempotentL w08w32 w08 w32 + assert $ Prop.idempotentL w08w16 w08 w16 + assert $ Prop.idempotentL w08i08 w08 i08 tests :: IO Bool tests = checkParallel $$(discover) diff --git a/test/Test/Data/Lattice.hs b/test/Test/Data/Lattice.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Lattice.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +module Test.Data.Lattice where + +import Data.Connection +import Data.Lattice +import Data.Connection.Property +import Data.Lattice.Property +import Data.Order +import Test.Data.Connection + +import Hedgehog +import qualified Hedgehog.Gen as G + +prop_heytingL :: Property +prop_heytingL = withTests 1000 . property $ do + b1 <- forAll G.bool + b2 <- forAll G.bool + b3 <- forAll G.bool + o1 <- forAll ord + o2 <- forAll ord + o3 <- forAll ord + w1 <- forAll $ G.integral (ri @Word) + w2 <- forAll $ G.integral (ri @Word) + w3 <- forAll $ G.integral (ri @Word) + f1 <- forAll f32 + f2 <- forAll f32 + f3 <- forAll f32 + + assert $ adjointL (heyting b3) b1 b2 + assert $ closedL (heyting b3) b1 + assert $ kernelL (heyting b3) b2 + assert $ monotonicL (heyting b3) b1 b2 b3 b2 + assert $ idempotentL (heyting b3) b1 b2 + + assert $ adjointL booleanL b1 b2 + assert $ closedL booleanL b1 + assert $ kernelL booleanL b2 + assert $ monotonicL booleanL b1 b2 b3 b2 + assert $ idempotentL booleanL b1 b3 + + assert $ heytingL1 b1 b2 b3 + assert $ heytingL2 b1 b2 b3 + assert $ heytingL3 b1 b2 b3 + assert $ heytingL4 b1 b2 b3 + assert $ heytingL5 b1 b2 b3 + assert $ heytingL6 b1 b2 + assert $ heytingL7 b1 b2 + assert $ heytingL8 b1 + assert $ heytingL9 b1 b2 + assert $ heytingL10 b1 b2 + assert $ heytingL11 b1 b2 + assert $ heytingL12 b1 b2 + assert $ heytingL13 b1 b2 + assert $ heytingL14 b1 + assert $ heytingL15 b1 + assert $ heytingL16 b1 + assert $ heytingL17 b1 + assert $ heytingL18 b1 + assert $ heytingL19 b1 b2 + assert $ heytingL20 b1 b2 + + assert $ adjointL (heyting o3) o1 o2 + assert $ closedL (heyting o3) o1 + assert $ kernelL (heyting o3) o2 + assert $ monotonicL (heyting o3) o1 o2 o3 o2 + assert $ idempotentL (heyting o3) o1 o2 + + assert $ adjointL booleanL o1 o2 + assert $ closedL booleanL o1 + assert $ kernelL booleanL o2 + assert $ monotonicL booleanL o1 o2 o3 o2 + assert $ idempotentL booleanL o1 o3 + + assert $ heytingL1 o1 o2 o3 + assert $ heytingL2 o1 o2 o3 + assert $ heytingL3 o1 o2 o3 + assert $ heytingL4 o1 o2 o3 + assert $ heytingL5 o1 o2 o3 + assert $ heytingL6 o1 o2 + assert $ heytingL7 o1 o2 + assert $ heytingL8 o1 + assert $ heytingL9 o1 o2 + assert $ heytingL10 o1 o2 + assert $ heytingL11 o1 o2 + assert $ heytingL12 o1 o2 + assert $ heytingL13 o1 o2 + assert $ heytingL14 o1 + assert $ heytingL15 o1 + assert $ heytingL16 o1 + assert $ heytingL17 o1 + assert $ heytingL18 o1 + assert $ heytingL19 o1 o2 + assert $ heytingL20 o1 o2 + + assert $ adjointL (heyting w3) w1 w2 + assert $ closedL (heyting w3) w1 + assert $ kernelL (heyting w3) w2 + assert $ monotonicL (heyting w3) w1 w2 w3 w2 + assert $ idempotentL (heyting w3) w1 w2 + + assert $ adjointL booleanL w1 w2 + assert $ closedL booleanL w1 + assert $ kernelL booleanL w2 + assert $ monotonicL booleanL w1 w2 w3 w2 + assert $ idempotentL booleanL w1 w3 + + assert $ heytingL1 w1 w2 w3 + assert $ heytingL2 w1 w2 w3 + assert $ heytingL3 w1 w2 w3 + assert $ heytingL4 w1 w2 w3 + assert $ heytingL5 w1 w2 w3 + assert $ heytingL6 w1 w2 + assert $ heytingL7 w1 w2 + assert $ heytingL8 w1 + assert $ heytingL9 w1 w2 + assert $ heytingL10 w1 w2 + assert $ heytingL11 w1 w2 + assert $ heytingL12 w1 w2 + assert $ heytingL13 w1 w2 + assert $ heytingL14 w1 + assert $ heytingL15 w1 + assert $ heytingL16 w1 + assert $ heytingL17 w1 + assert $ heytingL18 w1 + assert $ heytingL19 w1 w2 + assert $ heytingL20 w1 w2 + +prop_heytingR :: Property +prop_heytingR = withTests 1000 . property $ do + b1 <- forAll G.bool + b2 <- forAll G.bool + b3 <- forAll G.bool + o1 <- forAll ord + o2 <- forAll ord + o3 <- forAll ord + w1 <- forAll $ G.integral (ri @Word) + w2 <- forAll $ G.integral (ri @Word) + w3 <- forAll $ G.integral (ri @Word) + + assert $ adjointR (heyting b3) b1 b2 + assert $ closedR (heyting b3) b1 + assert $ kernelR (heyting b3) b2 + assert $ monotonicR (heyting b3) b1 b2 b3 b2 + assert $ idempotentR (heyting b3) b1 b2 + + assert $ adjointR booleanR b1 b2 + assert $ closedR booleanR b1 + assert $ kernelR booleanR b2 + assert $ monotonicR booleanR b1 b2 b3 b2 + assert $ idempotentR booleanR b1 b3 + + assert $ heytingR0 b1 b2 b3 + assert $ heytingR1 b1 b2 b3 + assert $ heytingR2 b1 b2 b3 + assert $ heytingR3 b1 b2 b3 + assert $ heytingR4 b1 b2 b3 + assert $ heytingR5 b1 b2 b3 + assert $ heytingR6 b1 b2 + assert $ heytingR7 b1 b2 + assert $ heytingR8 b1 + assert $ heytingR9 b1 b2 + assert $ heytingR10 b1 b2 + assert $ heytingR11 b1 b2 + assert $ heytingR12 b1 b2 + assert $ heytingR13 b1 b2 + assert $ heytingR14 b1 + assert $ heytingR15 b1 + assert $ heytingR16 b1 + assert $ heytingR17 b1 + + assert $ adjointR (heyting o3) o1 o2 + assert $ closedR (heyting o3) o1 + assert $ kernelR (heyting o3) o2 + assert $ monotonicR (heyting o3) o1 o2 o3 o2 + assert $ idempotentR (heyting o3) o1 o2 + + assert $ adjointR booleanR o1 o2 + assert $ closedR booleanR o1 + assert $ kernelR booleanR o2 + assert $ monotonicR booleanR o1 o2 o3 o2 + assert $ idempotentR booleanR o1 o3 + + assert $ heytingR0 o1 o2 o3 + assert $ heytingR1 o1 o2 o3 + assert $ heytingR2 o1 o2 o3 + assert $ heytingR3 o1 o2 o3 + assert $ heytingR4 o1 o2 o3 + assert $ heytingR5 o1 o2 o3 + assert $ heytingR6 o1 o2 + assert $ heytingR7 o1 o2 + assert $ heytingR8 o1 + assert $ heytingR9 o1 o2 + assert $ heytingR10 o1 o2 + assert $ heytingR11 o1 o2 + assert $ heytingR12 o1 o2 + assert $ heytingR13 o1 o2 + assert $ heytingR14 o1 + assert $ heytingR15 o1 + assert $ heytingR16 o1 + assert $ heytingR17 o1 + + assert $ adjointR (heyting w3) w1 w2 + assert $ closedR (heyting w3) w1 + assert $ kernelR (heyting w3) w2 + assert $ monotonicR (heyting w3) w1 w2 w3 w2 + assert $ idempotentR (heyting w3) w1 w2 + + assert $ adjointR booleanR w1 w2 + assert $ closedR booleanR w1 + assert $ kernelR booleanR w2 + assert $ monotonicR booleanR w1 w2 w3 w2 + assert $ idempotentR booleanR w1 w3 + + assert $ heytingR0 w1 w2 w3 + assert $ heytingR1 w1 w2 w3 + assert $ heytingR2 w1 w2 w3 + assert $ heytingR3 w1 w2 w3 + assert $ heytingR4 w1 w2 w3 + assert $ heytingR5 w1 w2 w3 + assert $ heytingR6 w1 w2 + assert $ heytingR7 w1 w2 + assert $ heytingR8 w1 + assert $ heytingR9 w1 w2 + assert $ heytingR10 w1 w2 + assert $ heytingR11 w1 w2 + assert $ heytingR12 w1 w2 + assert $ heytingR13 w1 w2 + assert $ heytingR14 w1 + assert $ heytingR15 w1 + assert $ heytingR16 w1 + assert $ heytingR17 w1 + +prop_symmetric :: Property +prop_symmetric = withTests 1000 . property $ do + b1 <- forAll G.bool + b2 <- forAll G.bool + b3 <- forAll G.bool + o1 <- forAll ord + o2 <- forAll ord + + assert $ symmetric1 b1 + assert $ symmetric2 b1 + assert $ symmetric3 b1 + assert $ symmetric4 b1 + assert $ symmetric5 b1 + assert $ symmetric6 b1 + assert $ symmetric7 b1 b2 + assert $ symmetric8 b1 b2 + assert $ symmetric9 b1 b2 + assert $ symmetric10 b1 b2 + assert $ symmetric11 b1 b2 + assert $ symmetric12 b1 b2 + assert $ symmetric13 b1 b2 + + assert $ adjoint boolean b1 b2 + assert $ closed boolean b1 + assert $ kernel boolean b2 + assert $ monotonic boolean b1 b2 b3 b2 + assert $ idempotent boolean b1 b3 + + assert $ boolean0 b1 + assert $ boolean1 b1 + assert $ boolean2 b1 + assert $ boolean3 b1 + assert $ boolean4 b1 b2 + assert $ boolean5 b1 b2 + assert $ boolean6 b1 b2 + + assert $ symmetric1 o1 + assert $ symmetric2 o1 + assert $ symmetric3 o1 + assert $ symmetric4 o1 + assert $ symmetric5 o1 + assert $ symmetric6 o1 + assert $ symmetric7 o1 o2 + assert $ symmetric8 o1 o2 + assert $ symmetric9 o1 o2 + assert $ symmetric10 o1 o2 + assert $ symmetric11 o1 o2 + assert $ symmetric12 o1 o2 + assert $ symmetric13 o1 o2 + +tests :: IO Bool +tests = checkParallel $$(discover) diff --git a/test/Test/Data/Order.hs b/test/Test/Data/Order.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Order.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE TemplateHaskell #-} +module Test.Data.Order where + +import Data.Int +import Data.Word +import Hedgehog +import Test.Data.Connection + +import qualified Data.Order.Property as Prop +import qualified Hedgehog.Gen as G + + +prop_order_i08 :: Property +prop_order_i08 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Int8) + y <- forAll $ G.integral (ri @Int8) + z <- forAll $ G.integral (ri @Int8) + w <- forAll $ G.integral (ri @Int8) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_i16 :: Property +prop_order_i16 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Int16) + y <- forAll $ G.integral (ri @Int16) + z <- forAll $ G.integral (ri @Int16) + w <- forAll $ G.integral (ri @Int16) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_i32 :: Property +prop_order_i32 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Int32) + y <- forAll $ G.integral (ri @Int32) + z <- forAll $ G.integral (ri @Int32) + w <- forAll $ G.integral (ri @Int32) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_i64 :: Property +prop_order_i64 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Int64) + y <- forAll $ G.integral (ri @Int64) + z <- forAll $ G.integral (ri @Int64) + w <- forAll $ G.integral (ri @Int64) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_ixx :: Property +prop_order_ixx = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Int) + y <- forAll $ G.integral (ri @Int) + z <- forAll $ G.integral (ri @Int) + w <- forAll $ G.integral (ri @Int) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_int :: Property +prop_order_int = withTests 1000 . property $ do + x <- forAll $ G.integral ri' + y <- forAll $ G.integral ri' + z <- forAll $ G.integral ri' + w <- forAll $ G.integral ri' + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_w08 :: Property +prop_order_w08 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Word8) + y <- forAll $ G.integral (ri @Word8) + z <- forAll $ G.integral (ri @Word8) + w <- forAll $ G.integral (ri @Word8) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_w16 :: Property +prop_order_w16 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Word16) + y <- forAll $ G.integral (ri @Word16) + z <- forAll $ G.integral (ri @Word16) + w <- forAll $ G.integral (ri @Word16) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_w32 :: Property +prop_order_w32 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Word32) + y <- forAll $ G.integral (ri @Word32) + z <- forAll $ G.integral (ri @Word32) + w <- forAll $ G.integral (ri @Word32) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_w64 :: Property +prop_order_w64 = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Word64) + y <- forAll $ G.integral (ri @Word64) + z <- forAll $ G.integral (ri @Word64) + w <- forAll $ G.integral (ri @Word64) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +prop_order_wxx :: Property +prop_order_wxx = withTests 1000 . property $ do + x <- forAll $ G.integral (ri @Word) + y <- forAll $ G.integral (ri @Word) + z <- forAll $ G.integral (ri @Word) + w <- forAll $ G.integral (ri @Word) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + +prop_order_nat :: Property +prop_order_nat = withTests 1000 . property $ do + x <- forAll $ G.integral rn + y <- forAll $ G.integral rn + z <- forAll $ G.integral rn + w <- forAll $ G.integral rn + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + +prop_order_rat :: Property +prop_order_rat = withTests 1000 . property $ do + x <- forAll rat + y <- forAll rat + z <- forAll rat + w <- forAll rat + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + +prop_order_pos :: Property +prop_order_pos = withTests 1000 . property $ do + x <- forAll pos + y <- forAll pos + z <- forAll pos + w <- forAll pos + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + +prop_order_f32 :: Property +prop_order_f32 = withTests 1000 . property $ do + x <- forAll f32 + y <- forAll f32 + z <- forAll f32 + w <- forAll f32 + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + +prop_order_f64 :: Property +prop_order_f64 = withTests 1000 . property $ do + x <- forAll f64 + y <- forAll f64 + z <- forAll f64 + w <- forAll f64 + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + +prop_order_extended :: Property +prop_order_extended = withTests 1000 . property $ do + x <- forAll . gen_extended $ G.integral (ri @Int8) + y <- forAll . gen_extended $ G.integral (ri @Int8) + z <- forAll . gen_extended $ G.integral (ri @Int8) + w <- forAll . gen_extended $ G.integral (ri @Int8) + assert $ Prop.preorder x y + assert $ Prop.order z w + assert $ Prop.reflexive_eq x + assert $ Prop.reflexive_le x + assert $ Prop.irreflexive_lt x + assert $ Prop.symmetric_eq x y + assert $ Prop.asymmetric_lt x y + assert $ Prop.antisymmetric_le x y + assert $ Prop.transitive_lt x y z + assert $ Prop.transitive_le x y z + assert $ Prop.transitive_eq x y z + assert $ Prop.chain_22 x y z w + assert $ Prop.chain_31 x y z w + +tests :: IO Bool +tests = checkParallel $$(discover) diff --git a/test/Test/Data/Prd.hs b/test/Test/Data/Prd.hs deleted file mode 100644 --- a/test/Test/Data/Prd.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Test.Data.Prd where - -import Data.Int -import Data.Word -import Test.Data.Connection -import Hedgehog - -import qualified Data.Prd.Property as Prop -import qualified Hedgehog.Gen as G - -prop_prd_i08 :: Property -prop_prd_i08 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Int8) - y <- forAll $ G.integral (ri @Int8) - z <- forAll $ G.integral (ri @Int8) - w <- forAll $ G.integral (ri @Int8) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_i16 :: Property -prop_prd_i16 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Int16) - y <- forAll $ G.integral (ri @Int16) - z <- forAll $ G.integral (ri @Int16) - w <- forAll $ G.integral (ri @Int16) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_i32 :: Property -prop_prd_i32 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Int32) - y <- forAll $ G.integral (ri @Int32) - z <- forAll $ G.integral (ri @Int32) - w <- forAll $ G.integral (ri @Int32) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_i64 :: Property -prop_prd_i64 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Int64) - y <- forAll $ G.integral (ri @Int64) - z <- forAll $ G.integral (ri @Int64) - w <- forAll $ G.integral (ri @Int64) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_ixx :: Property -prop_prd_ixx = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Int) - y <- forAll $ G.integral (ri @Int) - z <- forAll $ G.integral (ri @Int) - w <- forAll $ G.integral (ri @Int) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_int :: Property -prop_prd_int = withTests 1000 . property $ do - x <- forAll $ G.integral ri' - y <- forAll $ G.integral ri' - z <- forAll $ G.integral ri' - w <- forAll $ G.integral ri' - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_w08 :: Property -prop_prd_w08 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Word8) - y <- forAll $ G.integral (ri @Word8) - z <- forAll $ G.integral (ri @Word8) - w <- forAll $ G.integral (ri @Word8) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_w16 :: Property -prop_prd_w16 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Word16) - y <- forAll $ G.integral (ri @Word16) - z <- forAll $ G.integral (ri @Word16) - w <- forAll $ G.integral (ri @Word16) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_w32 :: Property -prop_prd_w32 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Word32) - y <- forAll $ G.integral (ri @Word32) - z <- forAll $ G.integral (ri @Word32) - w <- forAll $ G.integral (ri @Word32) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_w64 :: Property -prop_prd_w64 = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Word64) - y <- forAll $ G.integral (ri @Word64) - z <- forAll $ G.integral (ri @Word64) - w <- forAll $ G.integral (ri @Word64) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_wxx :: Property -prop_prd_wxx = withTests 1000 . property $ do - x <- forAll $ G.integral (ri @Word) - y <- forAll $ G.integral (ri @Word) - z <- forAll $ G.integral (ri @Word) - w <- forAll $ G.integral (ri @Word) - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -prop_prd_nat :: Property -prop_prd_nat = withTests 1000 . property $ do - x <- forAll $ G.integral rn - y <- forAll $ G.integral rn - z <- forAll $ G.integral rn - w <- forAll $ G.integral rn - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - assert $ Prop.chain_31 x y z w - -{- -w = (-61190296498818470224935979790417002496) % 1 -y = 784675940593409576367211913280487424 % 1 -z = 44351588178463768880997328738947432448 % 1 -w = 0 % 0 -Prop.chain_31 x y z w --} - -prop_prd_rat :: Property -prop_prd_rat = withTests 1000 . property $ do - x <- forAll rat - y <- forAll rat - z <- forAll rat - w <- forAll rat - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - -prop_prd_pos :: Property -prop_prd_pos = withTests 1000 . property $ do - x <- forAll pos - y <- forAll pos - z <- forAll pos - w <- forAll pos - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - -prop_prd_f32 :: Property -prop_prd_f32 = withTests 1000 . property $ do - x <- forAll f32 - y <- forAll f32 - z <- forAll f32 - w <- forAll f32 - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - -prop_prd_f64 :: Property -prop_prd_f64 = withTests 1000 . property $ do - x <- forAll f64 - y <- forAll f64 - z <- forAll f64 - w <- forAll f64 - assert $ Prop.consistent x y - assert $ Prop.consistent z w - assert $ Prop.reflexive_eq x - assert $ Prop.reflexive_le x - assert $ Prop.irreflexive_lt x - assert $ Prop.symmetric x y - assert $ Prop.asymmetric x y - assert $ Prop.antisymmetric x y - assert $ Prop.transitive_lt x y z - assert $ Prop.transitive_le x y z - assert $ Prop.transitive_eq x y z - assert $ Prop.chain_22 x y z w - -tests :: IO Bool -tests = checkParallel $$(discover) diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -2,7 +2,8 @@ import System.Exit (exitFailure) import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) -import qualified Test.Data.Prd as P +import qualified Test.Data.Order as P +import qualified Test.Data.Lattice as L import qualified Test.Data.Connection as C import qualified Test.Data.Connection.Int as CI import qualified Test.Data.Connection.Word as CW @@ -11,12 +12,13 @@ tests :: IO [Bool] tests = sequence - [ P.tests - , C.tests - , CI.tests - , CW.tests - , CF.tests - , CR.tests + [ P.tests + , L.tests + , C.tests + , CI.tests + , CW.tests + , CF.tests + , CR.tests ] main :: IO ()