% MonoidPlus and other classes
% [Public domain]
% version 0.1

\input birdstyle

\birdleftrule=1pt
\emergencystretch=1em

\def\hugebreak{\penalty-600\vskip 30pt plus 8pt minus 4pt\relax}
\newcount\chapno
\def\: #1.{\advance\chapno by 1\relax\hugebreak{\bf\S\the\chapno. #1. }}

\: Introduction. This is program for related things about monoids. It also
has a type for bounded numbers.

> {-# LANGUAGE FlexibleInstances #-}

Exports:

> module Data.Monoid.Plus (
>   module Data.Semigroup, MonoidPlus(..), Group(..), MonoidMinus(..),
>   MonoidNorm(..), MonoidPlusNorm(..), Semiring, Ring, (|*|), (|/|),
>   (|+|), (|-|), BoundFrac, fromBoundFrac, toBoundFrac,
>   WrapMonoidPlus(..), CatEndo(..), Possibilistic(..), Lukasiewicz(..),
>   monoidicMap, mpure, Prob, pChoose, pChoice, probNorm, uniform, probOf
> ) where {

Imports:

> import Control.Applicative;
> import Control.Category hiding (id, (.));
> import qualified Control.Category as C;
> import Control.Monad;
> import Control.Monad.Trans.Writer;
> import Data.Functor.Contravariant;
> import Data.List;
> import Data.Monoid;
> import Data.Ord;
> import Data.Semigroup hiding (First, Last, getFirst, getLast);

\: Classes. Other than {\tt Monoid} and {\tt MonoidPlus}, here are some
other related classes.

This class is for monoids that have another monoid operation on them
following specific laws.

> class Monoid t => MonoidPlus t where {
>   mpempty :: t;
>   mpappend :: t -> t -> t;
>   mpconcat :: [t] -> t;
>   mpconcat = foldr mpappend mpempty;
> };

Instances should follow these laws:

> {-
>   mpappend mpempty x = x;
>   mpappend x mpempty = x;
>   mpappend x (mpappend y z) = mpappend (mpappend x y) z;
>   mpconcat = foldr mpappend mpempty;
>   mappend x (mpappend y z) = mpappend (mappend x y) (mappend x z);
>   mappend (mpappend y z) x = mpappend (mappend y x) (mappend z x);
> -}

That is, it is a monoid that the original monoid is distributive over.

This class is for groups. All groups are monoids, and each elements can
be inversed.

> class Monoid t => Group t where {
>   minverse :: t -> t;
> };

Instances should follow these laws:

> {-
>   mappend x (minverse x) = mempty;
>   mappend (minverse x) x = mempty;
> -}

The {\tt MonoidPlus} instances can also form a group, which here is called
{\tt MonoidMinus}.

> class MonoidPlus t => MonoidMinus t where {
>   mpinverse :: t -> t;
> };

Instances should follow these laws:

> {-
>   mpappend x (mpinverse x) = mpempty;
>   mpappend (mpinverse x) x = mpempty;
> -}

This class is for normalizable monoids; for example, a list of numbers
normalized so that they add up to 1, such as with probabilities.

> class Monoid t => MonoidNorm t where {
>   mnormfunc :: [t] -> t -> t;
>   mnormalize :: [t] -> [t];
>   mnormalize x = mnormfunc x <$> x;
> };

Instances should follow these laws:

> {-
>   mnormalize x = mnormfunc x <$> x;
>   mnormalize (mnormalize x) = mnormalize x;
>   mconcat (mnormalize x) = mempty;
>   shuffle (mnormalize x) = mnormalize (shuffle x);
> -}

for any possible bijective function {\tt shuffle :: [a] -> [a]}.

Sometimes you want normalization over its distributive monoid.

> class MonoidPlus t => MonoidPlusNorm t where {
>   mpnormfunc :: [t] -> t -> t;
>   mpnormalize :: [t] -> [t];
>   mpnormalize x = mpnormfunc x <$> x;
> };

Instances should follow these laws:

> {-
>   mpnormalize x = mpnormfunc x <$> x;
>   mpnormalize (mpnormalize x) = mpnormalize x;
>   mpconcat (mpnormalize (x:y)) = mempty;
>   shuffle (mpnormalize x) = mpnormalize (shuffle x);
> -}

Some {\tt MonoidPlus} instances are semirings. There are no additional
class methods for semirings.

> class MonoidPlus t => Semiring t;

Instances should follow these laws:

> {-
>   mappend mpempty x = mpempty;
>   mappend x mpempty = mpempty;
>   mpappend x y = mpappend y x;
> -}

Some semirings are rings.

> class (Semiring t, MonoidMinus t) => Ring t;

There are no additional laws; they follow from the laws of the classes
that are required to make this class.

\: Bounded Fractions. Due to the use of bounded fractional numbers in some
rings, here is a type for bounded fractions. The type is exported without
its constructor; you can use it as a number.

> newtype BoundFrac t = BoundFrac { fromBoundFrac :: t }
>  deriving (Eq, Ord);

> toBoundFrac :: (Num t, Ord t) => t -> BoundFrac t;
> toBoundFrac x = if x < 0 || x > 1 then error "Out of bounds"
>  else BoundFrac x;

> instance Show t => Show (BoundFrac t) where {
>   show (BoundFrac x) = show x;
> };

> instance (Enum t, Fractional t, Ord t) => Enum (BoundFrac t) where {
>   toEnum 0 = BoundFrac 0.0;
>   toEnum 1 = BoundFrac 1.0;
>   toEnum _ = error "Out of bounds";
>   fromEnum (BoundFrac 1.0) = 1;
>   fromEnum _ = 0;
> };

Because it is bounded, it can have a {\tt Bounded} instance too.

> instance (Enum t, Fractional t, Ord t)
>  => Bounded (BoundFrac t) where {
>   minBound = BoundFrac 0.0;
>   maxBound = BoundFrac 1.0;
> };

All numeric operations must check that it is in bounds.

> instance (Num t, Ord t) => Num (BoundFrac t) where {
>   (BoundFrac x) + (BoundFrac y) = if x + y < 0 || x + y > 1 then
>    error "Out of bounds" else BoundFrac (x + y);
>   (BoundFrac x) - (BoundFrac y) = if x - y < 0 || x - y > 1 then
>    error "Out of bounds" else BoundFrac (x - y);
>   (BoundFrac x) * (BoundFrac y) = if x * y < 0 || x * y > 1 then
>    error "Out of bounds" else BoundFrac (x * y);
>   negate (BoundFrac 0) = BoundFrac 0;
>   negate _ = error "Out of bounds";
>   abs = id;
>   signum (BoundFrac 0) = BoundFrac 0;
>   signum _ = BoundFrac 1;
>   fromInteger 0 = BoundFrac 0;
>   fromInteger 1 = BoundFrac 1;
>   fromInteger _ = error "Out of bounds";
> };

> instance (Fractional t, Ord t) => Fractional (BoundFrac t) where {
>   (BoundFrac x) / (BoundFrac y) = if x / y < 0 || x / y > 1 then
>    error "Out of bounds" else BoundFrac (x / y);
>   fromRational x = if x < 0 || x > 1 then error "Out of bounds"
>    else BoundFrac (fromRational x);
> };

> instance Real t => Real (BoundFrac t) where {
>   toRational (BoundFrac x) = toRational x;
> };

> instance (Real t, Fractional t) => RealFrac (BoundFrac t) where {
>   properFraction 1 = (1, 0);
>   properFraction x = (0, x);
> };

\: New Monoid Types. Any {\tt MonoidPlus} forms its own monoid; there can
be a wrapper type to make it able to do so.

> newtype WrapMonoidPlus t = WrapMonoidPlus t deriving (Eq, Ord, Show);

> instance MonoidPlus t => Monoid (WrapMonoidPlus t) where {
>   mempty = WrapMonoidPlus mpempty;
>   mappend (WrapMonoidPlus x) (WrapMonoidPlus y) = WrapMonoidPlus
>    (mpappend x y);
> };

Endomorphisms of a category form a monoid (including the Kleisli category
of a monad).

> newtype CatEndo c t = CatEndo { runCatEndo :: c t t };

> instance Category c => Monoid (CatEndo c t) where {
>   mempty = CatEndo C.id;
>   mappend (CatEndo x) (CatEndo y) = CatEndo $ x C.. y;
> };

One semiring of bounded numbers is possibilistic semiring.

> newtype Possibilistic t = Possibilistic { getPossibilistic ::
>  BoundFrac t } deriving (Eq, Ord, Show);

> instance (Num t, Ord t) => Monoid (Possibilistic t) where {
>   mempty = Possibilistic 1;
>   mappend (Possibilistic x) (Possibilistic y) = Possibilistic (x * y);
> };

> instance (Num t, Ord t) => MonoidPlus (Possibilistic t) where {
>   mpempty = Possibilistic 0;
>   mpappend (Possibilistic x) (Possibilistic y) = Possibilistic $
>    max x y;
> };

> instance (Num t, Ord t) => Semiring (Possibilistic t);

It is also a normalizable semiring; everything is multiplied so that the
max value will be 1.

> instance (Fractional t, Ord t) => MonoidPlusNorm (Possibilistic t)
>  where {
>   mpnormfunc a (Possibilistic v) = if all (== Possibilistic 0) a then
>    Possibilistic 1 else (Possibilistic . toBoundFrac $ recip
>    (fromBoundFrac . getPossibilistic . last $ sort a) *
>    fromBoundFrac v);
> };

Another semiring of bounded numbers is Lukasiewicz semiring.

> newtype Lukasiewicz t = Lukasiewicz { getLukasiewicz :: BoundFrac t }
>  deriving (Eq, Ord, Show);

> instance (Num t, Ord t) => Monoid (Lukasiewicz t) where {
>   mempty = Lukasiewicz 1;
>   mappend (Lukasiewicz x) (Lukasiewicz y) = Lukasiewicz . toBoundFrac $
>    max (fromBoundFrac x + fromBoundFrac y - 1) 0;
> };

> instance (Num t, Ord t) => MonoidPlus (Lukasiewicz t) where {
>   mpempty = Lukasiewicz 1;
>   mpappend (Lukasiewicz x) (Lukasiewicz y) = Lukasiewicz $ min x y;
> };

\: Instances. The unit type easily forms a group, and is distributive
since it has only one possible value. It is also the trivial ring.

> instance MonoidPlus () where {
>   mpempty = ();
>   mpappend = const $ const ();
>   mpconcat = const ();
> };

> instance Group () where {
>   minverse = id;
> };

> instance MonoidMinus () where {
>   mpinverse = id;
> };

> instance MonoidNorm () where {
>   mnormfunc = flip const;
>   mnormalize = id;
> };

> instance MonoidPlusNorm () where {
>   mpnormfunc = flip const;
>   mpnormalize = id;
> };

> instance Semiring ();

> instance Ring ();

The distribution over addition is multiplication.

> instance Num t => MonoidPlus (Product t) where {
>   mpempty = Product 0;
>   mpappend (Product x) (Product y) = Product $ x + y;
> };

The distribution over logical conjunction is disjunction, and vice versa.

> instance MonoidPlus All where {
>   mpempty = All False;
>   mpappend (All x) (All y) = All (x || y);
> };

> instance MonoidPlus Any where {
>   mpempty = Any True;
>   mpappend (Any x) (Any y) = Any (x && y);
> };

It is also a semiring; the semiring laws are followed.

> instance Semiring All;

> instance Semiring Any;

Subtraction is the inverse of addition.

> instance Num t => Group (Sum t) where {
>   minverse = Sum . negate . getSum;
> };

The minimum and maximum operations distribute over each other.

> instance (Ord t, Bounded t) => MonoidPlus (Min t) where {
>   mpempty = minBound;
>   mpappend (Min x) (Min y) = Min $ max x y;
> };

> instance (Ord t, Bounded t) => MonoidPlus (Max t) where {
>   mpempty = maxBound;
>   mpappend (Max x) (Max y) = Max $ min x y;
> };

Fractional numbers can be normalized in addition and multiplication.

> instance Fractional t => MonoidNorm (Sum t) where {
>   mnormfunc a v = Sum $ getSum v - sum (getSum <$> a)
>    / fromIntegral (length a);
> };

> instance Fractional t => MonoidPlusNorm (Product t) where {
>   mpnormfunc a v = Product $ if sum (getProduct <$> a) == 0
>    then 1 / fromIntegral (length a)
>    else getProduct v / sum (getProduct <$> a);
> };

Most kinds of numbers form a ring.

> instance Num t => MonoidMinus (Product t) where {
>   mpinverse = Product . negate . getProduct;
> };

> instance Num t => Semiring (Product t);

> instance Num t => Ring (Product t);

There is a ring of sets. This kind of implementation is the same thing as
a predicate, which is also a contravariant functor.

> instance Monoid (Predicate t) where {
>   mempty = Predicate $ const True;
>   mappend (Predicate x) (Predicate y) = Predicate $ \z -> x z && y z;
> };

> instance MonoidPlus (Predicate t) where {
>   mpempty = Predicate $ const False;
>   mpappend (Predicate x) (Predicate y) = Predicate $ \z -> x z /= y z;
> };

> instance MonoidMinus (Predicate t) where {
>   mpinverse = id;
> };

> instance Semiring (Predicate t);

> instance Ring (Predicate t);

Equivalences (also a contravariant functor) can form an Abelian group.

> instance Eq t => Monoid (Equivalence t) where {
>   mempty = Equivalence (==);
>   mappend (Equivalence f) (Equivalence g) = Equivalence $ \x y ->
>    (x == y) /= (f x y /= g x y);
> };

> instance Eq t => Group (Equivalence t) where {
>   minverse = id;
> };

If you have multiple groups, their direct product is a group.

> instance (Group a, Group b) => Group (a, b) where {
>   minverse (a, b) = (minverse a, minverse b);
> };

> instance (Group a, Group b, Group c) => Group (a, b, c) where {
>   minverse (a, b, c) = (minverse a, minverse b, minverse c);
> };

\: Operators. These are infix operator forms of the other functions.

> (|*|) :: Monoid t => t -> t -> t;
> (|*|) = mappend;
> infixr 5 |*|;

> (|/|) :: Group t => t -> t -> t;
> x |/| y = mappend x (minverse y);
> infixr 5 |/|;

> (|+|) :: MonoidPlus t => t -> t -> t;
> (|+|) = mpappend;
> infixr 4 |+|;

> (|-|) :: MonoidMinus t => t -> t -> t;
> x |-| y = mpappend x (mpinverse y);
> infixr 4 |-|;

\: Monoidic Monads. Although there is applicative for pairs having a
monoid type, it is not a monad instance. A monad instance can be made.

> instance Monoid t => Monad ((,) t) where {
>   return = pure;
>   x >>= f = join $ fmap f x where {
>     join :: Monoid t => (t, (t, u)) -> (t, u);
>     join (x, (y, z)) = (x |*| y, z);
>   };
> };

It can make a monad transformer, too. In fact this monad transformer is
{\tt WriterT}. Here are some extra functions for its use.

> monoidicMap :: Functor m => (x -> y) -> WriterT x m a -> WriterT y m a;
> monoidicMap = mapWriterT . fmap . fmap;

> mpure :: Applicative f => w -> t -> WriterT w f t;
> mpure x y = WriterT $ pure (y, x);

It can be used for probability distributions too, as long as the
probabilities are any normalizable ring. (Note: All possible outputs on
the right side of a bind (or all lists in a join) must have probabilities
adding up to the same total!)

> type Prob a b = WriterT a [] b;

> pChoose :: Ring p => p -> t -> t -> Prob p t;
> pChoose p x y = WriterT [(x, p), (y, mempty |-| p)];

> pChoice :: Ring p => p -> Prob p t -> Prob p t -> Prob p t;
> pChoice p x y = join $ pChoose p x y;

This function will normalize the results so that the underlying list will
be equal to any one representing the same probability distribution. It
requires sorting, equality testing, etc.

> probNorm :: (Semiring p, MonoidPlusNorm p, Eq p, Ord t) => Prob p t
>  -> Prob p t;
> probNorm = WriterT . uncurry zip . (\(l, r) -> (l, mpnormalize r))
>  . unzip . filter ((/=) mpempty . snd) . map (\x -> (fst $ head x,
>  mpconcat $ snd <$> x)) . groupBy (\x y -> fst x == fst y) . sortBy
>  (comparing fst) . runWriterT;

> uniform :: (Semiring p, MonoidPlusNorm p) => [t] -> Prob p t;
> uniform x = WriterT $ (flip (,) $ mpnormfunc (mempty <$ x) mempty)
>  <$> x;

> probOf :: (Semiring p, MonoidPlusNorm p, Eq p)
>  => (t -> Bool) -> Prob p t -> p;
> probOf f x = case (runWriterT $ probNorm (f <$> x)) of {
>   [_, (True, p)] -> p;
>   [(True, p)] -> p;
>   _ -> mpempty;
> };

%  [Monty Hall example]
%> data Door = A | B | C deriving (Eq, Ord, Show);
%> doors :: [Door];
%> doors = [A, B, C];
%> hide :: Prob (Product Double) Door;
%> hide = uniform doors;
%> pick :: Prob (Product Double) Door;
%> pick = uniform doors;
%> tease :: Door -> Door -> Prob (Product Double) Door;
%> tease h p = uniform (doors \\ [h, p]);
%> switch :: Door -> Door -> Prob (Product Double) Door;
%> switch p t = return $ head (doors \\ [p, t]);
%> stick :: Door -> Door -> Prob (Product Double) Door;
%> stick p t = return p;
%> play :: (Door -> Door -> Prob (Product Double) Door)
%>  -> Prob (Product Double) Bool;
%> play strategy = probNorm $ do {
%>   h <- hide;
%>   p <- pick;
%>   t <- tease h p;
%>   s <- strategy p t;
%>   return (s == h);
%> };

% End of document (final "}" is suppressed from printout)
\toks0={{

> } -- }\bye