valuations-0.0.1: 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 (..),
    SetSemiValuationAlgebra,

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

    -- * combinators
    projectValuation',
  )
where

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.Set (Set)
import Data.Valuation.ProjectValuation
  ( HasProjectValuation (..),
    ProjectValuation (..),
  )
import Data.Valuation.Semigroup
  ( HasSemigroup (..),
    Semigroup,
    applySemigroup,
  )
import Witherable (Filterable)
import Prelude hiding (Semigroup)
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 v set var
  = SemiValuationAlgebra
      -- | algebra combine
      (Semigroup v)
      -- | algebra project
      (ProjectValuation v set var)

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

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

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

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

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

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

instance HasProjectValuation (SemiValuationAlgebra v set var) 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) => Contravariant (SemiValuationAlgebra 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, Prelude.Semigroup v) => Divisible (SemiValuationAlgebra v set) where
  conquer = SemiValuationAlgebra (review applySemigroup (<>)) 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, Prelude.Semigroup v) => Decidable (SemiValuationAlgebra v set) where
  lose f = SemiValuationAlgebra (review applySemigroup (<>)) (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) => Divise (SemiValuationAlgebra 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) => Decide (SemiValuationAlgebra 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, Prelude.Semigroup v) => Conclude (SemiValuationAlgebra v set) where
  conclude f = SemiValuationAlgebra (review applySemigroup (<>)) (conclude f)

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