valuations-0.0.4: src/Data/Valuation/Poset.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- | A poset (partial order) on a type, generalised over a 'Profunctor' @p@,
-- wrapping @p a (p a 'Bool')@.
-- When @p ~ (->)@, this specialises to @a -> a -> 'Bool'@
-- (see 'Poset'').
--
-- This is a simplified alternative to
-- 'Data.Valuation.PartialOrder.PartialOrder' which wraps
-- @p a (p a ('Maybe' 'Ordering'))@.
-- While 'Data.Valuation.PartialOrder.PartialOrder' distinguishes
-- @LT@, @EQ@, @GT@, and incomparable,
-- 'Poset' only captures the @<=@ relation as a 'Bool'.
--
-- @
-- 'True'   — a <= b
-- 'False'  — a is not <= b (either a > b, or a and b are incomparable)
-- @
module Data.Valuation.Poset
  ( Poset (..),
    Poset',

    -- * optics
    HasPoset (..),
    AsPoset (..),

    -- * combinators
    semigroupPoset,
    runPoset,
    totalPoset,
    comparisonPoset,
    equivalencePoset,
    fromPartialOrder,
    toPartialOrder,
  )
where

import Control.Lens
  ( Lens',
    Prism',
    Rewrapped,
    Wrapped (..),
    iso,
    review,
  )
import Data.Functor.Apply (Apply, liftF2)
import Data.Functor.Contravariant
  ( Comparison (Comparison),
    Contravariant (contramap),
    Equivalence (Equivalence),
  )
import Data.Functor.Contravariant.Conclude (Conclude (..))
import Data.Functor.Contravariant.Decide (Decide (..))
import Data.Functor.Contravariant.Divise (Divise (..))
import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))
import Data.Profunctor (Profunctor (..))
import qualified Data.Profunctor.Rep as Pro
import Data.Profunctor.Sieve (Sieve (..))
import Data.Valuation.PartialOrder
  ( PartialOrder',
    fromLeq,
    partialOrderLeq,
  )
import Data.Valuation.Semigroup
  ( Semigroup',
    applySemigroup,
    runSemigroup,
  )
import Data.Void (absurd)
import Prelude hiding (Semigroup)
import qualified Prelude

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults
-- >>> import Data.Void (Void)

