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

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- | A valuation algebra: a semi-valuation algebra with unit and zero operations.
module Data.Valuation.ValuationAlgebra
  ( ValuationAlgebra (..),
    ValuationAlgebra',
    SetValuationAlgebra,
    SetValuationAlgebra',

    -- * optics
    HasValuationAlgebra (..),
    AsValuationAlgebra (..),
  )
where

import Control.Arrow (Arrow (..))
import Control.Category (Category (..))
import Control.Lens (Lens', Prism')
import Data.Functor.Contravariant (Contravariant (..))
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 (..), Strong (..))
import Data.Semigroupoid (Semigroupoid (..))
import Data.Set (Set)
import Data.Valuation.ProjectValuation (HasProjectValuation (..))
import Data.Valuation.SemiValuationAlgebra
  ( HasSemiValuationAlgebra (..),
    SemiValuationAlgebra,
  )
import Data.Valuation.Semigroup (HasSemigroup (..))
import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp (..))
import Witherable (Filterable (mapMaybe))
import Prelude hiding (Semigroup, id, (.))
import qualified Prelude

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

-- |
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s))
-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp sum) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) (->) (->) Int [] Int
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = va
-- >>> runSemigroup sg 3 4
-- 7
-- >>> p [1,2,3] 10
-- 16
-- >>> u [1,2,3]
-- 6
-- >>> z [1,2,3]
-- 0
data ValuationAlgebra p q r v set var
  = ValuationAlgebra
      (SemiValuationAlgebra p q r v set var)
      -- | algebra unit
      (ValuationAlgebraOp p set var v)
      -- | algebra zero
      (ValuationAlgebraOp p set var v)

type ValuationAlgebra' v set var =
  ValuationAlgebra (->) (->) (->) v set var

-- | Classy lens for types that contain a 'ValuationAlgebra'.
class HasValuationAlgebra c p q r v set var | c -> p q r v set var where
  valuationAlgebra :: Lens' c (ValuationAlgebra p q r v set var)
  valuationAlgebraUnit :: Lens' c (ValuationAlgebraOp p set var v)
  valuationAlgebraUnit = valuationAlgebra . valuationAlgebraUnit
  valuationAlgebraZero :: Lens' c (ValuationAlgebraOp p set var v)
  valuationAlgebraZero = valuationAlgebra . valuationAlgebraZero

instance HasValuationAlgebra (ValuationAlgebra p q r v set var) p q r v set var where
  valuationAlgebra = id
  valuationAlgebraUnit f (ValuationAlgebra s u z) = fmap (\u' -> ValuationAlgebra s u' z) (f u)
  valuationAlgebraZero f (ValuationAlgebra s u z) = fmap (ValuationAlgebra s u) (f z)

-- | Classy prism for types that can be constructed from a 'ValuationAlgebra'.
class AsValuationAlgebra c p q r v set var | c -> p q r v set var where
  _ValuationAlgebra :: Prism' c (ValuationAlgebra p q r v set var)

instance AsValuationAlgebra (ValuationAlgebra p q r v set var) p q r v set var where
  _ValuationAlgebra = id

instance HasSemiValuationAlgebra (ValuationAlgebra p q r v set var) p q r v set var where
  semiValuationAlgebra f (ValuationAlgebra a u z) = fmap (\a' -> ValuationAlgebra a' u z) (f a)

instance HasSemigroup (ValuationAlgebra p q r v set var) p v where
  semigroup = semiValuationAlgebra . semigroup

instance HasProjectValuation (ValuationAlgebra p q r v set var) q r v set var where
  projectValuation = semiValuationAlgebra . projectValuation

-- |
-- >>> import Data.Functor.Contravariant (contramap)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s))
-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp sum) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) (->) (->) Int [] Int
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = contramap (*2) va
-- >>> runSemigroup sg 3 4
-- 7
-- >>> p [1,2,3] 10
-- 22
-- >>> u [1,2,3]
-- 12
-- >>> z [1,2,3]
-- 0
instance (Profunctor p, Profunctor q, Functor set) => Contravariant (ValuationAlgebra p q r v set) where
  contramap f (ValuationAlgebra s (ValuationAlgebraOp u) (ValuationAlgebraOp z)) =
    ValuationAlgebra (contramap f s) (ValuationAlgebraOp (lmap (fmap f) u)) (ValuationAlgebraOp (lmap (fmap f) z))

