valuations-0.0.3: src/Data/Valuation/SemiValuationAlgebra.hs

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

-- | A semi-valuation algebra: a semigroup paired with a projection.
module Data.Valuation.SemiValuationAlgebra
  ( SemiValuationAlgebra (..),
    SemiValuationAlgebra',
    SetSemiValuationAlgebra,

    -- * optics
    HasSemiValuationAlgebra (..),
    AsSemiValuationAlgebra (..),

    -- * combinators
    projectValuation',
  )
where

import Control.Arrow (Arrow (..))
import Control.Category (Category (..))
import Control.Lens
  ( Lens,
    Lens',
    Prism',
    review,
  )
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 (..),
    ProjectValuation (..),
  )
import Data.Valuation.Semigroup
  ( HasSemigroup (..),
    Semigroup,
    applySemigroup,
  )
import Witherable (Filterable)
import Prelude hiding (Semigroup, id, (.))
import qualified Prelude

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (applySemigroup, runSemigroup)
-- >>> import Data.Void (Void)
-- >>> import Prelude hiding (Semigroup)

-- |
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s)) :: SemiValuationAlgebra (->) Int [] Int
-- >>> runSemigroup sg 3 4
-- 7
-- >>> p [1,2,3] 10
-- 16
data SemiValuationAlgebra p v set var
  = SemiValuationAlgebra
      -- | algebra combine
      (Semigroup p v)
      -- | algebra project
      (ProjectValuation p v set var)

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

-- | Type-changing lens to the 'ProjectValuation' component.
projectValuation' :: Lens (SemiValuationAlgebra p v set var) (SemiValuationAlgebra p v set' var') (ProjectValuation p v set var) (ProjectValuation p v set' var')
projectValuation' f (SemiValuationAlgebra s p) = fmap (SemiValuationAlgebra s) (f p)

-- | Classy lens for types that contain a 'SemiValuationAlgebra'.
class HasSemiValuationAlgebra c p v set var | c -> p v set var where
  semiValuationAlgebra ::
    Lens' c (SemiValuationAlgebra p v set var)

instance HasSemiValuationAlgebra (SemiValuationAlgebra p v set var) p v set var where
  semiValuationAlgebra = id

-- | Classy prism for types that can be constructed from a 'SemiValuationAlgebra'.
class AsSemiValuationAlgebra c p v set var | c -> p v set var where
  _SemiValuationAlgebra ::
    Prism' c (SemiValuationAlgebra p v set var)

instance AsSemiValuationAlgebra (SemiValuationAlgebra p v set var) p v set var where
  _SemiValuationAlgebra = id

instance HasSemigroup (SemiValuationAlgebra p v set var) p v where
  semigroup f (SemiValuationAlgebra s p) = fmap (`SemiValuationAlgebra` p) (f s)

instance HasProjectValuation (SemiValuationAlgebra p v set var) p v set var where
  projectValuation = projectValuation'

-- |
-- >>> import Data.Functor.Contravariant (contramap)
-- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s)) :: SemiValuationAlgebra (->) Int [] Int
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = contramap (*2) sva
-- >>> runSemigroup sg 3 4
-- 7
-- >>> p [1,2,3] 10
-- 22
instance (Functor set, Profunctor p) => Contravariant (SemiValuationAlgebra p v set) where
  contramap f (SemiValuationAlgebra s p) = SemiValuationAlgebra s (contramap f p)

-- |
-- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = conquer :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> runSemigroup sg [1,2] [3,4]
-- [1,2,3,4]
-- >>> p [10,20,30] [42]
-- [42]
--
-- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = divide (\x -> (x, x + 10)) sva1 sva2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> p [1,2,3] [0]
-- [0,13,12,11,1,2,3]
instance (Functor set, Strong p, Arrow p, Prelude.Semigroup v) => Divisible (SemiValuationAlgebra p v set) where
  conquer = SemiValuationAlgebra (review applySemigroup (rmap arr (arr (<>)))) conquer
  divide f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =
    SemiValuationAlgebra s (divide f p1 p2)

-- |
-- >>> import Data.Functor.Contravariant.Divisible (choose, lose)
-- >>> import Data.Void (Void, absurd)
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = lose absurd :: SemiValuationAlgebra (->) [Int] [] Void
-- >>> runSemigroup sg [1,2] [3,4]
-- [1,2,3,4]
-- >>> p [] [42]
-- [42]
--
-- >>> import Data.Functor.Contravariant.Divisible (choose)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ map negate s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = choose (\x -> if even x then Left x else Right x) sva1 sva2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> p [1,2,3,4] [0]
-- [0,-1,-3,2,4]
instance (Filterable set, Strong p, Arrow p, Prelude.Semigroup v) => Decidable (SemiValuationAlgebra p v set) where
  lose f = SemiValuationAlgebra (review applySemigroup (rmap arr (arr (<>)))) (lose f)
  choose f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =
    SemiValuationAlgebra s (choose f p1 p2)

-- |
-- >>> import Data.Functor.Contravariant.Divise (divise)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = divise (\x -> (x, x + 10)) sva1 sva2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> p [1,2,3] [0]
-- [0,13,12,11,1,2,3]
instance (Functor set, Strong p, Semigroupoid p) => Divise (SemiValuationAlgebra p v set) where
  divise f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =
    SemiValuationAlgebra s (divise f p1 p2)

-- |
-- >>> import Data.Functor.Contravariant.Decide (decide)
-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ map negate s)) :: SemiValuationAlgebra (->) [Int] [] Int
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = decide (\x -> if even x then Left x else Right x) sva1 sva2
-- >>> runSemigroup sg [1] [2]
-- [1,2]
-- >>> p [1,2,3,4] [0]
-- [0,-1,-3,2,4]
instance (Filterable set, Strong p, Semigroupoid p) => Decide (SemiValuationAlgebra p v set) where
  decide f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =
    SemiValuationAlgebra s (decide f p1 p2)

-- |
-- >>> import Data.Functor.Contravariant.Conclude (conclude)
-- >>> import Data.Void (absurd)
-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = conclude absurd :: SemiValuationAlgebra (->) [Int] [] Void
-- >>> runSemigroup sg [1,2] [3,4]
-- [1,2,3,4]
-- >>> p [] [42]
-- [42]
instance (Filterable set, Strong p, Semigroupoid p, Arrow p, Prelude.Semigroup v) => Conclude (SemiValuationAlgebra p v set) where
  conclude f = SemiValuationAlgebra (review applySemigroup (rmap arr (arr (<>)))) (conclude f)

-- | A 'SemiValuationAlgebra' specialised to 'Set'.
type SetSemiValuationAlgebra p v var =
  SemiValuationAlgebra p v Set var