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

{-# LANGUAGE FlexibleContexts #-}
{-# 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 (..),
    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 (..))
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,
  )
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 p set var v
  = ValuationAlgebraOp (p (set var) v)

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

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

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

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

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

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

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

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

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

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

-- |
-- >>> let ValuationAlgebraOp f = fmap (*2) (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int)
-- >>> f [1,2,3]
-- 12
instance (Profunctor p) => Functor (ValuationAlgebraOp p set a) where
  fmap f (ValuationAlgebraOp g) = ValuationAlgebraOp (rmap 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 (Strong p, Semigroupoid p) => Apply (ValuationAlgebraOp p set a) where
  ValuationAlgebraOp f <.> ValuationAlgebraOp g = ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry ($)) (second' g `o` first' f)))

-- |
-- >>> 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 (Strong p, Semigroupoid p, Category p) => Applicative (ValuationAlgebraOp p set a) where
  pure b = ValuationAlgebraOp (rmap (const b) id)
  (<*>) = (<.>)

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

-- |
-- >>> 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 (Closed p, Strong p, Semigroupoid p, Extend set) => Semigroupoid (ValuationAlgebraOp p set) where
  o (ValuationAlgebraOp g) (ValuationAlgebraOp f) =
    let step = rmap extended (lmap (const id) (closed f))
        ext = lmap (\x -> (x, x)) (rmap (\(h, x) -> h x) (first' step))
     in ValuationAlgebraOp (g `o` ext)

-- |
-- >>> 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 (Closed p, Strong p, Category p, Comonad set) => Category (ValuationAlgebraOp p set) where
  id = ValuationAlgebraOp (rmap extract id)
  ValuationAlgebraOp g . ValuationAlgebraOp f =
    let step = rmap extend (lmap (const id) (closed f))
        ext = lmap (\x -> (x, x)) (rmap (\(h, x) -> h x) (first' step))
     in ValuationAlgebraOp (g . ext)

-- |
-- >>> 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 (Closed p, Strong p, Category p, Comonad set) => Arrow (ValuationAlgebraOp p set) where
  arr f = ValuationAlgebraOp (rmap (f . extract) id)
  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 (Closed p, Strong p, Choice p, Category p, Comonad set) => ArrowChoice (ValuationAlgebraOp p 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 (Strong p, Semigroupoid p, Category p) => Selective (ValuationAlgebraOp p set var) where
  select (ValuationAlgebraOp feab) (ValuationAlgebraOp fab) =
    ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (\(eab, f) -> either f Prelude.id eab) (second' fab . first' feab)))

-- |
-- >>> 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 Prelude.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 p) => Profunctor (ValuationAlgebraOp p set) where
  dimap f g (ValuationAlgebraOp h) = ValuationAlgebraOp (dimap (fmap f) g h)
  lmap f (ValuationAlgebraOp h) = ValuationAlgebraOp (lmap (fmap f) h)
  rmap g (ValuationAlgebraOp h) = ValuationAlgebraOp (rmap 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 p) => Strong (ValuationAlgebraOp p set) where
  first' (ValuationAlgebraOp f) = ValuationAlgebraOp (lmap (\s -> (fmap fst s, snd (extract s))) (first' f))
  second' (ValuationAlgebraOp f) = ValuationAlgebraOp (lmap (\s -> (fst (extract s), fmap snd s)) (second' f))

-- |
-- >>> 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 p) => Choice (ValuationAlgebraOp p set) where
  left' (ValuationAlgebraOp f) =
    ValuationAlgebraOp $
      lmap
        ( \s -> case extract s of
            Left a -> Left (fmap (fromLeft a) s)
            Right c -> Right c
        )
        (left' f)
  right' (ValuationAlgebraOp f) =
    ValuationAlgebraOp $
      lmap
        ( \s -> case extract s of
            Right a -> Right (fmap (fromRight a) s)
            Left c -> Left c
        )
        (right' f)

-- |
-- >>> import Data.Profunctor.Closed (Closed(..))
-- >>> let ValuationAlgebraOp f = closed (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int)
-- >>> f [(*2), (*3)] 10
-- 50
instance (Functor set, Closed p) => Closed (ValuationAlgebraOp p set) where
  closed (ValuationAlgebraOp f) = ValuationAlgebraOp (lmap distribute (closed f))

-- |
-- >>> 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

-- |
-- >>> import Data.Valuation.Semigroup (runSemigroup)
-- >>> let ValuationAlgebraOp f = runSemigroup semigroupValuationAlgebraOp (ValuationAlgebraOp (const "hello")) (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp (->) [] Int String) in f []
-- "hello world"
semigroupValuationAlgebraOp :: (Arrow p, Prelude.Semigroup v) => Semigroup p (ValuationAlgebraOp p set var v)
semigroupValuationAlgebraOp =
  let combine f g = arr (uncurry (Prelude.<>)) . (f *** g) . arr (\x -> (x, x))
   in review applySemigroup (arr (\(ValuationAlgebraOp f) -> arr (\(ValuationAlgebraOp g) -> ValuationAlgebraOp (combine f g))))

-- |
-- >>> let ValuationAlgebraOp f = ValuationAlgebraOp (const "hello") <> (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp (->) [] Int String) in f []
-- "hello world"
instance (Strong p, Semigroupoid p, Prelude.Semigroup v) => Prelude.Semigroup (ValuationAlgebraOp p set var v) where
  ValuationAlgebraOp f <> ValuationAlgebraOp g =
    ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (Prelude.<>)) (second' g `o` first' f)))

-- |
-- >>> 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 Prelude.mempty)