valuations-0.0.1: src/Data/Valuation/ValuationAlgebraOp.hs

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

-- | An operation on a valuation algebra, a function from a set of variables to a value.
module Data.Valuation.ValuationAlgebraOp
  ( ValuationAlgebraOp (..),

    -- * optics
    HasValuationAlgebraOp (..),
    AsValuationAlgebraOp (..),

    -- * combinators
    semigroupValuationAlgebraOp,
    valuationAlgebraOpProjectValuation,
    applyHasValuationAlgebraOp,
    applyAsValuationAlgebraOp,
  )
where

import Control.Arrow (Arrow (..), ArrowApply (..), ArrowChoice (..), ArrowLoop (..))
import Control.Category (Category (..))
import Control.Comonad (Comonad (..), ComonadApply (..))
import Control.Lens
  ( Iso,
    Lens',
    Prism',
    Rewrapped,
    Wrapped (..),
    iso,
    review,
    _Wrapped,
  )
import Control.Monad.Fix (MonadFix (..))
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.Zip (MonadZip (..))
import Control.Selective (Selective (..), selectM)
import Data.Distributive (Distributive (..))
import Data.Either (fromLeft, fromRight)
import Data.Function (fix)
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind (Bind (..))
import Data.Functor.Extend (Extend (..))
import Data.Functor.Rep (Representable (..))
import Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
import Data.Profunctor.Closed (Closed (..))
import Data.Profunctor.Sieve (Cosieve (..))
import Data.Semigroupoid (Semigroupoid (..))
import Data.Valuation.ProjectValuation (ProjectValuation (..))
import Data.Valuation.Semigroup
  ( Semigroup,
    applySemigroup,
    runSemigroup,
  )
import Prelude hiding (Semigroup, id, (.))
import qualified Prelude

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults

-- | A function from a set of variables to a value. Isomorphic to @set var -> v@.
newtype ValuationAlgebraOp set var v
  = ValuationAlgebraOp (set var -> v)

instance (ValuationAlgebraOp set var v ~ t) => Rewrapped (ValuationAlgebraOp set' var' v') t

instance Wrapped (ValuationAlgebraOp set var v) where
  type Unwrapped (ValuationAlgebraOp set var v) = set var -> v
  _Wrapped' =
    iso (\(ValuationAlgebraOp x) -> x) ValuationAlgebraOp

-- | Classy lens for types that contain a 'ValuationAlgebraOp'.
class HasValuationAlgebraOp c set var v | c -> set var v where
  valuationAlgebraOp ::
    Lens' c (ValuationAlgebraOp set var v)

instance HasValuationAlgebraOp (ValuationAlgebraOp set var v) set var v where
  valuationAlgebraOp = id

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

instance AsValuationAlgebraOp (ValuationAlgebraOp set var v) set var v where
  _ValuationAlgebraOp = id

-- | Iso between a 'ValuationAlgebraOp' producing an endomorphism and a 'ProjectValuation'.
valuationAlgebraOpProjectValuation :: Iso (ValuationAlgebraOp set var (v -> v)) (ValuationAlgebraOp set' var' (v' -> v')) (ProjectValuation v set var) (ProjectValuation v' set' var')
valuationAlgebraOpProjectValuation =
  iso
    (\(ValuationAlgebraOp k) -> ProjectValuation k)
    (\(ProjectValuation k) -> ValuationAlgebraOp k)

-- | Lens to the underlying function of a 'HasValuationAlgebraOp'.
applyHasValuationAlgebraOp :: (HasValuationAlgebraOp op set var v) => Lens' op (set var -> v)
applyHasValuationAlgebraOp = valuationAlgebraOp . _Wrapped

-- | Prism to the underlying function of an 'AsValuationAlgebraOp'.
applyAsValuationAlgebraOp :: (AsValuationAlgebraOp op set var v) => Prism' op (set var -> v)
applyAsValuationAlgebraOp = _ValuationAlgebraOp . _Wrapped

-- |
-- >>> let ValuationAlgebraOp f = fmap (*2) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)
-- >>> f [1,2,3]
-- 12
instance Functor (ValuationAlgebraOp set a) where
  fmap f (ValuationAlgebraOp g) = ValuationAlgebraOp (f . g)

-- |
-- >>> import Data.Functor.Apply ((<.>))
-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp (\s -> (+ sum s)) :: ValuationAlgebraOp [] Int (Int -> Int)) <.> ValuationAlgebraOp product
-- >>> f [1,2,3]
-- 12
instance Apply (ValuationAlgebraOp set a) where
  ValuationAlgebraOp f <.> ValuationAlgebraOp g = ValuationAlgebraOp (\sa -> f sa (g sa))