-- |
-- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = conquer :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> p [10,20] [42]
-- [42]
-- >>> u [10,20]
-- []
-- >>> z [10,20]
-- []
--
-- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))
-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))
-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = divide (\x -> (x, x + 10)) va1 va2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> u [1,2,3]
-- [1,2,3,13,12,11]
-- >>> z [1,2,3]
-- [-1,-2,-3]
instance (Functor set, Strong p, Strong q, Arrow p, Category q, Category r, Prelude.Semigroup v, Prelude.Monoid v) => Divisible (ValuationAlgebra p q r v set) where
  conquer = ValuationAlgebra conquer (ValuationAlgebraOp (rmap (const mempty) id)) (ValuationAlgebraOp (rmap (const mempty) id))
  divide f (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =
    let combine g1 g2 =
          let g1' = lmap (fmap (fst . f)) g1
              g2' = lmap (fmap (snd . f)) g2
           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' . first' g1')))
     in ValuationAlgebra (divide f s1 s2) (combine u1 u2) (combine z1 z2)

-- |
-- >>> import Data.Functor.Contravariant.Divisible (choose, lose)
-- >>> import Data.Void (Void, absurd)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = lose absurd :: ValuationAlgebra (->) (->) (->) [Int] [] Void
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> p [] [42]
-- [42]
-- >>> u []
-- []
-- >>> z []
-- []
--
-- >>> import Data.Functor.Contravariant.Divisible (choose)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))
-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))
-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = choose (\x -> if even x then Left x else Right x) va1 va2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> u [1,2,3,4]
-- [2,4,3,1]
-- >>> z [1,2,3,4]
-- [-2,-4]
instance (Filterable set, Strong p, Strong q, Arrow p, Category q, Category r, Prelude.Semigroup v, Prelude.Monoid v) => Decidable (ValuationAlgebra p q r v set) where
  lose f = ValuationAlgebra (lose f) (ValuationAlgebraOp (rmap (const mempty) id)) (ValuationAlgebraOp (rmap (const mempty) id))
  choose ch (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =
    let lefts = mapMaybe (either Just (const Nothing) . ch)
        rights = mapMaybe (either (const Nothing) Just . ch)
        combine g1 g2 =
          let g1' = lmap lefts g1
              g2' = lmap rights g2
           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' . first' g1')))
     in ValuationAlgebra (choose ch s1 s2) (combine u1 u2) (combine z1 z2)

-- |
-- >>> import Data.Functor.Contravariant.Divise (divise)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))
-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))
-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = divise (\x -> (x, x + 10)) va1 va2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> u [1,2,3]
-- [1,2,3,13,12,11]
-- >>> z [1,2,3]
-- [-1,-2,-3]
instance (Functor set, Strong p, Semigroupoid p, Strong q, Semigroupoid q, Semigroupoid r, Prelude.Semigroup v) => Divise (ValuationAlgebra p q r v set) where
  divise f (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =
    let combine g1 g2 =
          let g1' = lmap (fmap (fst . f)) g1
              g2' = lmap (fmap (snd . f)) g2
           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' `o` first' g1')))
     in ValuationAlgebra (divise f s1 s2) (combine u1 u2) (combine z1 z2)

-- |
-- >>> import Data.Functor.Contravariant.Decide (decide)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))
-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))
-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) (->) (->) [Int] [] Int
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = decide (\x -> if even x then Left x else Right x) va1 va2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> u [1,2,3,4]
-- [2,4,3,1]
-- >>> z [1,2,3,4]
-- [-2,-4]
instance (Filterable set, Strong p, Semigroupoid p, Strong q, Semigroupoid q, Semigroupoid r, Prelude.Semigroup v) => Decide (ValuationAlgebra p q r v set) where
  decide ch (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =
    let lefts = mapMaybe (either Just (const Nothing) . ch)
        rights = mapMaybe (either (const Nothing) Just . ch)
        combine g1 g2 =
          let g1' = lmap lefts g1
              g2' = lmap rights g2
           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' `o` first' g1')))
     in ValuationAlgebra (decide ch s1 s2) (combine u1 u2) (combine z1 z2)

-- |
-- >>> import Data.Functor.Contravariant.Conclude (conclude)
-- >>> import Data.Void (absurd)
-- >>> import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra(..))
-- >>> import Data.Valuation.ProjectValuation (ProjectValuation(..))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)
-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = conclude absurd :: ValuationAlgebra (->) (->) (->) [Int] [] Void
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> u []
-- []
-- >>> z []
-- []
instance (Filterable set, Strong p, Semigroupoid p, Arrow p, Strong q, Semigroupoid q, Category q, Semigroupoid r, Category r, Prelude.Semigroup v, Prelude.Monoid v) => Conclude (ValuationAlgebra p q r v set) where
  conclude f = ValuationAlgebra (conclude f) (ValuationAlgebraOp (rmap (const mempty) id)) (ValuationAlgebraOp (rmap (const mempty) id))

-- | A 'ValuationAlgebra' specialised to 'Set'.
type SetValuationAlgebra p q r v var =
  ValuationAlgebra p q r v Set var

type SetValuationAlgebra' v var =
  SetValuationAlgebra (->) (->) (->) v var