% 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.
>
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:
>
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:
>
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:
>
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:
>
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:
>
Some {\tt MonoidPlus} instances are semirings. There are no additional
class methods for semirings.
> class MonoidPlus t => Semiring t;
Instances should follow these laws:
>
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={{
> }