-- |
-- >>> let ValuationAlgebraOp f = pure 42 :: ValuationAlgebraOp [] Int Int
-- >>> f [1,2,3]
-- 42
--
-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp (\s -> (+ sum s)) :: ValuationAlgebraOp [] Int (Int -> Int)) <*> ValuationAlgebraOp product
-- >>> f [1,2,3]
-- 12
instance Applicative (ValuationAlgebraOp set a) where
  pure b = ValuationAlgebraOp (const b)
  (<*>) = (<.>)

-- |
-- >>> import Data.Functor.Bind ((>>-))
-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int) >>- (\n -> ValuationAlgebraOp (\s -> n + product s))
-- >>> f [1,2,3]
-- 12
instance Bind (ValuationAlgebraOp set a) where
  ValuationAlgebraOp f >>- k = ValuationAlgebraOp (\sa -> let ValuationAlgebraOp g = k (f sa) in g sa)

-- |
-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int) >>= (\n -> ValuationAlgebraOp (\s -> n * length s))
-- >>> f [1,2,3]
-- 18
--
-- >>> let ValuationAlgebraOp f = return 42 :: ValuationAlgebraOp [] Int Int
-- >>> f [1,2,3]
-- 42
instance Monad (ValuationAlgebraOp set a) where
  (>>=) = (>>-)

-- |
-- >>> import Data.Semigroupoid (o)
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = o (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int) (ValuationAlgebraOp sum)
-- >>> f (1 :| [2, 3])
-- 14
instance (Extend set) => Semigroupoid (ValuationAlgebraOp set) where
  o (ValuationAlgebraOp g) (ValuationAlgebraOp f) = ValuationAlgebraOp (g . extended f)

-- |
-- >>> import Control.Category (id, (.))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = id :: ValuationAlgebraOp NonEmpty Int Int
-- >>> f (1 :| [2, 3])
-- 1
--
-- >>> import Control.Category ((.))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int) . ValuationAlgebraOp sum
-- >>> f (1 :| [2, 3])
-- 14
instance (Comonad set) => Category (ValuationAlgebraOp set) where
  id = ValuationAlgebraOp extract
  ValuationAlgebraOp g . ValuationAlgebraOp f = ValuationAlgebraOp (g . extend f)

-- |
-- >>> import Control.Arrow (arr, first)
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = arr (*2) :: ValuationAlgebraOp NonEmpty Int Int
-- >>> f (3 :| [4, 5])
-- 6
--
-- >>> import Control.Arrow (first)
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = first (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)
-- >>> f ((1, "a") :| [(2, "b"), (3, "c")])
-- (6,"a")
instance (Comonad set) => Arrow (ValuationAlgebraOp set) where
  arr f = ValuationAlgebraOp (f . extract)
  first = first'

-- |
-- >>> import Control.Arrow (left)
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = left (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)
-- >>> f (Left 1 :| [Left 2, Left 3])
-- Left 6
-- >>> f (Right "hi" :| [Left 2])
-- Right "hi"
instance (Comonad set) => ArrowChoice (ValuationAlgebraOp set) where
  left = left'

-- |
-- >>> import Control.Arrow (app)
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = app :: ValuationAlgebraOp NonEmpty (ValuationAlgebraOp NonEmpty Int Int, Int) Int
-- >>> f ((ValuationAlgebraOp sum, 99) :| [(ValuationAlgebraOp product, 1)])
-- 100
instance (Comonad set) => ArrowApply (ValuationAlgebraOp set) where
  app = ValuationAlgebraOp $ \wpair ->
    let (ValuationAlgebraOp f, _) = extract wpair
     in f (fmap snd wpair)

