Merge pull request #120 from haskellari/prepare-2.1

Fix comparable of PartialOrd (a,b) instance, remove Stacked in favour of Either

Author: phadej

CHANGELOG.md

@@ -1,3 +1,11 @@
+# 2.1 (2022-12-27)
+
+- Fix `comprable` for `PartialOrd (a,b)` instance
+- Remove `Stacked`, use `Either` instead for ordinal sum.
+  There is no type for disjoint union / parallel composition.
+  Open an issue if you need one.
+  Terminology is from https://en.wikipedia.org/wiki/Partially_ordered_set#Sums_of_partially_ordered_sets
+
 # 2.0.3 (2021-10-30)
 
 - Add instances for `Solo`

lattices.cabal

@@ -1,7 +1,6 @@
 cabal-version:      1.18
 name:               lattices
-version:            2.0.3
-x-revision:         4
+version:            2.1
 category:           Math
 license:            BSD3
 license-file:       LICENSE
@@ -69,7 +68,6 @@ library
     Algebra.Lattice.N5
     Algebra.Lattice.Op
     Algebra.Lattice.Ordered
-    Algebra.Lattice.Stacked
     Algebra.Lattice.Unicode
     Algebra.Lattice.Wide
     Algebra.Lattice.ZeroHalfOne

src/Algebra/Lattice.hs

@@ -310,6 +310,32 @@ instance (BoundedJoinSemiLattice a, BoundedJoinSemiLattice b) => BoundedJoinSemi
 instance (BoundedMeetSemiLattice a, BoundedMeetSemiLattice b) => BoundedMeetSemiLattice (a, b) where
     top = (top, top)
 
+--
+-- Either
+--
+
+-- | Ordinal sum.
+--
+-- @since 2.1
+instance (Lattice a, Lattice b) => Lattice (Either a b) where
+    Right x     \/ Right y     = Right (x \/ y)
+    u@(Right _) \/ _           = u
+    _           \/ u@(Right _) = u
+    Left x      \/ Left y      = Left (x \/ y)
+
+    Left x      /\ Left y     = Left (x /\ y)
+    l@(Left _)  /\ _          = l
+    _           /\ l@(Left _) = l
+    Right x     /\ Right y    = Right (x /\ y)
+
+-- | @since 2.1
+instance (BoundedJoinSemiLattice a, Lattice b) => BoundedJoinSemiLattice (Either a b) where
+    bottom = Left bottom
+
+-- | @since 2.1
+instance (Lattice a, BoundedMeetSemiLattice b) => BoundedMeetSemiLattice (Either a b) where
+    top = Right top
+
 --
 -- Bools
 --

src/Algebra/Lattice/Stacked.hs

@@ -148,17 +148,19 @@ instance (PartialOrd a, PartialOrd b) => PartialOrd (a, b) where
     -- ordering is incompatible with the transitivity axiom we require for the derived partial order
     (x1, y1) `leq` (x2, y2) = x1 `leq` x2 && y1 `leq` y2
 
-    comparable (x1, y1) (x2, y2) = comparable x1 x2 && comparable y1 y2
-
--- | @since 2.0.1
+-- | Ordinal sum.
+--
+-- @since 2.1
 instance (PartialOrd a, PartialOrd b) => PartialOrd (Either a b) where
-    Left x  `leq` Left y  = leq x y
-    Right x `leq` Right y = leq x y
-    leq _ _ = False
+    leq (Right x) (Right y) = leq x y
+    leq (Right _) _         = False
+    leq _         (Right _) = True
+    leq (Left x)  (Left y)  = leq x y
 
-    comparable (Left x)  (Left y)  = comparable x y
     comparable (Right x) (Right y) = comparable x y
-    comparable _ _ = False
+    comparable (Right _) _         = True
+    comparable _         (Right _) = True
+    comparable (Left x)  (Left y)  = comparable x y
 
 -- | Least point of a partially ordered monotone function. Checks that the function is monotone.
 lfpFrom :: PartialOrd a => a -> (a -> a) -> a

src/Algebra/PartialOrd.hs

@@ -44,7 +44,6 @@ import qualified Algebra.Lattice.Lexicographic as LO
 import qualified Algebra.Lattice.Lifted        as U
 import qualified Algebra.Lattice.Op            as Op
 import qualified Algebra.Lattice.Ordered       as O
-import qualified Algebra.Lattice.Stacked       as S
 import qualified Algebra.Lattice.Wide          as W
 
 import Data.HashMap.Lazy (HashMap)
@@ -90,11 +89,14 @@ tests = testGroup "Tests"
     , allLatticeLaws (LBounded Partial Modular)          (Proxy :: Proxy (W.Wide Int))
     , allLatticeLaws (LBounded Partial NonModular)       (Proxy :: Proxy (LO.Lexicographic (Set Bool) (Set Bool)))
     , allLatticeLaws (LBounded Partial NonModular)       (Proxy :: Proxy (LO.Lexicographic M2 M2)) -- non distributive!
-    , allLatticeLaws (LBounded Partial Distributive)     (Proxy :: Proxy (S.Stacked M2 M2))
-    , allLatticeLaws (LBounded Partial NonModular)       (Proxy :: Proxy (S.Stacked M3 N5)) -- non modular, though it takes QC time to find
+
 
     , allLatticeLaws LNotLattice                         (Proxy :: Proxy String)
 
+    , allLatticeLaws (LBounded Partial Modular)          (Proxy :: Proxy (M2, M2))
+    , allLatticeLaws (LBounded Partial Distributive)     (Proxy :: Proxy (Either M2 M2))
+    , allLatticeLaws (LBounded Partial NonModular)       (Proxy :: Proxy (Either M3 N5)) -- non modular, though it takes QC time to find
+
     , allLatticeLaws (LHeyting Total   IsBoolean)        (Proxy :: Proxy All)
     , allLatticeLaws (LHeyting Total   IsBoolean)        (Proxy :: Proxy Any)
     , allLatticeLaws (LHeyting Partial IsBoolean)        (Proxy :: Proxy (Endo Bool)) -- note: it's partial!
@@ -122,7 +124,6 @@ tests = testGroup "Tests"
     , monadLaws "Op" (Proxy1 :: Proxy1 Op.Op)
     , monadLaws "Ordered" (Proxy1 :: Proxy1 O.Ordered)
     , monadLaws "Wide" (Proxy1 :: Proxy1 W.Wide)
-    , monadLaws "Stacked" (Proxy1 :: Proxy1 (S.Stacked N5))
     , monadLaws "Heyting.Free" (Proxy1 :: Proxy1 HF.Free)
 
     , finiteLaws (Proxy :: Proxy M2)
@@ -137,7 +138,6 @@ tests = testGroup "Tests"
     , finiteLaws (Proxy :: Proxy (L.Levitated OInt8))
     , finiteLaws (Proxy :: Proxy (U.Lifted OInt8))
     , finiteLaws (Proxy :: Proxy (LO.Lexicographic OInt8 OInt8))
-    , finiteLaws (Proxy :: Proxy (S.Stacked OInt8 OInt8))
     ]
 
 type OInt8 = O.Ordered Int8