-- |
-- >>> runPoset (totalPoset :: Poset' Int) 1 2
-- True
-- >>> runPoset (totalPoset :: Poset' Int) 2 2
-- True
-- >>> runPoset (totalPoset :: Poset' Int) 3 2
-- False
--
-- >>> import qualified Data.Set as Set
-- >>> runPoset (Poset Set.isSubsetOf) (Set.fromList [1,2]) (Set.fromList [2,3 :: Int])
-- False
newtype Poset p a
  = Poset (p a (p a Bool))

type Poset' a =
  Poset (->) a

instance (Poset' a ~ t) => Rewrapped (Poset' a') t

instance Wrapped (Poset' a) where
  type Unwrapped (Poset' a) = a -> a -> Bool
  _Wrapped' = iso (\(Poset x) -> x) Poset

-- | Classy lens for types that contain a 'Poset'.
class HasPoset c p a | c -> p a where
  poset :: Lens' c (Poset p a)

instance HasPoset (Poset p a) p a where
  poset = id

-- | Classy prism for types that can be constructed from a 'Poset'.
class AsPoset c p a | c -> p a where
  _Poset :: Prism' c (Poset p a)

instance AsPoset (Poset p a) p a where
  _Poset = id

-- | Unwrap the poset to its underlying profunctor value.
-- For @p ~ (->)@, this gives @a -> a -> 'Bool'@.
--
-- >>> runPoset (totalPoset :: Poset' Int) 1 2
-- True
-- >>> runPoset (totalPoset :: Poset' Int) 2 2
-- True
-- >>> runPoset (totalPoset :: Poset' Int) 3 2
-- False
runPoset :: Poset p a -> p a (p a Bool)
runPoset (Poset f) = f

-- | Construct a 'Poset' from a total order ('Ord' instance).
-- The result is the standard @<=@ comparison.
--
-- >>> runPoset (totalPoset :: Poset' Int) 1 2
-- True
-- >>> runPoset (totalPoset :: Poset' Int) 2 2
-- True
-- >>> runPoset (totalPoset :: Poset' Int) 3 2
-- False
totalPoset :: (Ord a) => Poset' a
totalPoset = Poset (<=)

-- | Lift a 'Comparison' (a reified total order) into a 'Poset''.
-- The result tests @<=@ according to the comparison.
--
-- >>> import Data.Functor.Contravariant (Comparison(..))
-- >>> runPoset (comparisonPoset (Comparison compare)) (1 :: Int) 2
-- True
-- >>> runPoset (comparisonPoset (Comparison compare)) (2 :: Int) 2
-- True
-- >>> runPoset (comparisonPoset (Comparison compare)) (3 :: Int) 2
-- False
--
-- >>> import Data.Functor.Contravariant (Comparison(..), contramap)
-- >>> runPoset (comparisonPoset (contramap negate (Comparison compare))) (1 :: Int) 2
-- False
comparisonPoset :: Comparison a -> Poset' a
comparisonPoset (Comparison cmp) = Poset (\a1 a2 -> cmp a1 a2 /= GT)

-- | Lift an 'Equivalence' (a reified equivalence relation) into a 'Poset''.
-- The result is the discrete order: @a <= b@ iff @a@ is equivalent to @b@.
--
-- >>> import Data.Functor.Contravariant (Equivalence(..), getEquivalence)
-- >>> let eq = Equivalence (\a b -> a `mod` 3 == b `mod` 3) :: Equivalence Int
-- >>> runPoset (equivalencePoset eq) 1 4
-- True
-- >>> runPoset (equivalencePoset eq) 1 2
-- False
equivalencePoset :: Equivalence a -> Poset' a
equivalencePoset (Equivalence p) = Poset p

-- | Convert a 'PartialOrder'' to a 'Poset'' by extracting the @<=@ relation.
-- Returns 'True' when the partial order yields 'Just' 'LT' or 'Just' 'EQ',
-- 'False' otherwise (including incomparable elements).
--
-- >>> import Data.Valuation.PartialOrder (totalOrder, runPartialOrder)
-- >>> let po = totalOrder :: PartialOrder' Int
-- >>> runPoset (fromPartialOrder po) 1 2
-- True
-- >>> runPoset (fromPartialOrder po) 2 2
-- True
-- >>> runPoset (fromPartialOrder po) 3 2
-- False
--
-- >>> import qualified Data.Set as Set
-- >>> import Data.Valuation.PartialOrder (fromLeq)
-- >>> runPoset (fromPartialOrder (fromLeq Set.isSubsetOf)) (Set.fromList [1,2]) (Set.fromList [2,3 :: Int])
-- False
fromPartialOrder :: PartialOrder' a -> Poset' a
fromPartialOrder po = Poset (partialOrderLeq po)

-- | Convert a 'Poset'' to a 'PartialOrder'' by inferring the full ordering
-- from the @<=@ relation.
--
-- * @a <= b@ and @b <= a@ implies @a = b@ ('Just' 'EQ')
-- * @a <= b@ and not @b <= a@ implies @a < b@ ('Just' 'LT')
-- * not @a <= b@ and @b <= a@ implies @a > b@ ('Just' 'GT')
-- * neither implies incomparable ('Nothing')
--
-- >>> import Data.Valuation.PartialOrder (runPartialOrder)
-- >>> let p = totalPoset :: Poset' Int
-- >>> runPartialOrder (toPartialOrder p) 1 2
-- Just LT
-- >>> runPartialOrder (toPartialOrder p) 2 2
-- Just EQ
-- >>> runPartialOrder (toPartialOrder p) 3 2
-- Just GT
--
-- >>> import qualified Data.Set as Set
-- >>> import Data.Valuation.PartialOrder (runPartialOrder)
-- >>> runPartialOrder (toPartialOrder (Poset Set.isSubsetOf)) (Set.fromList [1,2]) (Set.fromList [2,3 :: Int])
-- Nothing
toPartialOrder :: Poset' a -> PartialOrder' a
toPartialOrder (Poset f) = fromLeq f

-- |
-- >>> import Data.Functor.Contravariant (contramap)
-- >>> runPoset (contramap negate (totalPoset :: Poset' Int)) 1 2
-- False
-- >>> runPoset (contramap negate (totalPoset :: Poset' Int)) 2 1
-- True
instance (Profunctor p) => Contravariant (Poset p) where
  contramap f (Poset g) = Poset (dimap f (lmap f) g)

-- | Conjunction as a first-class 'Semigroup': @a <= b@ in the combined
-- poset iff @a <= b@ in /both/ component posets (the product order).
--
-- >>> let p = totalPoset :: Poset' Int
-- >>> runPoset (runSemigroup semigroupPoset p p) 1 2
-- True
-- >>> runPoset (runSemigroup semigroupPoset p p) 2 2
-- True
-- >>> runPoset (runSemigroup semigroupPoset p p) 3 2
-- False
--
-- Two independent orderings:
--
-- >>> let byVal = totalPoset :: Poset' (Int, Int)
-- >>> let byFst = Poset (\(a,_) (b,_) -> a <= b) :: Poset' (Int, Int)
-- >>> runPoset (runSemigroup semigroupPoset byVal byFst) (1, 2) (1, 3)
-- True
-- >>> runPoset (runSemigroup semigroupPoset byVal byFst) (1, 3) (1, 2)
-- False
semigroupPoset :: (Pro.Representable p, Apply (Pro.Rep p)) => Semigroup' (Poset p a)
semigroupPoset = review applySemigroup $ \(Poset pf) (Poset pg) ->
  Poset $ Pro.tabulate $ \a ->
    liftF2
      ( \innerF innerG -> Pro.tabulate $ \b ->
          liftF2 (&&) (sieve innerF b) (sieve innerG b)
      )
      (sieve pf a)
      (sieve pg a)
{-# SPECIALIZE semigroupPoset :: Semigroup' (Poset' a) #-}

-- |
-- >>> let p = totalPoset :: Poset' Int
-- >>> runPoset (p <> p) 1 2
-- True
-- >>> runPoset (p <> p) 2 2
-- True
-- >>> runPoset (p <> p) 3 2
-- False
instance (Pro.Representable p, Apply (Pro.Rep p)) => Prelude.Semigroup (Poset p a) where
  (<>) = runSemigroup semigroupPoset

-- | The trivial poset where all elements are related: @a <= b@ for all @a@, @b@.
--
-- >>> runPoset (mempty :: Poset' Int) 1 2
-- True
-- >>> runPoset (mempty :: Poset' Int) 42 0
-- True
instance (Pro.Representable p, Apply (Pro.Rep p), Applicative (Pro.Rep p)) => Monoid (Poset p a) where
  mempty = Poset (Pro.tabulate (\_ -> pure (Pro.tabulate (\_ -> pure True))))

-- | Product order: split @a@ into @(b, c)@, check @b <= b'@ and @c <= c'@
-- in both component posets. @conquer@ treats all elements as related.
--
-- >>> import Data.Functor.Contravariant.Divisible (divide, conquer)
-- >>> let p = divide id (totalPoset :: Poset' Int) (totalPoset :: Poset' Int)
-- >>> runPoset p (1, 2) (1, 3)
-- True
-- >>> runPoset p (1, 2) (2, 1)
-- False
-- >>> runPoset p (1, 2) (1, 2)
-- True
--
-- >>> import Data.Functor.Contravariant.Divisible (conquer)
-- >>> runPoset (conquer :: Poset' Int) 1 2
-- True
instance (Pro.Representable p, Apply (Pro.Rep p), Applicative (Pro.Rep p)) => Divisible (Poset p) where
  conquer = mempty
  divide f pb pc = contramap (fst . f) pb <> contramap (snd . f) pc

-- | Disjoint sum: classify @a@ as 'Left' @b@ or 'Right' @c@.
-- Elements on the same side are compared by that side's poset.
-- Elements on different sides are not related ('False').
--
-- >>> import Data.Functor.Contravariant.Divisible (choose, lose)
-- >>> import Data.Void (Void, absurd)
-- >>> let p = choose id (totalPoset :: Poset' Int) (totalPoset :: Poset' String)
-- >>> runPoset p (Left 1) (Left 2)
-- True
-- >>> runPoset p (Right "a") (Right "b")
-- True
-- >>> runPoset p (Left 1) (Right "a")
-- False
-- >>> runPoset p (Right "a") (Left 1)
-- False
--
-- >>> import Data.Functor.Contravariant.Divisible (lose)
-- >>> import Data.Void (Void, absurd)
-- >>> let p = lose absurd :: Poset' Void
-- >>> seq p ()
-- ()
instance (Pro.Representable p, Apply (Pro.Rep p), Monad (Pro.Rep p)) => Decidable (Poset p) where
  lose f = Poset (Pro.tabulate (absurd . f))
  choose f pb pc = Poset $ Pro.tabulate $ \a1 ->
    pure $ Pro.tabulate $ \a2 ->
      case (f a1, f a2) of
        (Left b1, Left b2) -> sieve (runPoset pb) b1 >>= \inner -> sieve inner b2
        (Right c1, Right c2) -> sieve (runPoset pc) c1 >>= \inner -> sieve inner c2
        _ -> pure False

-- |
-- >>> import Data.Functor.Contravariant.Divise (divise)
-- >>> let p = divise id (totalPoset :: Poset' Int) (totalPoset :: Poset' Int)
-- >>> runPoset p (1, 2) (1, 3)
-- True
-- >>> runPoset p (1, 2) (1, 2)
-- True
-- >>> runPoset p (1, 2) (2, 1)
-- False
instance (Pro.Representable p, Apply (Pro.Rep p)) => Divise (Poset p) where
  divise f pb pc = contramap (fst . f) pb <> contramap (snd . f) pc

-- |
-- >>> import Data.Functor.Contravariant.Decide (decide)
-- >>> let p = decide id (totalPoset :: Poset' Int) (totalPoset :: Poset' String)
-- >>> runPoset p (Left 1) (Left 2)
-- True
-- >>> runPoset p (Left 1) (Right "a")
-- False
instance (Pro.Representable p, Apply (Pro.Rep p), Monad (Pro.Rep p)) => Decide (Poset p) where
  decide = choose

-- |
-- >>> import Data.Functor.Contravariant.Conclude (conclude)
-- >>> import Data.Void (absurd)
-- >>> let p = conclude absurd :: Poset' Void
-- >>> seq p ()
-- ()
instance (Pro.Representable p, Apply (Pro.Rep p), Monad (Pro.Rep p)) => Conclude (Poset p) where
  conclude = lose