-- |
-- >>> import Control.Arrow (loop)
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> let ValuationAlgebraOp f = loop (ValuationAlgebraOp (\(Identity (b, _)) -> (b * 2, 0))) :: ValuationAlgebraOp Identity Int Int
-- >>> f (Identity 3)
-- 6
instance (ComonadApply set) => ArrowLoop (ValuationAlgebraOp set) where
  loop (ValuationAlgebraOp f) = ValuationAlgebraOp $ \wa ->
    fst . extract $ fix $ \wbd -> extend f ((,) <$> wa <@> fmap snd wbd)

-- |
-- >>> import Control.Monad.Fix (mfix)
-- >>> let ValuationAlgebraOp f = mfix (\x -> ValuationAlgebraOp (\s -> const 42 x + sum s)) :: ValuationAlgebraOp [] Int Int
-- >>> f [1,2,3]
-- 48
instance MonadFix (ValuationAlgebraOp set var) where
  mfix f = ValuationAlgebraOp (\s -> fix (\a -> let ValuationAlgebraOp g = f a in g s))

-- |
-- >>> import Control.Monad.Zip (mzipWith)
-- >>> let ValuationAlgebraOp f = mzipWith (+) (ValuationAlgebraOp sum) (ValuationAlgebraOp product :: ValuationAlgebraOp [] Int Int)
-- >>> f [1,2,3]
-- 12
instance MonadZip (ValuationAlgebraOp set var) where
  mzipWith f (ValuationAlgebraOp g) (ValuationAlgebraOp h) = ValuationAlgebraOp (\s -> f (g s) (h s))

-- |
-- >>> import Control.Selective (select)
-- >>> let ValuationAlgebraOp f = select (ValuationAlgebraOp (\s -> Left (sum s)) :: ValuationAlgebraOp [] Int (Either Int Int)) (ValuationAlgebraOp (\_ -> (+10)))
-- >>> f [1,2,3]
-- 16
instance Selective (ValuationAlgebraOp set var) where
  select = selectM

-- |
-- >>> import Control.Monad.Reader.Class (ask, local)
-- >>> let ValuationAlgebraOp f = ask :: ValuationAlgebraOp [] Int [Int]
-- >>> f [1,2,3]
-- [1,2,3]
--
-- >>> import Control.Monad.Reader.Class (ask, local)
-- >>> let ValuationAlgebraOp f = local (map (*2)) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)
-- >>> f [1,2,3]
-- 12
instance MonadReader (set var) (ValuationAlgebraOp set var) where
  ask = ValuationAlgebraOp id
  local f (ValuationAlgebraOp g) = ValuationAlgebraOp (g . f)

-- |
-- >>> import Data.Profunctor (dimap, lmap, rmap)
-- >>> let ValuationAlgebraOp f = dimap (+1) (*2) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)
-- >>> f [1,2,3]
-- 18
--
-- >>> import Data.Profunctor (lmap)
-- >>> let ValuationAlgebraOp f = lmap (*10) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)
-- >>> f [1,2,3]
-- 60
--
-- >>> import Data.Profunctor (rmap)
-- >>> let ValuationAlgebraOp f = rmap show (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)
-- >>> f [1,2,3]
-- "6"
instance (Functor set) => Profunctor (ValuationAlgebraOp set) where
  dimap f g (ValuationAlgebraOp h) = ValuationAlgebraOp (g . h . fmap f)
  lmap f (ValuationAlgebraOp h) = ValuationAlgebraOp (h . fmap f)
  rmap g (ValuationAlgebraOp h) = ValuationAlgebraOp (g . h)

-- |
-- >>> import Data.Profunctor (Strong(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = first' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)
-- >>> f ((1, "a") :| [(2, "b"), (3, "c")])
-- (6,"a")
--
-- >>> import Data.Profunctor (Strong(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = second' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)
-- >>> f (("a", 1) :| [("b", 2), ("c", 3)])
-- ("a",6)
instance (Comonad set) => Strong (ValuationAlgebraOp set) where
  first' (ValuationAlgebraOp f) = ValuationAlgebraOp (\sac -> (f (fmap fst sac), snd (extract sac)))
  second' (ValuationAlgebraOp f) = ValuationAlgebraOp (\sca -> (fst (extract sca), f (fmap snd sca)))

-- |
-- >>> import Data.Profunctor (Choice(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = left' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)
-- >>> f (Left 1 :| [Left 2, Left 3])
-- Left 6
-- >>> f (Right "hi" :| [Left 2])
-- Right "hi"
--
-- >>> import Data.Profunctor (Choice(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> let ValuationAlgebraOp f = right' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)
-- >>> f (Right 1 :| [Right 2, Right 3])
-- Right 6
-- >>> f (Left "hi" :| [Right 2])
-- Left "hi"
instance (Comonad set) => Choice (ValuationAlgebraOp set) where
  left' (ValuationAlgebraOp f) = ValuationAlgebraOp $ \seac ->
    case extract seac of
      Left a -> Left (f (fmap (fromLeft a) seac))
      Right c -> Right c
  right' (ValuationAlgebraOp f) = ValuationAlgebraOp $ \seca ->
    case extract seca of
      Right a -> Right (f (fmap (fromRight a) seca))
      Left c -> Left c

-- |
-- >>> import Data.Profunctor.Closed (Closed(..))
-- >>> let ValuationAlgebraOp f = closed (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)
-- >>> f [(*2), (*3)] 10
-- 50
instance (Functor set) => Closed (ValuationAlgebraOp set) where
  closed (ValuationAlgebraOp f) = ValuationAlgebraOp (\sxa x -> f (fmap ($ x) sxa))

-- |
-- >>> import Data.Profunctor.Sieve (Cosieve(..))
-- >>> cosieve (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int) [1,2,3]
-- 6
instance (Functor set) => Cosieve (ValuationAlgebraOp set) set where
  cosieve (ValuationAlgebraOp f) = f

-- |
-- >>> import Data.Distributive (distribute)
-- >>> let ValuationAlgebraOp f = distribute [ValuationAlgebraOp sum, ValuationAlgebraOp product] :: ValuationAlgebraOp [] Int [Int]
-- >>> f [1,2,3]
-- [6,6]
instance Distributive (ValuationAlgebraOp set var) where
  distribute fs = ValuationAlgebraOp (\s -> fmap (\(ValuationAlgebraOp g) -> g s) fs)

-- |
-- >>> import Data.Functor.Rep (tabulate, index)
-- >>> let vao = tabulate (\s -> sum s * 2) :: ValuationAlgebraOp [] Int Int
-- >>> index vao [1,2,3]
-- 12
instance Representable (ValuationAlgebraOp set var) where
  type Rep (ValuationAlgebraOp set var) = set var
  tabulate = ValuationAlgebraOp
  index (ValuationAlgebraOp f) = f

-- |
-- >>> let ValuationAlgebraOp f = runSemigroup semigroupValuationAlgebraOp (ValuationAlgebraOp (const "hello")) (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp [] Int String) in f []
-- "hello world"
semigroupValuationAlgebraOp :: (Prelude.Semigroup v) => Semigroup (ValuationAlgebraOp set var v)
semigroupValuationAlgebraOp = review applySemigroup (\(ValuationAlgebraOp f) (ValuationAlgebraOp g) -> ValuationAlgebraOp (\s -> f s <> g s))

-- |
-- >>> let ValuationAlgebraOp f = ValuationAlgebraOp (const "hello") <> (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp [] Int String) in f []
-- "hello world"
instance (Prelude.Semigroup v) => Prelude.Semigroup (ValuationAlgebraOp set var v) where
  (<>) = runSemigroup semigroupValuationAlgebraOp

-- |
-- >>> let ValuationAlgebraOp f = mempty :: ValuationAlgebraOp [] Int String in f [1,2,3]
-- ""
instance (Prelude.Monoid v) => Prelude.Monoid (ValuationAlgebraOp set var v) where
  mempty = ValuationAlgebraOp (const mempty)