{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-- | __A 'Control.Monad.Free.Free' 'Num' is a 'Seq'uence of 'Bag's.__
--
-- One of the many things that sparks joy in Haskell is the density of expression that can be achieved. If it wasn't for a few quirks of the language, and if 'Ring' is substituted for 'Num', a free ring could be concretely defined as 'Control.Monad.Free.Free' ('Data.Functor.Compose.Compose' 'Bag' 'Seq') a.
--
-- As it stands, the library associates a free algebra with a forgetful functor representing what could be thought of as a robust set of polymorphic fusion rules. There are a lot of things that are number-like computations, and some of them need to go very fast and be very clean.
--
-- I had often heard about a free monoid and had always wondered what else, other than the iconic Haskell list, is a free thing. This library is a rough map of what has been a somewhat shambolic exploration of this notion. I hope you enjoy browsing the haddocks as much as I enjoyed crafting them. Before diving into the module proper,  there is a few landmarks worth noting:
--
-- - What, exactly, is a 'Num'?
--
-- - What is an algebra?
--
-- - The forgotten price that must be paid for an object to be free.
--
-- - The magic in category theory.
--
-- == What is a 'Num'?
--
-- /Can you truthfully say that you treasure something buried so deeply in a closet or drawer that you have forgotten its existence? If things had feelings, they would certainly not be happy. Free them from the prison to which you have relegated them. Help them leave that deserted isle to which you have exiled them./ ~ Marie Kondo
--
-- 'GHC.Num' is a dusty, old corner of our Haskell shelf-space. As is usually the case, the exact definition of what a 'Num' is is only ever a @λ> :i@ away.
--
-- >>> :i Num
-- type Num :: * -> Constraint
-- class Num a where
--   (GHC.Num.+) :: a -> a -> a
--   (GHC.Num.-) :: a -> a -> a
--   (GHC.Num.*) :: a -> a -> a
--   GHC.Num.negate :: a -> a
--   GHC.Num.abs :: a -> a
--   signum :: a -> a
--   GHC.Num.fromInteger :: Integer -> a
-- ...
--
-- So 'Num' is a Haskell class with an interface unchanged since it's specification in the [haskell98](https://www.haskell.org/onlinereport/standard-prelude.html) standard.
--
-- The other, obvious answer to the question is that a 'Num' is a number; it says so in the name, after all. But, by convention, a Haskell class is more than just the polymorphic type (the a) and the operators (the class interface). By convention, a Haskell class is also a set of laws that the class is expected to adhere to.
--
-- The commentary added since haskell98 mentions the mathematical concept of a ring but there are a few warts:
--
-- - 'zero' and 'one' are not included in the interface, but defined via 'fromInteger', a [special](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/rebindable_syntax.html) function baked into the Haskell language.
--
-- - abs and signum are not properties of a [ring](https://en.wikipedia.org/wiki/Ring_(mathematics\)), but of metric analytic branches of math.
--
-- The end result is that any notion of a free object applied to a 'Num' is difficult to imagine. If the interface is cleaned up, however, as in 'Ring' from the [numhask](https://hackage.haskell.org/package/numhask) library, with attention paid to each and every law, then resolution improves, and we are able to sharpen our tools.
--
-- A better definition of what our number systems are can lead to cleaner, faster coding patterns and design. In turn, this might eventually lead to ubiquitous usage of Haskell in numerical computing. As it stands right now, Haskell usage is restricted to only the most stubborn and dreamy of the numeric-analyst crew to which I claim membership of.
--
-- This article-module is, in part, a plea to release the Haskell numerical classes from their existing dusty drawers so we can begin to imagine some sort of future of numerical computation within the halls proper of Haskell. With apologies to Marie Kondo (and unsupported strikeout):
--
-- The __prelude__ (space) within which we __code__ (live) should be for the __language__ (person) we are becoming now, not for the __language__ (person) we were in the past.
--
-- and
--
-- Imagine what it would be like to have a __prelude__ (bookshelf) filled only with __functions__ (books) that you really love. Isn’t that image spellbinding? For someone who loves __functions__ (books), what greater happiness could there be?
--
-- == What is an algebra?
--
-- /Art is fire plus algebra./ ~ Jorge Luis Borges
--
-- or, less succinctly,
--
-- /An algebra is a collection of operations which combine values to produce other values. Algebra is a posh way of saying "construction kit". The type of values an algebra combines and produces is called the carrier of the algebra. The collection of operations and specification of their arities is called the signature of the algebra./ ~ [pigworker reddit comment](https://www.reddit.com/r/haskell/comments/36y9jc/haskell_as_an_mvc_framework/)
--
-- A free algebra then, is a set of instructions for creating a free object from some initial structure or expression. 'FreeAlgebra' can be thought of as a class for busting up a computation into two parts:
--
-- - 'forget': a function that transforms a structure into a Free Object representing an ideal given the (abstract) laws of the algebra being defined, and
--
-- - 'algebra': a (concrete) algebra from the Free Object to the carrier type (the type being produced).
--
-- == The price of a free object is forgetting.
--
-- /Maybe if I forgot things once in a while, we'd all be a little bit happier./ ~ Jay Asher, Thirteen Reasons Why
--
-- A free object is [neither](https://en.wikipedia.org/wiki/Gratis_versus_libre) "free as in beer" nor "free as in speech". It is free as in absent the algebraic laws that refer to how the object is constructed. At the heart of what is the free object, the @free@ part of the @FreeAlgebra initial free@ type, is a forgetting that throws away the structural details of the very laws the free object defines.
--
-- /A free object over a set forgets everything about that set except some universal properties, specified by the word following free. For example, the free monoid over Integers forgets unique factorization, unique representation in every base, the GCD function, and everything else about the Integers except: they are a set of objects, there is an associative (binary) operation on Integers, and there is a "neutral" Integer; precisely the universal properties of monoids./ ~ <https://www.schoolofhaskell.com/user/bss/magma-tree>
--
-- /... informally, a free object over a set A can be thought of as being a "generic" algebraic structure over A: the only equations that hold between elements of the free object are those that follow from the defining axioms of the algebraic structure./ ~ <https://en.wikipedia.org/wiki/Free_object>
--
-- /Adding a law to an algebra can be thought of as partitioning the carrier of the algebra into equivalence classes induced by that law, and regarding each class as one element./ ~ [The Boom Hierarchy](http://citeseerx.ist.psu.edu/viewdoc/download;jsessionid=601FB55680BBC2C1A14D136657E4A7ED?doi=10.1.1.49.3252&rep=rep1&type=pdf)
--
-- As is becoming well known, the easiest way to ensure that laws are never violated is by making their transgression non-representable. 'FreeAlgebra' represents a  technique for achieving this necessary step in constructing a free object from an initial representation.
--
-- == The magic in category theory
--
-- /Essentially everything that makes category theory nontrivial and interesting ... can be derived from the concept of adjoint functors./ ~ nLabs
--
-- What makes the above statement so interesting is when you combine it with their definition of adjunction (the noun to the "adjoint" adverb):
--
-- /adjunction : free functor ⊣ forgetful functor/ ~ [nLabs](https://ncatlab.org/nlab/show/free-forgetful+adjunction)
--
-- That's it! That's as far as they are prepared to discuss things, cascading definitions notwithstanding.
--
-- There's something very 17th century medicine about 21st century category theory. "An overabundance of the yellow humours can be fixed by an application of leeches" is how I hear much category theoretic prescription. We simply don't yet know enough about applied category theory for it to be distinguishable from magic.
--
-- Which leaves room for amateurs such as myself to do some hack-and-slash exploring. I can take a leap and see adjunctiveness (or is it adjointanality?) as yet another metaphor for this deep dual nature of programming. That is, for every way of considering a problem, you can "flip the switch" and think about it in an opposite, orthogonal, adjacent or flippin' arrow perspective or context.
--
-- With respect to a 'FreeAlgebra', the flipped switch is this:
--
-- __To arrive at a Free Object (where the only thing that is left are the laws under consideration), you need to forget the very laws encapsulated in the free structure and remember everything else.__
--
-- /this functor “forgets” the monoidal structure — once we are inside a plain set, we no longer distinguish the unit element or care about multiplication — it’s called a forgetful functor./ ~ https://bartoszmilewski.com/2015/07/21/free-monoids/
--
-- Future breakthroughs will not be found in quantum theory, mired in the 20th century slide-rules of physics.  They will not be gained by applying bio-logic-al constructs to computers with convoluted neural nets and tautological machine learnings. They will certainly never occur within a context of computer science as linguistic endeavour. The future can be seen now, however opaquely and paradoxical, and will be shaped by the binary oppositions and sheer post-modernist confusions of category theory.
--
module NumHask.FreeAlgebra
  ( -- * a free algebra class
    FreeAlgebra (..),

    -- * initial objects
    NoLaws,
    Tree (..),
    toTreeL,
    toTreeR,
    Exp (..),
    parseExp,
    freeExp,

    -- * single law free algebras
    MagmaOnly,
    UnitalOnly,
    TreeU (..),
    AssociativeOnly,
    TreeA (..),
    CommutativeOnly,
    InvertibleOnly,
    IdempotentOnly,
    AbsorbingOnly,

    -- * multi-law free algebras
    FreeMonoid (..),
    MultMonoid,
    Bag (..),
    mapBag,
    AddCommGroup,
    RingLaws,
    FreeRing (..),

    -- * example helpers
    Example (..),
    InformalTests,
    calate,
  )
where

import qualified Data.Attoparsec.Text as A
import qualified Data.Map as Map hiding (fromList)
import qualified Data.Sequence as Seq
import Data.Sequence ((<|), Seq (..), (|>))
import qualified Data.Text as Text
import GHC.Exts (IsList (..), coerce, toList)
import qualified GHC.Show
import NumHask.Algebra.Group ()
import NumHask.Prelude hiding (lift, reduce, toList)

-- $setup
--
-- >>> :set -XOverloadedStrings
-- >>> :set -XOverloadedLists
-- >>> :set -XNoImplicitPrelude
-- >>> import NumHask.Prelude hiding (toList, reduce, pure)

-- | A free algebra is a construction kit of operations and axioms that combine to produce values of a type.
class FreeAlgebra initial free a | free -> initial where
  -- | Convert from a structure (the initial type) to another structure, the free object, forgetting the algebraic laws encapsulated in the free object definition.
  forget :: initial a -> free a

  -- | Create a free object from a carrier type singleton.
  lift :: a -> free a

  -- | The algebra of the free object.
  --
  -- > lift . algebra == id
  algebra :: free a -> a

  -- | Pretty print the free object.
  printf :: free a -> Text

-- | Starting from a particular initial structure, different sets of laws may lead to the same actual structure (or free object). Informal phantom type are included in most structures to help distinguish these cases and supply differing instances.
data NoLaws

-- | A binary tree is a common initial structure when considering free algebras.
--
-- The initial object for a Magma algebra is typically a tree-like structure representing a computation or expression; a series of binary operations, such as:
--
-- > (1 ⊕ 4) ⊕ ((7 ⊕ 12) ⊕ 0)
--
-- >>> let m1 = Branch (Branch (Leaf (Example 1)) (Leaf (Example 4))) (Branch (Branch (Leaf (Example 7)) (Leaf (Example 12))) (Leaf (Example 0))) :: Tree MagmaOnly Example
-- >>> putStrLn $ printf m1
-- ((1⊕4)⊕((7⊕12)⊕0))
data Tree laws a
  = Leaf a
  | Branch (Tree laws a) (Tree laws a)
  deriving (Tree laws a -> Tree laws a -> Bool
(Tree laws a -> Tree laws a -> Bool)
-> (Tree laws a -> Tree laws a -> Bool) -> Eq (Tree laws a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall laws a. Eq a => Tree laws a -> Tree laws a -> Bool
/= :: Tree laws a -> Tree laws a -> Bool
$c/= :: forall laws a. Eq a => Tree laws a -> Tree laws a -> Bool
== :: Tree laws a -> Tree laws a -> Bool
$c== :: forall laws a. Eq a => Tree laws a -> Tree laws a -> Bool
Eq, Eq (Tree laws a)
Eq (Tree laws a)
-> (Tree laws a -> Tree laws a -> Ordering)
-> (Tree laws a -> Tree laws a -> Bool)
-> (Tree laws a -> Tree laws a -> Bool)
-> (Tree laws a -> Tree laws a -> Bool)
-> (Tree laws a -> Tree laws a -> Bool)
-> (Tree laws a -> Tree laws a -> Tree laws a)
-> (Tree laws a -> Tree laws a -> Tree laws a)
-> Ord (Tree laws a)
Tree laws a -> Tree laws a -> Bool
Tree laws a -> Tree laws a -> Ordering
Tree laws a -> Tree laws a -> Tree laws a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall laws a. Ord a => Eq (Tree laws a)
forall laws a. Ord a => Tree laws a -> Tree laws a -> Bool
forall laws a. Ord a => Tree laws a -> Tree laws a -> Ordering
forall laws a. Ord a => Tree laws a -> Tree laws a -> Tree laws a
min :: Tree laws a -> Tree laws a -> Tree laws a
$cmin :: forall laws a. Ord a => Tree laws a -> Tree laws a -> Tree laws a
max :: Tree laws a -> Tree laws a -> Tree laws a
$cmax :: forall laws a. Ord a => Tree laws a -> Tree laws a -> Tree laws a
>= :: Tree laws a -> Tree laws a -> Bool
$c>= :: forall laws a. Ord a => Tree laws a -> Tree laws a -> Bool
> :: Tree laws a -> Tree laws a -> Bool
$c> :: forall laws a. Ord a => Tree laws a -> Tree laws a -> Bool
<= :: Tree laws a -> Tree laws a -> Bool
$c<= :: forall laws a. Ord a => Tree laws a -> Tree laws a -> Bool
< :: Tree laws a -> Tree laws a -> Bool
$c< :: forall laws a. Ord a => Tree laws a -> Tree laws a -> Bool
compare :: Tree laws a -> Tree laws a -> Ordering
$ccompare :: forall laws a. Ord a => Tree laws a -> Tree laws a -> Ordering
$cp1Ord :: forall laws a. Ord a => Eq (Tree laws a)
Ord, Int -> Tree laws a -> ShowS
[Tree laws a] -> ShowS
Tree laws a -> String
(Int -> Tree laws a -> ShowS)
-> (Tree laws a -> String)
-> ([Tree laws a] -> ShowS)
-> Show (Tree laws a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall laws a. Show a => Int -> Tree laws a -> ShowS
forall laws a. Show a => [Tree laws a] -> ShowS
forall laws a. Show a => Tree laws a -> String
showList :: [Tree laws a] -> ShowS
$cshowList :: forall laws a. Show a => [Tree laws a] -> ShowS
show :: Tree laws a -> String
$cshow :: forall laws a. Show a => Tree laws a -> String
showsPrec :: Int -> Tree laws a -> ShowS
$cshowsPrec :: forall laws a. Show a => Int -> Tree laws a -> ShowS
Show, a -> Tree laws b -> Tree laws a
(a -> b) -> Tree laws a -> Tree laws b
(forall a b. (a -> b) -> Tree laws a -> Tree laws b)
-> (forall a b. a -> Tree laws b -> Tree laws a)
-> Functor (Tree laws)
forall a b. a -> Tree laws b -> Tree laws a
forall a b. (a -> b) -> Tree laws a -> Tree laws b
forall laws a b. a -> Tree laws b -> Tree laws a
forall laws a b. (a -> b) -> Tree laws a -> Tree laws b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Tree laws b -> Tree laws a
$c<$ :: forall laws a b. a -> Tree laws b -> Tree laws a
fmap :: (a -> b) -> Tree laws a -> Tree laws b
$cfmap :: forall laws a b. (a -> b) -> Tree laws a -> Tree laws b
Functor)

-- | Convenience function to construct a Tree from a list with left bracket groupings.
--
-- >>> toTreeL [1,4,7,12,0]
-- Branch (Branch (Branch (Branch (Leaf 1) (Leaf 4)) (Leaf 7)) (Leaf 12)) (Leaf 0)
toTreeL :: NonEmpty a -> Tree NoLaws a
toTreeL :: NonEmpty a -> Tree NoLaws a
toTreeL (a
x :| [a]
xs) = (Tree NoLaws a -> a -> Tree NoLaws a)
-> Tree NoLaws a -> [a] -> Tree NoLaws a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Tree NoLaws a
s a
a -> Tree NoLaws a -> Tree NoLaws a -> Tree NoLaws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree NoLaws a
s (a -> Tree NoLaws a
forall laws a. a -> Tree laws a
Leaf a
a)) (a -> Tree NoLaws a
forall laws a. a -> Tree laws a
Leaf a
x) [a]
xs

-- | Construct a Tree from a list with a right bracket groupings.
--
-- >>> toTreeR [1,4,7,12,0]
-- Branch (Leaf 1) (Branch (Leaf 4) (Branch (Leaf 7) (Branch (Leaf 12) (Leaf 0))))
toTreeR :: NonEmpty a -> Tree NoLaws a
toTreeR :: NonEmpty a -> Tree NoLaws a
toTreeR NonEmpty a
l =
  let (a
x :| [a]
xs) = ([a] -> NonEmpty a
forall l. IsList l => [Item l] -> l
fromList ([a] -> NonEmpty a)
-> (NonEmpty a -> [a]) -> NonEmpty a -> NonEmpty a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> (NonEmpty a -> [a]) -> NonEmpty a -> [a]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NonEmpty a -> [a]
forall l. IsList l => l -> [Item l]
toList (NonEmpty a -> NonEmpty a) -> NonEmpty a -> NonEmpty a
forall a b. (a -> b) -> a -> b
$ NonEmpty a
l)
   in (Tree NoLaws a -> a -> Tree NoLaws a)
-> Tree NoLaws a -> [a] -> Tree NoLaws a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Tree NoLaws a
s a
a -> Tree NoLaws a -> Tree NoLaws a -> Tree NoLaws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch (a -> Tree NoLaws a
forall laws a. a -> Tree laws a
Leaf a
a) Tree NoLaws a
s) (a -> Tree NoLaws a
forall laws a. a -> Tree laws a
Leaf a
x) [a]
xs

-- * Individual Magma Laws

-- | example type
newtype Example = Example Int deriving (Example -> Example -> Bool
(Example -> Example -> Bool)
-> (Example -> Example -> Bool) -> Eq Example
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Example -> Example -> Bool
$c/= :: Example -> Example -> Bool
== :: Example -> Example -> Bool
$c== :: Example -> Example -> Bool
Eq, Eq Example
Eq Example
-> (Example -> Example -> Ordering)
-> (Example -> Example -> Bool)
-> (Example -> Example -> Bool)
-> (Example -> Example -> Bool)
-> (Example -> Example -> Bool)
-> (Example -> Example -> Example)
-> (Example -> Example -> Example)
-> Ord Example
Example -> Example -> Bool
Example -> Example -> Ordering
Example -> Example -> Example
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Example -> Example -> Example
$cmin :: Example -> Example -> Example
max :: Example -> Example -> Example
$cmax :: Example -> Example -> Example
>= :: Example -> Example -> Bool
$c>= :: Example -> Example -> Bool
> :: Example -> Example -> Bool
$c> :: Example -> Example -> Bool
<= :: Example -> Example -> Bool
$c<= :: Example -> Example -> Bool
< :: Example -> Example -> Bool
$c< :: Example -> Example -> Bool
compare :: Example -> Example -> Ordering
$ccompare :: Example -> Example -> Ordering
$cp1Ord :: Eq Example
Ord, Magma Example
Magma Example -> Associative Example
forall a. Magma a -> Associative a
Associative, Magma Example
Magma Example -> Commutative Example
forall a. Magma a -> Commutative a
Commutative, Magma Example
Magma Example -> Idempotent Example
forall a. Magma a -> Idempotent a
Idempotent)

instance Magma Example where
  (Example Int
a) ⊕ :: Example -> Example -> Example
⊕ (Example Int
b) = Int -> Example
Example (Int -> Example) -> Int -> Example
forall a b. (a -> b) -> a -> b
$ Int
a Int -> Int -> Int
forall a. Additive a => a -> a -> a
+ Int
b

instance Unital Example where
  unit :: Example
unit = Int -> Example
Example Int
forall a. Additive a => a
zero

instance Absorbing Example where
  absorb :: Example
absorb = Int -> Example
Example Int
forall a. Additive a => a
zero

instance Invertible Example where
  inv :: Example -> Example
inv (Example Int
a) = Int -> Example
Example (Int -> Int
forall a. Subtractive a => a -> a
negate Int
a)

instance Show Example where
  show :: Example -> String
show (Example Int
a) = Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
a

-- | Free Algebra for a Magma
--
-- > a ⊕ b is closed
--
-- Given an initial binary Tree structure:
--
-- > data Tree a = Leaf a | Branch (Tree a) (Tree a)
--
-- , a closed binary operation (a magma) and no other laws, the free algebra is also a Tree.
--
-- >>> let init = toTreeL $ Example <$> [1,4,7,12,0] :: Tree NoLaws Example
-- >>> let free = forget init :: Tree MagmaOnly Example
-- >>> putStrLn $ printf $ free
-- ((((1⊕4)⊕7)⊕12)⊕0)
--
-- >>> algebra free
-- 24
data MagmaOnly

instance
  (Show a, Magma a) =>
  FreeAlgebra (Tree NoLaws) (Tree MagmaOnly) a
  where
  forget :: Tree NoLaws a -> Tree MagmaOnly a
forget = Tree NoLaws a -> Tree MagmaOnly a
coerce

  lift :: a -> Tree MagmaOnly a
lift = a -> Tree MagmaOnly a
forall laws a. a -> Tree laws a
Leaf

  algebra :: Tree MagmaOnly a -> a
algebra (Leaf a
a) = a
a
  algebra (Branch Tree MagmaOnly a
a Tree MagmaOnly a
b) = Tree MagmaOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree MagmaOnly a
a a -> a -> a
forall a. Magma a => a -> a -> a
⊕ Tree MagmaOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree MagmaOnly a
b

  printf :: Tree MagmaOnly a -> Text
printf (Leaf a
a) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a
  printf (Branch Tree MagmaOnly a
a Tree MagmaOnly a
b) = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Item [Text]
"(", Tree MagmaOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree MagmaOnly a
a, Item [Text]
"⊕", Tree MagmaOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree MagmaOnly a
b, Item [Text]
")"]

-- |
--
-- > unit ⊕ a = a
-- > a ⊕ unit = a
data UnitalOnly

-- | The introduction of unital laws to the algebra changes what the free structure is, compared to the 'MagmaOnly' case. From this library's point of view, that an algebra is an instruction kit for constructing an object, the unital laws are an instruction to substitute "a" for whenever "unit ⊕ a" occurs. Where an element is combined with the unit element, this operation should be erased and forgotten.
--
-- For example, from the point of view of the free algebra, ((0 ⊕ 4) ⊕ 0) ⊕ 12 and 4 ⊕ 12 (say) are the same. The initial structure can be divided into equivalence classes where trees are isomorphic (the same).
--
-- In contrast to the MagmaOnly case, the forgetting of unit operations means that an empty tree can result from an initially non-empty initial structure. The easiest way to represent this potential free object is simply to graft an EmptyTree tag to a Tree with a sum type.
--
-- An EmptyTree represents a collapse of an initial structure down to nothing, as a result of applying the unital laws eg
--
-- >>> let init = toTreeL $ Example <$> [0,0,0] :: Tree NoLaws Example
-- >>> forget init :: TreeU UnitalOnly Example
-- EmptyTree
--
-- __/By forgetting instances of the unital laws in the original expression, the unital laws cannot be violated in the free object because they no longer exist./__
--
-- >>> let init = toTreeL $ Example <$> [0,1,4,0,7,12,0] :: Tree NoLaws Example
-- >>> putStrLn $ printf $ (forget init :: TreeU UnitalOnly Example)
-- (((1⊕4)⊕7)⊕12)
data TreeU laws a = EmptyTree | NonEmptyTree (Tree MagmaOnly a)
  deriving (TreeU laws a -> TreeU laws a -> Bool
(TreeU laws a -> TreeU laws a -> Bool)
-> (TreeU laws a -> TreeU laws a -> Bool) -> Eq (TreeU laws a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall laws a. Eq a => TreeU laws a -> TreeU laws a -> Bool
/= :: TreeU laws a -> TreeU laws a -> Bool
$c/= :: forall laws a. Eq a => TreeU laws a -> TreeU laws a -> Bool
== :: TreeU laws a -> TreeU laws a -> Bool
$c== :: forall laws a. Eq a => TreeU laws a -> TreeU laws a -> Bool
Eq, Eq (TreeU laws a)
Eq (TreeU laws a)
-> (TreeU laws a -> TreeU laws a -> Ordering)
-> (TreeU laws a -> TreeU laws a -> Bool)
-> (TreeU laws a -> TreeU laws a -> Bool)
-> (TreeU laws a -> TreeU laws a -> Bool)
-> (TreeU laws a -> TreeU laws a -> Bool)
-> (TreeU laws a -> TreeU laws a -> TreeU laws a)
-> (TreeU laws a -> TreeU laws a -> TreeU laws a)
-> Ord (TreeU laws a)
TreeU laws a -> TreeU laws a -> Bool
TreeU laws a -> TreeU laws a -> Ordering
TreeU laws a -> TreeU laws a -> TreeU laws a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall laws a. Ord a => Eq (TreeU laws a)
forall laws a. Ord a => TreeU laws a -> TreeU laws a -> Bool
forall laws a. Ord a => TreeU laws a -> TreeU laws a -> Ordering
forall laws a.
Ord a =>
TreeU laws a -> TreeU laws a -> TreeU laws a
min :: TreeU laws a -> TreeU laws a -> TreeU laws a
$cmin :: forall laws a.
Ord a =>
TreeU laws a -> TreeU laws a -> TreeU laws a
max :: TreeU laws a -> TreeU laws a -> TreeU laws a
$cmax :: forall laws a.
Ord a =>
TreeU laws a -> TreeU laws a -> TreeU laws a
>= :: TreeU laws a -> TreeU laws a -> Bool
$c>= :: forall laws a. Ord a => TreeU laws a -> TreeU laws a -> Bool
> :: TreeU laws a -> TreeU laws a -> Bool
$c> :: forall laws a. Ord a => TreeU laws a -> TreeU laws a -> Bool
<= :: TreeU laws a -> TreeU laws a -> Bool
$c<= :: forall laws a. Ord a => TreeU laws a -> TreeU laws a -> Bool
< :: TreeU laws a -> TreeU laws a -> Bool
$c< :: forall laws a. Ord a => TreeU laws a -> TreeU laws a -> Bool
compare :: TreeU laws a -> TreeU laws a -> Ordering
$ccompare :: forall laws a. Ord a => TreeU laws a -> TreeU laws a -> Ordering
$cp1Ord :: forall laws a. Ord a => Eq (TreeU laws a)
Ord, Int -> TreeU laws a -> ShowS
[TreeU laws a] -> ShowS
TreeU laws a -> String
(Int -> TreeU laws a -> ShowS)
-> (TreeU laws a -> String)
-> ([TreeU laws a] -> ShowS)
-> Show (TreeU laws a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall laws a. Show a => Int -> TreeU laws a -> ShowS
forall laws a. Show a => [TreeU laws a] -> ShowS
forall laws a. Show a => TreeU laws a -> String
showList :: [TreeU laws a] -> ShowS
$cshowList :: forall laws a. Show a => [TreeU laws a] -> ShowS
show :: TreeU laws a -> String
$cshow :: forall laws a. Show a => TreeU laws a -> String
showsPrec :: Int -> TreeU laws a -> ShowS
$cshowsPrec :: forall laws a. Show a => Int -> TreeU laws a -> ShowS
Show, a -> TreeU laws b -> TreeU laws a
(a -> b) -> TreeU laws a -> TreeU laws b
(forall a b. (a -> b) -> TreeU laws a -> TreeU laws b)
-> (forall a b. a -> TreeU laws b -> TreeU laws a)
-> Functor (TreeU laws)
forall a b. a -> TreeU laws b -> TreeU laws a
forall a b. (a -> b) -> TreeU laws a -> TreeU laws b
forall laws a b. a -> TreeU laws b -> TreeU laws a
forall laws a b. (a -> b) -> TreeU laws a -> TreeU laws b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TreeU laws b -> TreeU laws a
$c<$ :: forall laws a b. a -> TreeU laws b -> TreeU laws a
fmap :: (a -> b) -> TreeU laws a -> TreeU laws b
$cfmap :: forall laws a b. (a -> b) -> TreeU laws a -> TreeU laws b
Functor)

instance
  (Eq a, Show a, Unital a) =>
  FreeAlgebra (Tree NoLaws) (TreeU UnitalOnly) a
  where
  forget :: Tree NoLaws a -> TreeU UnitalOnly a
forget (Leaf a
a) = a -> TreeU UnitalOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
a -> free a
lift a
a
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = TreeU UnitalOnly a -> TreeU UnitalOnly a -> TreeU UnitalOnly a
forall laws a. TreeU laws a -> TreeU laws a -> TreeU laws a
opU (Tree NoLaws a -> TreeU UnitalOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a) (Tree NoLaws a -> TreeU UnitalOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b)
    where
      opU :: TreeU laws a -> TreeU laws a -> TreeU laws a
opU TreeU laws a
EmptyTree TreeU laws a
t = TreeU laws a
t
      opU TreeU laws a
t TreeU laws a
EmptyTree = TreeU laws a
t
      opU (NonEmptyTree Tree MagmaOnly a
t) (NonEmptyTree Tree MagmaOnly a
t') = Tree MagmaOnly a -> TreeU laws a
forall laws a. Tree MagmaOnly a -> TreeU laws a
NonEmptyTree (Tree MagmaOnly a -> Tree MagmaOnly a -> Tree MagmaOnly a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree MagmaOnly a
t Tree MagmaOnly a
t')

  lift :: a -> TreeU UnitalOnly a
lift a
a = TreeU UnitalOnly a
-> TreeU UnitalOnly a -> Bool -> TreeU UnitalOnly a
forall a. a -> a -> Bool -> a
bool (Tree MagmaOnly a -> TreeU UnitalOnly a
forall laws a. Tree MagmaOnly a -> TreeU laws a
NonEmptyTree (a -> Tree MagmaOnly a
forall laws a. a -> Tree laws a
Leaf a
a)) TreeU UnitalOnly a
forall laws a. TreeU laws a
EmptyTree (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Unital a => a
unit)

  algebra :: TreeU UnitalOnly a -> a
algebra TreeU UnitalOnly a
EmptyTree = a
forall a. Unital a => a
unit
  algebra (NonEmptyTree Tree MagmaOnly a
t) = Tree MagmaOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree MagmaOnly a
t

  printf :: TreeU UnitalOnly a -> Text
printf TreeU UnitalOnly a
EmptyTree = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show @a (Unital a => a
forall a. Unital a => a
unit @a)
  printf (NonEmptyTree Tree MagmaOnly a
t) = Tree MagmaOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree MagmaOnly a
t

-- |
--
-- > (a ⊕ b) ⊕ c = a ⊕ (b ⊕ c)
data AssociativeOnly

-- | Introduction of an associative law induces an equivalence class where, for example, (1 ⊕ 2) ⊕ 3 and 1 ⊕ (2 ⊕ 3) should be represented in the same way.
--
-- 'forget', the free object constructor, thus needs to forget about the tree shape (the brackets or parentheses of the original expression).
--
-- As an algebra consumes an expression one element at a time, branches (or "links") still exist from one element to the next. The free object is still a tree structure, but it is the same tree shape.
--
-- Forcing one side of the branch to be a value provides a tree structure that branches to the other side. The left branch as the value has been chosen in this representation but this is arbitrary.
--
-- >>> let exl = toTreeL $ Example <$> [1,4,7,12,0]
-- >>> putStrLn $ printf (forget exl :: Tree MagmaOnly Example)
-- ((((1⊕4)⊕7)⊕12)⊕0)
--
-- >>> let exr = toTreeR $ Example <$> [1,4,7,12,0]
-- >>> putStrLn $ printf (forget exr :: Tree MagmaOnly Example)
-- (1⊕(4⊕(7⊕(12⊕0))))
--
-- >>> putStrLn $ printf (forget exl :: TreeA AssociativeOnly Example)
-- 1⊕4⊕7⊕12⊕0
--
-- >>> (\x -> (forget $ toTreeL x :: TreeA AssociativeOnly Example) == (forget $ toTreeR $ x :: TreeA AssociativeOnly Example)) (Example <$> [1,4,7,12,0])
-- True
data TreeA laws a = LeafA a | BranchA a (TreeA laws a) deriving (TreeA laws a -> TreeA laws a -> Bool
(TreeA laws a -> TreeA laws a -> Bool)
-> (TreeA laws a -> TreeA laws a -> Bool) -> Eq (TreeA laws a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall laws a. Eq a => TreeA laws a -> TreeA laws a -> Bool
/= :: TreeA laws a -> TreeA laws a -> Bool
$c/= :: forall laws a. Eq a => TreeA laws a -> TreeA laws a -> Bool
== :: TreeA laws a -> TreeA laws a -> Bool
$c== :: forall laws a. Eq a => TreeA laws a -> TreeA laws a -> Bool
Eq, Int -> TreeA laws a -> ShowS
[TreeA laws a] -> ShowS
TreeA laws a -> String
(Int -> TreeA laws a -> ShowS)
-> (TreeA laws a -> String)
-> ([TreeA laws a] -> ShowS)
-> Show (TreeA laws a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall laws a. Show a => Int -> TreeA laws a -> ShowS
forall laws a. Show a => [TreeA laws a] -> ShowS
forall laws a. Show a => TreeA laws a -> String
showList :: [TreeA laws a] -> ShowS
$cshowList :: forall laws a. Show a => [TreeA laws a] -> ShowS
show :: TreeA laws a -> String
$cshow :: forall laws a. Show a => TreeA laws a -> String
showsPrec :: Int -> TreeA laws a -> ShowS
$cshowsPrec :: forall laws a. Show a => Int -> TreeA laws a -> ShowS
Show, a -> TreeA laws b -> TreeA laws a
(a -> b) -> TreeA laws a -> TreeA laws b
(forall a b. (a -> b) -> TreeA laws a -> TreeA laws b)
-> (forall a b. a -> TreeA laws b -> TreeA laws a)
-> Functor (TreeA laws)
forall a b. a -> TreeA laws b -> TreeA laws a
forall a b. (a -> b) -> TreeA laws a -> TreeA laws b
forall laws a b. a -> TreeA laws b -> TreeA laws a
forall laws a b. (a -> b) -> TreeA laws a -> TreeA laws b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TreeA laws b -> TreeA laws a
$c<$ :: forall laws a b. a -> TreeA laws b -> TreeA laws a
fmap :: (a -> b) -> TreeA laws a -> TreeA laws b
$cfmap :: forall laws a b. (a -> b) -> TreeA laws a -> TreeA laws b
Functor)

instance (Show a, Associative a) => FreeAlgebra (Tree NoLaws) (TreeA AssociativeOnly) a where
  forget :: Tree NoLaws a -> TreeA AssociativeOnly a
forget (Leaf a
a) = a -> TreeA AssociativeOnly a
forall laws a. a -> TreeA laws a
LeafA a
a
  forget (Branch (Leaf a
a) Tree NoLaws a
b) = a -> TreeA AssociativeOnly a -> TreeA AssociativeOnly a
forall laws a. a -> TreeA laws a -> TreeA laws a
BranchA a
a (Tree NoLaws a -> TreeA AssociativeOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b)
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = TreeA AssociativeOnly a
-> TreeA AssociativeOnly a -> TreeA AssociativeOnly a
opA (Tree NoLaws a -> TreeA AssociativeOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a) (Tree NoLaws a -> TreeA AssociativeOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b)
    where
      opA :: TreeA AssociativeOnly a -> TreeA AssociativeOnly a -> TreeA AssociativeOnly a
      opA :: TreeA AssociativeOnly a
-> TreeA AssociativeOnly a -> TreeA AssociativeOnly a
opA (LeafA a
a) TreeA AssociativeOnly a
b = a -> TreeA AssociativeOnly a -> TreeA AssociativeOnly a
forall laws a. a -> TreeA laws a -> TreeA laws a
BranchA a
a TreeA AssociativeOnly a
b
      opA (BranchA a
a TreeA AssociativeOnly a
b) TreeA AssociativeOnly a
c = a -> TreeA AssociativeOnly a -> TreeA AssociativeOnly a
forall laws a. a -> TreeA laws a -> TreeA laws a
BranchA a
a (TreeA AssociativeOnly a
-> TreeA AssociativeOnly a -> TreeA AssociativeOnly a
opA TreeA AssociativeOnly a
b TreeA AssociativeOnly a
c)

  lift :: a -> TreeA AssociativeOnly a
lift = a -> TreeA AssociativeOnly a
forall laws a. a -> TreeA laws a
LeafA

  algebra :: TreeA AssociativeOnly a -> a
algebra (LeafA a
a) = a
a
  algebra (BranchA a
a TreeA AssociativeOnly a
b) = a
a a -> a -> a
forall a. Magma a => a -> a -> a
⊕ TreeA AssociativeOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra TreeA AssociativeOnly a
b

  printf :: TreeA AssociativeOnly a -> Text
printf (LeafA a
a) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a
  printf (BranchA a
a TreeA AssociativeOnly a
b) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"⊕" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TreeA AssociativeOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf TreeA AssociativeOnly a
b

-- |
--
-- > a ⊕ b == b ⊕ a
--
-- but non-associative, so
--
-- > (a ⊕ b) ⊕ c == (b ⊕ a) ⊕ c
--
-- but
--
-- > (a ⊕ b) ⊕ c /= a ⊕ (b ⊕ c)
--
-- Commutation requires a ⊕ b and b ⊕ a to be represented the same, and this induces a preordering: __/some/__ form of (arbitrary) ordering is needed to consistently and naturally represent a ⊕ b and b ⊕ a as "ab".
--
-- In structural terms, a commutative tree is a mobile; a tree that has lost it's left and rightedness. To implement this forgetting, the left element of BranchC is arbitrarily chosen as always being less than or equal to the right element.
--
-- c1: 3 ⊕ (2 ⊕ 1)
--
-- c2: 3 ⊕ (1 ⊕ 2)
--
-- c3: (1 ⊕ 2) ⊕ 3
--
-- >>> let c1 = forget $ Branch (Leaf (Example 3)) (Branch (Leaf (Example 2)) (Leaf (Example 1))) :: Tree CommutativeOnly Example
-- >>> let c2 = forget $ Branch (Leaf (Example 3)) (Branch (Leaf (Example 1)) (Leaf (Example 2))) :: Tree CommutativeOnly Example
-- >>> let c3 = forget $ Branch (Branch (Leaf (Example 1)) (Leaf (Example 2))) (Leaf (Example 3)) :: Tree CommutativeOnly Example
--
-- >>> c1 == c2
-- True
--
-- >>> c1 == c3
-- True
data CommutativeOnly

instance (Show a, Ord a, Commutative a) => FreeAlgebra (Tree NoLaws) (Tree CommutativeOnly) a where
  forget :: Tree NoLaws a -> Tree CommutativeOnly a
forget (Leaf a
a) = a -> Tree CommutativeOnly a
forall laws a. a -> Tree laws a
Leaf a
a
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = Tree CommutativeOnly a
-> Tree CommutativeOnly a -> Tree CommutativeOnly a
forall a laws. Ord a => Tree laws a -> Tree laws a -> Tree laws a
op (Tree NoLaws a -> Tree CommutativeOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a) (Tree NoLaws a -> Tree CommutativeOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b)
    where
      -- The commutative binary operation "forgets" the original ordering, thus losing the left/right information contained in the original Tree.
      op :: Tree laws a -> Tree laws a -> Tree laws a
op Tree laws a
a Tree laws a
b = Tree laws a -> Tree laws a -> Bool -> Tree laws a
forall a. a -> a -> Bool -> a
bool (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
b Tree laws a
a) (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
a Tree laws a
b) (Tree laws a
a Tree laws a -> Tree laws a -> Bool
forall a. Ord a => a -> a -> Bool
< Tree laws a
b)

  lift :: a -> Tree CommutativeOnly a
lift = a -> Tree CommutativeOnly a
forall laws a. a -> Tree laws a
Leaf

  algebra :: Tree CommutativeOnly a -> a
algebra (Leaf a
a) = a
a
  algebra (Branch Tree CommutativeOnly a
a Tree CommutativeOnly a
b) = Tree CommutativeOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree CommutativeOnly a
a a -> a -> a
forall a. Magma a => a -> a -> a
⊕ Tree CommutativeOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree CommutativeOnly a
b

  printf :: Tree CommutativeOnly a -> Text
printf (Leaf a
a) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a
  printf (Branch Tree CommutativeOnly a
a Tree CommutativeOnly a
b) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree CommutativeOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree CommutativeOnly a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"⊕" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree CommutativeOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree CommutativeOnly a
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- |
--
-- > inv a ⊕ (a ⊕ b) == b -- left cancellation
-- > (a ⊕ b) ⊕ inv b == a -- right cancellation
--
-- but
--
-- > inv a ⊕ a == unit
-- is not a thing yet without a unit to equal to.
--
-- The cancellation (or reversal or negation) of a value and the value are both lost in forming the equivalence relationship. Editing and diffing are two obvious examples.
--
-- The data structure for the equivalence class is unchanged, so Tree can be reused.
--
-- inv1: -1 ⊕ (1 ⊕ 5) == 5
--
-- inv2: (1 ⊕ 5) ⊕ -5 == 1
--
-- inv3: (1 ⊕ 5) ⊕ -1 == (1 ⊕ 5) ⊕ -1
--
-- >>> let inv1 = Branch (Leaf (Example (-1))) (Branch (Leaf (Example 1)) (Leaf (Example 5)))
-- >>> let inv2 = Branch (Branch (Leaf (Example 1)) (Leaf (Example 5))) (Leaf (Example (-5)))
-- >>> let inv3 = Branch (Branch (Leaf (Example 1)) (Leaf (Example 5))) (Leaf ((Example (-1))))
-- >>> forget inv1 :: Tree InvertibleOnly Example
-- Leaf 5
--
-- >>> putStrLn $ printf $ (forget inv3 :: Tree InvertibleOnly Example)
-- ((1⊕5)⊕-1)
data InvertibleOnly

instance (Show a, Eq a, Invertible a) => FreeAlgebra (Tree NoLaws) (Tree InvertibleOnly) a where
  forget :: Tree NoLaws a -> Tree InvertibleOnly a
forget (Leaf a
a) = a -> Tree InvertibleOnly a
forall laws a. a -> Tree laws a
Leaf a
a
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = Tree InvertibleOnly a
-> Tree InvertibleOnly a -> Tree InvertibleOnly a
forall a laws.
(Eq a, Invertible a) =>
Tree laws a -> Tree laws a -> Tree laws a
op (Tree NoLaws a -> Tree InvertibleOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a) (Tree NoLaws a -> Tree InvertibleOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b)
    where
      op :: Tree laws a -> Tree laws a -> Tree laws a
op a :: Tree laws a
a@(Branch Tree laws a
la (Leaf a
ra)) b :: Tree laws a
b@(Branch (Leaf a
lb) Tree laws a
rb) =
        Tree laws a -> Tree laws a -> Bool -> Tree laws a
forall a. a -> a -> Bool -> a
bool (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
a Tree laws a
b) (Tree laws a -> Tree laws a -> Tree laws a
op Tree laws a
la Tree laws a
rb) (a
ra a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Invertible a => a -> a
inv a
lb)
      op l :: Tree laws a
l@(Leaf a
la) b :: Tree laws a
b@(Branch (Leaf a
lb) Tree laws a
bb) =
        Tree laws a -> Tree laws a -> Bool -> Tree laws a
forall a. a -> a -> Bool -> a
bool (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
l Tree laws a
b) Tree laws a
bb (a
la a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Invertible a => a -> a
inv a
lb)
      op b :: Tree laws a
b@(Branch Tree laws a
bb (Leaf a
lb)) l :: Tree laws a
l@(Leaf a
la) =
        Tree laws a -> Tree laws a -> Bool -> Tree laws a
forall a. a -> a -> Bool -> a
bool (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
b Tree laws a
l) Tree laws a
bb (a
lb a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Invertible a => a -> a
inv a
la)
      op Tree laws a
l Tree laws a
r = Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
l Tree laws a
r

  lift :: a -> Tree InvertibleOnly a
lift = a -> Tree InvertibleOnly a
forall laws a. a -> Tree laws a
Leaf

  algebra :: Tree InvertibleOnly a -> a
algebra (Leaf a
a) = a
a
  algebra (Branch Tree InvertibleOnly a
a Tree InvertibleOnly a
b) = Tree InvertibleOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree InvertibleOnly a
a a -> a -> a
forall a. Magma a => a -> a -> a
⊕ Tree InvertibleOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree InvertibleOnly a
b

  printf :: Tree InvertibleOnly a -> Text
printf (Leaf a
a) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a
  printf (Branch Tree InvertibleOnly a
a Tree InvertibleOnly a
b) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree InvertibleOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree InvertibleOnly a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"⊕" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree InvertibleOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree InvertibleOnly a
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- |
--
-- > a ⊕ a = a
--
-- Immediately repeated elements are forgotten in the equivalence class object.
--
-- idem1: (5 ⊕ 5) ⊕ 1 == 5 ⊕ 1
--
-- idem2: (1 ⊕ 5) ⊕ (1 ⊕ 5) == (1 ⊕ 5)
--
-- but
--
-- idem3: (1 ⊕ 5) ⊕ 5 == (1 ⊕ 5) ⊕ 5
--
-- because we don't yet have associativity.
--
-- >>> let idem1 = Branch (Branch (Leaf (Example 5)) (Leaf (Example 5))) (Leaf (Example 1))
-- >>> let idem2 = Branch (Branch (Leaf (Example 1)) (Leaf (Example 5))) (Branch (Leaf (Example 1)) (Leaf  (Example 5)))
-- >>> let idem3 = Branch (Branch (Leaf (Example 1)) (Leaf (Example 5))) (Leaf (Example 5))
-- >>> putStrLn $ printf (forget idem1 :: Tree IdempotentOnly Example)
-- (5 o 1)
--
-- >>> putStrLn $ printf (forget idem2 :: Tree IdempotentOnly Example)
-- (1 o 5)
--
-- >>> putStrLn $ printf (forget idem3 :: Tree IdempotentOnly Example)
-- ((1 o 5) o 5)
--
-- >>> algebra (forget idem3 :: Tree IdempotentOnly Example)
-- 5
data IdempotentOnly

instance (Show a, Ord a) => FreeAlgebra (Tree NoLaws) (Tree IdempotentOnly) a where
  forget :: Tree NoLaws a -> Tree IdempotentOnly a
forget (Leaf a
a) = a -> Tree IdempotentOnly a
forall laws a. a -> Tree laws a
Leaf a
a
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = Tree IdempotentOnly a
-> Tree IdempotentOnly a -> Tree IdempotentOnly a
forall a laws. Eq a => Tree laws a -> Tree laws a -> Tree laws a
op (Tree NoLaws a -> Tree IdempotentOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a) (Tree NoLaws a -> Tree IdempotentOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b)
    where
      op :: Tree laws a -> Tree laws a -> Tree laws a
op Tree laws a
a Tree laws a
b = Tree laws a -> Tree laws a -> Bool -> Tree laws a
forall a. a -> a -> Bool -> a
bool (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
a Tree laws a
b) Tree laws a
a (Tree laws a
a Tree laws a -> Tree laws a -> Bool
forall a. Eq a => a -> a -> Bool
== Tree laws a
b)

  lift :: a -> Tree IdempotentOnly a
lift = a -> Tree IdempotentOnly a
forall laws a. a -> Tree laws a
Leaf

  algebra :: Tree IdempotentOnly a -> a
algebra (Leaf a
a) = a
a
  algebra (Branch Tree IdempotentOnly a
a Tree IdempotentOnly a
b) = Tree IdempotentOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree IdempotentOnly a
a a -> a -> a
forall a. Ord a => a -> a -> a
`max` Tree IdempotentOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree IdempotentOnly a
b

  printf :: Tree IdempotentOnly a -> Text
printf (Leaf a
a) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a
  printf (Branch Tree IdempotentOnly a
a Tree IdempotentOnly a
b) =
    Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree IdempotentOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree IdempotentOnly a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" o " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree IdempotentOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree IdempotentOnly a
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- |
--
-- > e ⊕ a == e  left absorbing
-- > a ⊕ e == e  right absorbing
--
-- The absorbed element is forgotten.
--
-- ab1: 0 * (2 * 5) == 0
--
-- ab2: (2 * 5) * 0 == 0
--
-- >>> let ab1 = Branch (Leaf (Example 0)) (Branch (Leaf (Example 2)) (Leaf (Example 5)))
-- >>> let ab2 = Branch (Branch (Leaf (Example 2)) (Leaf (Example 5))) (Leaf (Example 0))
-- >>> forget ab1 :: Tree AbsorbingOnly Example
-- Leaf 0
--
-- >>> forget ab2 :: Tree AbsorbingOnly Example
-- Leaf 0
data AbsorbingOnly

instance
  (Show a, Eq a, Absorbing a) =>
  FreeAlgebra (Tree NoLaws) (Tree AbsorbingOnly) a
  where
  forget :: Tree NoLaws a -> Tree AbsorbingOnly a
forget (Leaf a
a) = a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
a
  forget (Branch (Leaf a
a) (Leaf a
b)) =
    Tree AbsorbingOnly a
-> Tree AbsorbingOnly a -> Bool -> Tree AbsorbingOnly a
forall a. a -> a -> Bool -> a
bool
      (Tree AbsorbingOnly a
-> Tree AbsorbingOnly a -> Tree AbsorbingOnly a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch (a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
a) (a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
b))
      (a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
forall a. Absorbing a => a
absorb)
      (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Absorbing a => a
absorb Bool -> Bool -> Bool
|| a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Absorbing a => a
absorb)
  forget (Branch (Leaf a
a) Tree NoLaws a
r) =
    Tree AbsorbingOnly a
-> Tree AbsorbingOnly a -> Bool -> Tree AbsorbingOnly a
forall a. a -> a -> Bool -> a
bool (Tree AbsorbingOnly a
-> Tree AbsorbingOnly a -> Tree AbsorbingOnly a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch (a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
a) (Tree NoLaws a -> Tree AbsorbingOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
r)) (a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
forall a. Absorbing a => a
absorb) (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Absorbing a => a
absorb)
  forget (Branch Tree NoLaws a
l (Leaf a
a)) =
    Tree AbsorbingOnly a
-> Tree AbsorbingOnly a -> Bool -> Tree AbsorbingOnly a
forall a. a -> a -> Bool -> a
bool (Tree AbsorbingOnly a
-> Tree AbsorbingOnly a -> Tree AbsorbingOnly a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch (Tree NoLaws a -> Tree AbsorbingOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
l) (a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
a)) (a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf a
forall a. Absorbing a => a
absorb) (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Absorbing a => a
absorb)
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = Tree AbsorbingOnly a
-> Tree AbsorbingOnly a -> Tree AbsorbingOnly a
forall a laws.
(Absorbing a, Eq a) =>
Tree laws a -> Tree laws a -> Tree laws a
op (Tree NoLaws a -> Tree AbsorbingOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a) (Tree NoLaws a -> Tree AbsorbingOnly a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b)
    where
      op :: Tree laws a -> Tree laws a -> Tree laws a
op l :: Tree laws a
l@(Leaf a
a) Tree laws a
r =
        Tree laws a -> Tree laws a -> Bool -> Tree laws a
forall a. a -> a -> Bool -> a
bool (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
l Tree laws a
r) (a -> Tree laws a
forall laws a. a -> Tree laws a
Leaf a
forall a. Absorbing a => a
absorb) (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Absorbing a => a
absorb)
      op Tree laws a
l r :: Tree laws a
r@(Leaf a
a) =
        Tree laws a -> Tree laws a -> Bool -> Tree laws a
forall a. a -> a -> Bool -> a
bool (Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
l Tree laws a
r) (a -> Tree laws a
forall laws a. a -> Tree laws a
Leaf a
forall a. Absorbing a => a
absorb) (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Absorbing a => a
absorb)
      op Tree laws a
a Tree laws a
b = Tree laws a -> Tree laws a -> Tree laws a
forall laws a. Tree laws a -> Tree laws a -> Tree laws a
Branch Tree laws a
a Tree laws a
b

  lift :: a -> Tree AbsorbingOnly a
lift = a -> Tree AbsorbingOnly a
forall laws a. a -> Tree laws a
Leaf

  algebra :: Tree AbsorbingOnly a -> a
algebra (Leaf a
a) = a
a
  algebra (Branch Tree AbsorbingOnly a
a Tree AbsorbingOnly a
b) = Tree AbsorbingOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree AbsorbingOnly a
a a -> a -> a
forall a. Magma a => a -> a -> a
⊕ Tree AbsorbingOnly a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Tree AbsorbingOnly a
b

  printf :: Tree AbsorbingOnly a -> Text
printf (Leaf a
a) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a
  printf (Branch Tree AbsorbingOnly a
a Tree AbsorbingOnly a
b) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree AbsorbingOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree AbsorbingOnly a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tree AbsorbingOnly a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Tree AbsorbingOnly a
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | The free monoid is a list.
--
-- Applying unital and associativity laws in the context of converting an expression tree into a free monoid, the simplest structure possible, involves:
--
-- - forgetting whenever an element in the initial structure in the unit (one, say, in the case of multiplication).
-- - forgetting the brackets.
--
-- So, starting with the initial tree:
--
-- > data Tree a = Leaf a | Branch (Tree a) (Tree a)
--
-- We graft on a sum tag to represent an empty structure:
--
-- > data Tree a = EmptyTree | Leaf a | Branch (Tree a) (Tree a)
--
-- To 'forget' the left/right structure of the tree we force the left side of the branch to be a value rather than another tree branch, so that the whole tree always branches to the right:
--
-- > data Tree a = EmptyTree | Leaf a | Branch a (Tree a)
--
-- Leaf a can be represented as Branch a EmptyTree, so we can simplify this to:
--
-- > data Tree a = EmptyTree | Branch a (Tree a)
--
-- And this is the classical Haskell cons list with different names:
--
-- > data [] a = [] | a : [a]
newtype FreeMonoid laws a = FreeMonoid {FreeMonoid laws a -> [a]
leaves :: [a]} deriving (FreeMonoid laws a -> FreeMonoid laws a -> Bool
(FreeMonoid laws a -> FreeMonoid laws a -> Bool)
-> (FreeMonoid laws a -> FreeMonoid laws a -> Bool)
-> Eq (FreeMonoid laws a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall laws a.
Eq a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
/= :: FreeMonoid laws a -> FreeMonoid laws a -> Bool
$c/= :: forall laws a.
Eq a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
== :: FreeMonoid laws a -> FreeMonoid laws a -> Bool
$c== :: forall laws a.
Eq a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
Eq, Eq (FreeMonoid laws a)
Eq (FreeMonoid laws a)
-> (FreeMonoid laws a -> FreeMonoid laws a -> Ordering)
-> (FreeMonoid laws a -> FreeMonoid laws a -> Bool)
-> (FreeMonoid laws a -> FreeMonoid laws a -> Bool)
-> (FreeMonoid laws a -> FreeMonoid laws a -> Bool)
-> (FreeMonoid laws a -> FreeMonoid laws a -> Bool)
-> (FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a)
-> (FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a)
-> Ord (FreeMonoid laws a)
FreeMonoid laws a -> FreeMonoid laws a -> Bool
FreeMonoid laws a -> FreeMonoid laws a -> Ordering
FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall laws a. Ord a => Eq (FreeMonoid laws a)
forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> Ordering
forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a
min :: FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a
$cmin :: forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a
max :: FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a
$cmax :: forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> FreeMonoid laws a
>= :: FreeMonoid laws a -> FreeMonoid laws a -> Bool
$c>= :: forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
> :: FreeMonoid laws a -> FreeMonoid laws a -> Bool
$c> :: forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
<= :: FreeMonoid laws a -> FreeMonoid laws a -> Bool
$c<= :: forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
< :: FreeMonoid laws a -> FreeMonoid laws a -> Bool
$c< :: forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> Bool
compare :: FreeMonoid laws a -> FreeMonoid laws a -> Ordering
$ccompare :: forall laws a.
Ord a =>
FreeMonoid laws a -> FreeMonoid laws a -> Ordering
$cp1Ord :: forall laws a. Ord a => Eq (FreeMonoid laws a)
Ord, a -> FreeMonoid laws a -> Bool
FreeMonoid laws m -> m
FreeMonoid laws a -> [a]
FreeMonoid laws a -> Bool
FreeMonoid laws a -> Int
FreeMonoid laws a -> a
FreeMonoid laws a -> a
FreeMonoid laws a -> a
FreeMonoid laws a -> a
(a -> m) -> FreeMonoid laws a -> m
(a -> m) -> FreeMonoid laws a -> m
(a -> b -> b) -> b -> FreeMonoid laws a -> b
(a -> b -> b) -> b -> FreeMonoid laws a -> b
(b -> a -> b) -> b -> FreeMonoid laws a -> b
(b -> a -> b) -> b -> FreeMonoid laws a -> b
(a -> a -> a) -> FreeMonoid laws a -> a
(a -> a -> a) -> FreeMonoid laws a -> a
(forall m. Monoid m => FreeMonoid laws m -> m)
-> (forall m a. Monoid m => (a -> m) -> FreeMonoid laws a -> m)
-> (forall m a. Monoid m => (a -> m) -> FreeMonoid laws a -> m)
-> (forall a b. (a -> b -> b) -> b -> FreeMonoid laws a -> b)
-> (forall a b. (a -> b -> b) -> b -> FreeMonoid laws a -> b)
-> (forall b a. (b -> a -> b) -> b -> FreeMonoid laws a -> b)
-> (forall b a. (b -> a -> b) -> b -> FreeMonoid laws a -> b)
-> (forall a. (a -> a -> a) -> FreeMonoid laws a -> a)
-> (forall a. (a -> a -> a) -> FreeMonoid laws a -> a)
-> (forall a. FreeMonoid laws a -> [a])
-> (forall a. FreeMonoid laws a -> Bool)
-> (forall a. FreeMonoid laws a -> Int)
-> (forall a. Eq a => a -> FreeMonoid laws a -> Bool)
-> (forall a. Ord a => FreeMonoid laws a -> a)
-> (forall a. Ord a => FreeMonoid laws a -> a)
-> (forall a. Num a => FreeMonoid laws a -> a)
-> (forall a. Num a => FreeMonoid laws a -> a)
-> Foldable (FreeMonoid laws)
forall a. Eq a => a -> FreeMonoid laws a -> Bool
forall a. Num a => FreeMonoid laws a -> a
forall a. Ord a => FreeMonoid laws a -> a
forall m. Monoid m => FreeMonoid laws m -> m
forall a. FreeMonoid laws a -> Bool
forall a. FreeMonoid laws a -> Int
forall a. FreeMonoid laws a -> [a]
forall a. (a -> a -> a) -> FreeMonoid laws a -> a
forall laws a. Eq a => a -> FreeMonoid laws a -> Bool
forall laws a. Num a => FreeMonoid laws a -> a
forall laws a. Ord a => FreeMonoid laws a -> a
forall m a. Monoid m => (a -> m) -> FreeMonoid laws a -> m
forall laws m. Monoid m => FreeMonoid laws m -> m
forall laws a. FreeMonoid laws a -> Bool
forall laws a. FreeMonoid laws a -> Int
forall laws a. FreeMonoid laws a -> [a]
forall b a. (b -> a -> b) -> b -> FreeMonoid laws a -> b
forall a b. (a -> b -> b) -> b -> FreeMonoid laws a -> b
forall laws a. (a -> a -> a) -> FreeMonoid laws a -> a
forall laws m a. Monoid m => (a -> m) -> FreeMonoid laws a -> m
forall laws b a. (b -> a -> b) -> b -> FreeMonoid laws a -> b
forall laws a b. (a -> b -> b) -> b -> FreeMonoid laws a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: FreeMonoid laws a -> a
$cproduct :: forall laws a. Num a => FreeMonoid laws a -> a
sum :: FreeMonoid laws a -> a
$csum :: forall laws a. Num a => FreeMonoid laws a -> a
minimum :: FreeMonoid laws a -> a
$cminimum :: forall laws a. Ord a => FreeMonoid laws a -> a
maximum :: FreeMonoid laws a -> a
$cmaximum :: forall laws a. Ord a => FreeMonoid laws a -> a
elem :: a -> FreeMonoid laws a -> Bool
$celem :: forall laws a. Eq a => a -> FreeMonoid laws a -> Bool
length :: FreeMonoid laws a -> Int
$clength :: forall laws a. FreeMonoid laws a -> Int
null :: FreeMonoid laws a -> Bool
$cnull :: forall laws a. FreeMonoid laws a -> Bool
toList :: FreeMonoid laws a -> [a]
$ctoList :: forall laws a. FreeMonoid laws a -> [a]
foldl1 :: (a -> a -> a) -> FreeMonoid laws a -> a
$cfoldl1 :: forall laws a. (a -> a -> a) -> FreeMonoid laws a -> a
foldr1 :: (a -> a -> a) -> FreeMonoid laws a -> a
$cfoldr1 :: forall laws a. (a -> a -> a) -> FreeMonoid laws a -> a
foldl' :: (b -> a -> b) -> b -> FreeMonoid laws a -> b
$cfoldl' :: forall laws b a. (b -> a -> b) -> b -> FreeMonoid laws a -> b
foldl :: (b -> a -> b) -> b -> FreeMonoid laws a -> b
$cfoldl :: forall laws b a. (b -> a -> b) -> b -> FreeMonoid laws a -> b
foldr' :: (a -> b -> b) -> b -> FreeMonoid laws a -> b
$cfoldr' :: forall laws a b. (a -> b -> b) -> b -> FreeMonoid laws a -> b
foldr :: (a -> b -> b) -> b -> FreeMonoid laws a -> b
$cfoldr :: forall laws a b. (a -> b -> b) -> b -> FreeMonoid laws a -> b
foldMap' :: (a -> m) -> FreeMonoid laws a -> m
$cfoldMap' :: forall laws m a. Monoid m => (a -> m) -> FreeMonoid laws a -> m
foldMap :: (a -> m) -> FreeMonoid laws a -> m
$cfoldMap :: forall laws m a. Monoid m => (a -> m) -> FreeMonoid laws a -> m
fold :: FreeMonoid laws m -> m
$cfold :: forall laws m. Monoid m => FreeMonoid laws m -> m
Foldable, Int -> FreeMonoid laws a -> ShowS
[FreeMonoid laws a] -> ShowS
FreeMonoid laws a -> String
(Int -> FreeMonoid laws a -> ShowS)
-> (FreeMonoid laws a -> String)
-> ([FreeMonoid laws a] -> ShowS)
-> Show (FreeMonoid laws a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall laws a. Show a => Int -> FreeMonoid laws a -> ShowS
forall laws a. Show a => [FreeMonoid laws a] -> ShowS
forall laws a. Show a => FreeMonoid laws a -> String
showList :: [FreeMonoid laws a] -> ShowS
$cshowList :: forall laws a. Show a => [FreeMonoid laws a] -> ShowS
show :: FreeMonoid laws a -> String
$cshow :: forall laws a. Show a => FreeMonoid laws a -> String
showsPrec :: Int -> FreeMonoid laws a -> ShowS
$cshowsPrec :: forall laws a. Show a => Int -> FreeMonoid laws a -> ShowS
Show)

-- | Multiplicative monoid laws
--
-- > a * b is closed
-- > one * a = a
-- > a * one = a
-- > (a * b) * c = a * (b * c)
--
-- >>> one :: FreeMonoid MultMonoid Int
-- FreeMonoid {leaves = []}
--
--  ex1: (1 * 2) * (4 * 5) * 1
--
-- >>> let ex1 = Branch (Branch (Branch (Leaf 1) (Leaf 2)) (Branch (Leaf 4) (Leaf 5))) (Leaf 1)
--
-- >>> putStrLn $ printf (forget ex1 :: FreeMonoid MultMonoid Int)
-- (2*4*5)
--
-- >>> algebra (forget ex1 :: FreeMonoid MultMonoid Int)
-- 40
data MultMonoid

instance Multiplicative (FreeMonoid MultMonoid a) where
  one :: FreeMonoid MultMonoid a
one = [a] -> FreeMonoid MultMonoid a
forall laws a. [a] -> FreeMonoid laws a
FreeMonoid []

  -- times shuffles the ones out of the expression tree
  * :: FreeMonoid MultMonoid a
-> FreeMonoid MultMonoid a -> FreeMonoid MultMonoid a
(*) (FreeMonoid [a]
as) (FreeMonoid [a]
bs) = [a] -> FreeMonoid MultMonoid a
forall laws a. [a] -> FreeMonoid laws a
FreeMonoid ([a] -> FreeMonoid MultMonoid a) -> [a] -> FreeMonoid MultMonoid a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
rz [a]
as [a]
bs
    where
      -- quotienting (???)
      rz :: [a] -> [a] -> [a]
rz [] [a]
a = [a]
a
      rz [a]
a [] = [a]
a
      rz (a
x : [a]
xs) [a]
ys = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
rz [a]
xs [a]
ys

instance (Show a, Eq a, Multiplicative a) => FreeAlgebra (Tree NoLaws) (FreeMonoid MultMonoid) a where
  forget :: Tree NoLaws a -> FreeMonoid MultMonoid a
forget (Leaf a
a) = a -> FreeMonoid MultMonoid a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
a -> free a
lift a
a
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = Tree NoLaws a -> FreeMonoid MultMonoid a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a FreeMonoid MultMonoid a
-> FreeMonoid MultMonoid a -> FreeMonoid MultMonoid a
forall a. Multiplicative a => a -> a -> a
* Tree NoLaws a -> FreeMonoid MultMonoid a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b

  lift :: a -> FreeMonoid MultMonoid a
lift a
a = FreeMonoid MultMonoid a
-> FreeMonoid MultMonoid a -> Bool -> FreeMonoid MultMonoid a
forall a. a -> a -> Bool -> a
bool ([a] -> FreeMonoid MultMonoid a
forall laws a. [a] -> FreeMonoid laws a
FreeMonoid [a
Item [a]
a]) FreeMonoid MultMonoid a
forall a. Multiplicative a => a
one (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Multiplicative a => a
one)

  algebra :: FreeMonoid MultMonoid a -> a
algebra = (a -> a -> a) -> a -> FreeMonoid MultMonoid a -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> a -> a
forall a. Multiplicative a => a -> a -> a
(*) a
forall a. Multiplicative a => a
one

  printf :: FreeMonoid MultMonoid a -> Text
printf (FreeMonoid []) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show @a a
forall a. Multiplicative a => a
one
  printf (FreeMonoid [a]
ls) = Text -> [Text] -> Text
calate Text
"*" (a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ls)

-- | The Free commutative monoid is a Bag.
--
-- In addition to the forgetting needed for the free monoid, forgetting additions of zero and forgetting brackets, a commutative law means forgetting the order of the original expression structure.
--
-- A list that has lost it's order is sometimes referred to as a bag. An efficient representation of a bag is a (key,value) pair where the keys are elements in the initial expression and values are the number of times the element has occurred.
--
-- In the usual surface-paradox typical of adjointness, the forgetting of the ordering of the initial structure induces a requirement that the carrier type be ordered.
newtype Bag laws a = Bag {Bag laws a -> Map a Int
unbag :: Map.Map a Int} deriving (Bag laws a -> Bag laws a -> Bool
(Bag laws a -> Bag laws a -> Bool)
-> (Bag laws a -> Bag laws a -> Bool) -> Eq (Bag laws a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall laws a. Eq a => Bag laws a -> Bag laws a -> Bool
/= :: Bag laws a -> Bag laws a -> Bool
$c/= :: forall laws a. Eq a => Bag laws a -> Bag laws a -> Bool
== :: Bag laws a -> Bag laws a -> Bool
$c== :: forall laws a. Eq a => Bag laws a -> Bag laws a -> Bool
Eq, Eq (Bag laws a)
Eq (Bag laws a)
-> (Bag laws a -> Bag laws a -> Ordering)
-> (Bag laws a -> Bag laws a -> Bool)
-> (Bag laws a -> Bag laws a -> Bool)
-> (Bag laws a -> Bag laws a -> Bool)
-> (Bag laws a -> Bag laws a -> Bool)
-> (Bag laws a -> Bag laws a -> Bag laws a)
-> (Bag laws a -> Bag laws a -> Bag laws a)
-> Ord (Bag laws a)
Bag laws a -> Bag laws a -> Bool
Bag laws a -> Bag laws a -> Ordering
Bag laws a -> Bag laws a -> Bag laws a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall laws a. Ord a => Eq (Bag laws a)
forall laws a. Ord a => Bag laws a -> Bag laws a -> Bool
forall laws a. Ord a => Bag laws a -> Bag laws a -> Ordering
forall laws a. Ord a => Bag laws a -> Bag laws a -> Bag laws a
min :: Bag laws a -> Bag laws a -> Bag laws a
$cmin :: forall laws a. Ord a => Bag laws a -> Bag laws a -> Bag laws a
max :: Bag laws a -> Bag laws a -> Bag laws a
$cmax :: forall laws a. Ord a => Bag laws a -> Bag laws a -> Bag laws a
>= :: Bag laws a -> Bag laws a -> Bool
$c>= :: forall laws a. Ord a => Bag laws a -> Bag laws a -> Bool
> :: Bag laws a -> Bag laws a -> Bool
$c> :: forall laws a. Ord a => Bag laws a -> Bag laws a -> Bool
<= :: Bag laws a -> Bag laws a -> Bool
$c<= :: forall laws a. Ord a => Bag laws a -> Bag laws a -> Bool
< :: Bag laws a -> Bag laws a -> Bool
$c< :: forall laws a. Ord a => Bag laws a -> Bag laws a -> Bool
compare :: Bag laws a -> Bag laws a -> Ordering
$ccompare :: forall laws a. Ord a => Bag laws a -> Bag laws a -> Ordering
$cp1Ord :: forall laws a. Ord a => Eq (Bag laws a)
Ord, Int -> Bag laws a -> ShowS
[Bag laws a] -> ShowS
Bag laws a -> String
(Int -> Bag laws a -> ShowS)
-> (Bag laws a -> String)
-> ([Bag laws a] -> ShowS)
-> Show (Bag laws a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall laws a. Show a => Int -> Bag laws a -> ShowS
forall laws a. Show a => [Bag laws a] -> ShowS
forall laws a. Show a => Bag laws a -> String
showList :: [Bag laws a] -> ShowS
$cshowList :: forall laws a. Show a => [Bag laws a] -> ShowS
show :: Bag laws a -> String
$cshow :: forall laws a. Show a => Bag laws a -> String
showsPrec :: Int -> Bag laws a -> ShowS
$cshowsPrec :: forall laws a. Show a => Int -> Bag laws a -> ShowS
Show)

-- | This is a functor from Ord -> Ord but, sadly, not a functor from Hask -> Hask
mapBag :: (Ord b) => (a -> b) -> Bag laws a -> Bag laws b
mapBag :: (a -> b) -> Bag laws a -> Bag laws b
mapBag a -> b
f (Bag Map a Int
m) = Map b Int -> Bag laws b
forall laws a. Map a Int -> Bag laws a
Bag (Map b Int -> Bag laws b) -> Map b Int -> Bag laws b
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> (a -> b) -> Map a Int -> Map b Int
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith Int -> Int -> Int
forall a. Additive a => a -> a -> a
(+) a -> b
f Map a Int
m

-- toList . fromList /= id due to forgetfulness
-- but the interface is too ubiquitous to give up.
instance (Ord a, Subtractive a) => IsList (Bag AddCommGroup a) where
  type Item (Bag AddCommGroup a) = a

  toList :: Bag AddCommGroup a -> [Item (Bag AddCommGroup a)]
toList (Bag Map a Int
m) =
    [[a]] -> [a]
forall a. Monoid a => [a] -> a
mconcat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$
      ( \(a
k, Int
v) ->
          [a] -> [a] -> Bool -> [a]
forall a. a -> a -> Bool -> a
bool
            (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
v a
k)
            (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (Int -> Int
forall a. Subtractive a => a -> a
negate Int
v) (a -> a
forall a. Subtractive a => a -> a
negate a
k))
            (Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forall a. Additive a => a
zero)
      )
        ((a, Int) -> [a]) -> [(a, Int)] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a Int -> [(a, Int)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a Int
m

  fromList :: [Item (Bag AddCommGroup a)] -> Bag AddCommGroup a
fromList [Item (Bag AddCommGroup a)]
l =
    Map a Int -> Bag AddCommGroup a
forall laws a. Map a Int -> Bag laws a
Bag
      (Map a Int -> Bag AddCommGroup a)
-> Map a Int -> Bag AddCommGroup a
forall a b. (a -> b) -> a -> b
$ (Map a Int, Map a Int) -> Map a Int
forall a b. (a, b) -> b
snd
      ((Map a Int, Map a Int) -> Map a Int)
-> (Map a Int, Map a Int) -> Map a Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Map a Int -> (Map a Int, Map a Int)
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Additive a => a
zero)
      (Map a Int -> (Map a Int, Map a Int))
-> Map a Int -> (Map a Int, Map a Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> [(a, Int)] -> Map a Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Additive a => a -> a -> a
(+)
      ([(a, Int)] -> Map a Int) -> [(a, Int)] -> Map a Int
forall a b. (a -> b) -> a -> b
$ (\a
e -> (a, Int) -> (a, Int) -> Bool -> (a, Int)
forall a. a -> a -> Bool -> a
bool (a
e, Int
1) (a -> a
forall a. Subtractive a => a -> a
negate a
e, -Int
1) (a
e a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
forall a. Additive a => a
zero)) (a -> (a, Int)) -> [a] -> [(a, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
[Item (Bag AddCommGroup a)]
l

-- | Additive Commutative Group Laws
--
-- > a + b is closed
-- > zero + a = a
-- > a + zero = a
-- > (a + b) + c = a + (b + c)
-- > a + b == b + a
-- > a + negate a = zero
--
-- Adding invertibility to the list of laws for a commutative monoid gets us to the definition of a Commutative (or Abelian) Group.
--
-- Invertible (in combination with commutation) means forgetting a value when the inversion of the value is contained somewhere within the expression. For example, armed with a definition of what a negative number is, integer addition such as:
--
-- > 1+2+3+-1+-4+2
--
-- Can be represented as a bag of 2 2's, one 3 and minus one 4's.
--
-- >>> let exbag = fromList [1,2,3,-1,-4,-2] :: Bag AddCommGroup Int
-- >>> exbag
-- Bag {unbag = fromList [(3,1),(4,-1)]}
--
-- >>> toList exbag
-- [3,-4]
--
-- >>> exAdd = toTreeL [0,1,2,3,0,-1,-4,-2,0]
-- >>> putStrLn $ printf (forget exAdd :: Bag AddCommGroup Int)
-- (3+-4)
data AddCommGroup

instance (Ord a) => Additive (Bag AddCommGroup a) where
  zero :: Bag AddCommGroup a
zero = Map a Int -> Bag AddCommGroup a
forall laws a. Map a Int -> Bag laws a
Bag Map a Int
forall k a. Map k a
Map.empty

  + :: Bag AddCommGroup a -> Bag AddCommGroup a -> Bag AddCommGroup a
(+) (Bag Map a Int
a) (Bag Map a Int
b) =
    Map a Int -> Bag AddCommGroup a
forall laws a. Map a Int -> Bag laws a
Bag
      (Map a Int -> Bag AddCommGroup a)
-> Map a Int -> Bag AddCommGroup a
forall a b. (a -> b) -> a -> b
$ (Map a Int, Map a Int) -> Map a Int
forall a b. (a, b) -> b
snd
      ((Map a Int, Map a Int) -> Map a Int)
-> (Map a Int, Map a Int) -> Map a Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Map a Int -> (Map a Int, Map a Int)
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Additive a => a
zero)
      (Map a Int -> (Map a Int, Map a Int))
-> Map a Int -> (Map a Int, Map a Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> Map a Int -> Map a Int -> Map a Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Int -> Int -> Int
forall a. Additive a => a -> a -> a
(+) Map a Int
a Map a Int
b

instance (Ord a) => Subtractive (Bag AddCommGroup a) where
  negate :: Bag AddCommGroup a -> Bag AddCommGroup a
negate (Bag Map a Int
m) = Map a Int -> Bag AddCommGroup a
forall laws a. Map a Int -> Bag laws a
Bag (Map a Int -> Bag AddCommGroup a)
-> Map a Int -> Bag AddCommGroup a
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Map a Int -> Map a Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Int -> Int
forall a. Subtractive a => a -> a
negate Map a Int
m

instance (Show a, Eq a, Ord a, Subtractive a) => FreeAlgebra (Tree NoLaws) (Bag AddCommGroup) a where
  forget :: Tree NoLaws a -> Bag AddCommGroup a
forget (Leaf a
a) = a -> Bag AddCommGroup a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
a -> free a
lift a
a
  forget (Branch Tree NoLaws a
a Tree NoLaws a
b) = Tree NoLaws a -> Bag AddCommGroup a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
a Bag AddCommGroup a -> Bag AddCommGroup a -> Bag AddCommGroup a
forall a. Additive a => a -> a -> a
+ Tree NoLaws a -> Bag AddCommGroup a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Tree NoLaws a
b

  lift :: a -> Bag AddCommGroup a
lift a
a
    | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Additive a => a
zero = Bag AddCommGroup a
forall a. Additive a => a
zero
    | a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
forall a. Additive a => a
zero = Map a Int -> Bag AddCommGroup a
forall laws a. Map a Int -> Bag laws a
Bag (a -> Int -> Map a Int
forall k a. k -> a -> Map k a
Map.singleton (a -> a
forall a. Subtractive a => a -> a
negate a
a) (-Int
1))
    | Bool
otherwise = Map a Int -> Bag AddCommGroup a
forall laws a. Map a Int -> Bag laws a
Bag (Map a Int -> Bag AddCommGroup a)
-> Map a Int -> Bag AddCommGroup a
forall a b. (a -> b) -> a -> b
$ a -> Int -> Map a Int
forall k a. k -> a -> Map k a
Map.singleton a
a Int
1

  algebra :: Bag AddCommGroup a -> a
algebra (Bag Map a Int
m) =
    (a -> Int -> a -> a) -> a -> Map a Int -> a
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
      ( \a
k Int
v a
acc ->
          ((a -> a) -> a -> a) -> a -> [a -> a] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
($) a
acc (Int -> (a -> a) -> [a -> a]
forall a. Int -> a -> [a]
replicate Int
v (a
k a -> a -> a
forall a. Additive a => a -> a -> a
+))
      )
      a
forall a. Additive a => a
zero
      Map a Int
m

  printf :: Bag AddCommGroup a -> Text
printf Bag AddCommGroup a
b =
    Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool
      (Text -> [Text] -> Text
calate Text
"+" (a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bag AddCommGroup a -> [Item (Bag AddCommGroup a)]
forall l. IsList l => l -> [Item l]
toList Bag AddCommGroup a
b))
      (a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show @a a
forall a. Additive a => a
zero)
      (Bag AddCommGroup a
b Bag AddCommGroup a -> Bag AddCommGroup a -> Bool
forall a. Eq a => a -> a -> Bool
== Bag AddCommGroup a
forall a. Additive a => a
zero)

-- | Ring Laws
--
-- > a + b is closed
-- > zero + a = a
-- > a + zero = a
-- > (a + b) + c = a + (b + c)
-- > a + b == b + a
-- > a + negate a = zero
-- > a * b is closed
-- > one * a = a
-- > a * one = a
-- > (a * b) * c = a * (b * c)
-- > a * zero = zero
-- > zero * a = zero
-- > a * (b + c) = (a * b) + (a * c)
-- > (b + c) * a = (b * a) + (c * a)
data RingLaws

-- | Where an algebra involves two (or more) operators, the initial structure (the expression) is arrived at by grafting new types of branches using sum types.
data Exp a
  = Value a
  | Add (Exp a) (Exp a)
  | Mult (Exp a) (Exp a)
  deriving (Exp a -> Exp a -> Bool
(Exp a -> Exp a -> Bool) -> (Exp a -> Exp a -> Bool) -> Eq (Exp a)
forall a. Eq a => Exp a -> Exp a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exp a -> Exp a -> Bool
$c/= :: forall a. Eq a => Exp a -> Exp a -> Bool
== :: Exp a -> Exp a -> Bool
$c== :: forall a. Eq a => Exp a -> Exp a -> Bool
Eq, Eq (Exp a)
Eq (Exp a)
-> (Exp a -> Exp a -> Ordering)
-> (Exp a -> Exp a -> Bool)
-> (Exp a -> Exp a -> Bool)
-> (Exp a -> Exp a -> Bool)
-> (Exp a -> Exp a -> Bool)
-> (Exp a -> Exp a -> Exp a)
-> (Exp a -> Exp a -> Exp a)
-> Ord (Exp a)
Exp a -> Exp a -> Bool
Exp a -> Exp a -> Ordering
Exp a -> Exp a -> Exp a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Exp a)
forall a. Ord a => Exp a -> Exp a -> Bool
forall a. Ord a => Exp a -> Exp a -> Ordering
forall a. Ord a => Exp a -> Exp a -> Exp a
min :: Exp a -> Exp a -> Exp a
$cmin :: forall a. Ord a => Exp a -> Exp a -> Exp a
max :: Exp a -> Exp a -> Exp a
$cmax :: forall a. Ord a => Exp a -> Exp a -> Exp a
>= :: Exp a -> Exp a -> Bool
$c>= :: forall a. Ord a => Exp a -> Exp a -> Bool
> :: Exp a -> Exp a -> Bool
$c> :: forall a. Ord a => Exp a -> Exp a -> Bool
<= :: Exp a -> Exp a -> Bool
$c<= :: forall a. Ord a => Exp a -> Exp a -> Bool
< :: Exp a -> Exp a -> Bool
$c< :: forall a. Ord a => Exp a -> Exp a -> Bool
compare :: Exp a -> Exp a -> Ordering
$ccompare :: forall a. Ord a => Exp a -> Exp a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Exp a)
Ord, Int -> Exp a -> ShowS
[Exp a] -> ShowS
Exp a -> String
(Int -> Exp a -> ShowS)
-> (Exp a -> String) -> ([Exp a] -> ShowS) -> Show (Exp a)
forall a. Show a => Int -> Exp a -> ShowS
forall a. Show a => [Exp a] -> ShowS
forall a. Show a => Exp a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exp a] -> ShowS
$cshowList :: forall a. Show a => [Exp a] -> ShowS
show :: Exp a -> String
$cshow :: forall a. Show a => Exp a -> String
showsPrec :: Int -> Exp a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Exp a -> ShowS
Show, a -> Exp b -> Exp a
(a -> b) -> Exp a -> Exp b
(forall a b. (a -> b) -> Exp a -> Exp b)
-> (forall a b. a -> Exp b -> Exp a) -> Functor Exp
forall a b. a -> Exp b -> Exp a
forall a b. (a -> b) -> Exp a -> Exp b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Exp b -> Exp a
$c<$ :: forall a b. a -> Exp b -> Exp a
fmap :: (a -> b) -> Exp a -> Exp b
$cfmap :: forall a b. (a -> b) -> Exp a -> Exp b
Functor)

instance (Show a, Eq a, Ring a, Magma a) => FreeAlgebra Exp Exp a where
  forget :: Exp a -> Exp a
forget = Exp a -> Exp a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

  lift :: a -> Exp a
lift = a -> Exp a
forall a. a -> Exp a
Value

  algebra :: Exp a -> a
algebra (Value a
a) = a
a
  algebra (Add Exp a
a Exp a
b) = Exp a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Exp a
a a -> a -> a
forall a. Additive a => a -> a -> a
+ Exp a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Exp a
b
  algebra (Mult Exp a
a Exp a
b) = Exp a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Exp a
a a -> a -> a
forall a. Multiplicative a => a -> a -> a
* Exp a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra Exp a
b

  printf :: Exp a -> Text
printf (Value a
a) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
a
  printf (Mult Exp a
a Exp a
b) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Exp a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Exp a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Exp a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Exp a
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  printf (Add Exp a
a Exp a
b) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Exp a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Exp a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Exp a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf Exp a
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | The free ring is a recursive sequence of bags.
--
-- Given multiplication is monoidal (with the free object a list) and addition is a commutative group (with the free object a bag), it seems intuitively the case that the free object for a ring is a recursive list of bags. It is recursive because the ordering of +'s and *'s does not reduce, so that the tree-like nature of the expression is not forgotten.
--
-- Abstractly, the choice of what goes in what should be an arbitrary one; the free object could also be a (recursive) bag of lists. The addition collection structure feels like it should be within the multiplication structure, however, because of the distribution law equivalence that need to be honoured in the representation:
--
-- > a ⋅ (b + c) = (a · b) + (a · c)
-- > (b + c) · a = (b · a) + (c · a)
--
-- It is likely, in most endeavours, that multiplication is more expensive than addition, and the left hand side of these equations have less multiplications.
--
-- Because the distribution laws are substitutions to both the left and the right, use of 'Seq' is indicated instead of a list (which is isomorphic to a list and thus allowed as an alternative).
--
-- The free ring is the same general shape as the free monad in the [free](https://hackage.haskell.org/package/free-5.1.4/docs/Control-Monad-Free.html) library
--
-- > data Free f a = Pure a | Free (f (Free f a))
--
-- which in turn is almost the same shape as Fix eg
--
-- > newtype Fix f = Fix (f (Fix f))
--
-- If Bag could form a Functor instance, then the Free Ring could be expressed as @'Control.Monad.Free.Free' ('Compose' 'Bag' 'Seq') a@
--
-- which is a very clean result.
data FreeRing laws a
  = FreeV a
  | FreeR (Seq (Bag AddCommGroup (FreeRing laws a)))
  deriving (FreeRing laws a -> FreeRing laws a -> Bool
(FreeRing laws a -> FreeRing laws a -> Bool)
-> (FreeRing laws a -> FreeRing laws a -> Bool)
-> Eq (FreeRing laws a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall laws a. Eq a => FreeRing laws a -> FreeRing laws a -> Bool
/= :: FreeRing laws a -> FreeRing laws a -> Bool
$c/= :: forall laws a. Eq a => FreeRing laws a -> FreeRing laws a -> Bool
== :: FreeRing laws a -> FreeRing laws a -> Bool
$c== :: forall laws a. Eq a => FreeRing laws a -> FreeRing laws a -> Bool
Eq, Eq (FreeRing laws a)
Eq (FreeRing laws a)
-> (FreeRing laws a -> FreeRing laws a -> Ordering)
-> (FreeRing laws a -> FreeRing laws a -> Bool)
-> (FreeRing laws a -> FreeRing laws a -> Bool)
-> (FreeRing laws a -> FreeRing laws a -> Bool)
-> (FreeRing laws a -> FreeRing laws a -> Bool)
-> (FreeRing laws a -> FreeRing laws a -> FreeRing laws a)
-> (FreeRing laws a -> FreeRing laws a -> FreeRing laws a)
-> Ord (FreeRing laws a)
FreeRing laws a -> FreeRing laws a -> Bool
FreeRing laws a -> FreeRing laws a -> Ordering
FreeRing laws a -> FreeRing laws a -> FreeRing laws a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall laws a. Ord a => Eq (FreeRing laws a)
forall laws a. Ord a => FreeRing laws a -> FreeRing laws a -> Bool
forall laws a.
Ord a =>
FreeRing laws a -> FreeRing laws a -> Ordering
forall laws a.
Ord a =>
FreeRing laws a -> FreeRing laws a -> FreeRing laws a
min :: FreeRing laws a -> FreeRing laws a -> FreeRing laws a
$cmin :: forall laws a.
Ord a =>
FreeRing laws a -> FreeRing laws a -> FreeRing laws a
max :: FreeRing laws a -> FreeRing laws a -> FreeRing laws a
$cmax :: forall laws a.
Ord a =>
FreeRing laws a -> FreeRing laws a -> FreeRing laws a
>= :: FreeRing laws a -> FreeRing laws a -> Bool
$c>= :: forall laws a. Ord a => FreeRing laws a -> FreeRing laws a -> Bool
> :: FreeRing laws a -> FreeRing laws a -> Bool
$c> :: forall laws a. Ord a => FreeRing laws a -> FreeRing laws a -> Bool
<= :: FreeRing laws a -> FreeRing laws a -> Bool
$c<= :: forall laws a. Ord a => FreeRing laws a -> FreeRing laws a -> Bool
< :: FreeRing laws a -> FreeRing laws a -> Bool
$c< :: forall laws a. Ord a => FreeRing laws a -> FreeRing laws a -> Bool
compare :: FreeRing laws a -> FreeRing laws a -> Ordering
$ccompare :: forall laws a.
Ord a =>
FreeRing laws a -> FreeRing laws a -> Ordering
$cp1Ord :: forall laws a. Ord a => Eq (FreeRing laws a)
Ord, Int -> FreeRing laws a -> ShowS
[FreeRing laws a] -> ShowS
FreeRing laws a -> String
(Int -> FreeRing laws a -> ShowS)
-> (FreeRing laws a -> String)
-> ([FreeRing laws a] -> ShowS)
-> Show (FreeRing laws a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall laws a. Show a => Int -> FreeRing laws a -> ShowS
forall laws a. Show a => [FreeRing laws a] -> ShowS
forall laws a. Show a => FreeRing laws a -> String
showList :: [FreeRing laws a] -> ShowS
$cshowList :: forall laws a. Show a => [FreeRing laws a] -> ShowS
show :: FreeRing laws a -> String
$cshow :: forall laws a. Show a => FreeRing laws a -> String
showsPrec :: Int -> FreeRing laws a -> ShowS
$cshowsPrec :: forall laws a. Show a => Int -> FreeRing laws a -> ShowS
Show)

-- | Parse an Exp, forget to the free object structure and print.
--
-- >>> let t1 = "(4*(1+3)+(3+1)+6*(4+5*(11+6)*(3+2)))+(7+3+11*2)"
-- >>> putStrLn $ freeExp t1
-- (1+3+3+7+(4*(1+3))+(6*(4+(5*(6+11)*(2+3))))+(11*2))
freeExp :: Text -> Text
freeExp :: Text -> Text
freeExp Text
t = FreeRing RingLaws Int -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf (Exp Int -> FreeRing RingLaws Int
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget (Text -> Exp Int
parseExp Text
t) :: FreeRing RingLaws Int)

-- | informal test suite
--
-- empty expression
--
-- >>> freeExp "0"
-- "0"
--
-- plain (with multiplicative precedence)
--
-- >>> forget $ parseExp "1+2*3" :: FreeRing RingLaws Int
-- FreeR (fromList [Bag {unbag = fromList [(FreeV 1,1),(FreeR (fromList [Bag {unbag = fromList [(FreeV 2,1)]},Bag {unbag = fromList [(FreeV 3,1)]}]),1)]}])
--
-- >>> freeExp "1+2*3"
-- "(1+(2*3))"
--
-- Additive unital
--
-- >>> freeExp "0+(2+0)*3+0"
-- "(2*3)"
--
-- General additive associative and commutation
--
-- >>> freeExp "(1+2)*3+(4+5)+6*7"
-- "(4+5+((1+2)*3)+(6*7))"
--
-- Multiplicative unital
--
-- >>> freeExp "1*3+4*1+1*(5*6)"
-- "(3+4+(5*6))"
--
-- Multiplicative association (not commutative)
--
-- >>> freeExp "(2*6)*((4*5)*2)"
-- "(2*6*4*5*2)"
--
-- absorptive
--
-- >>> freeExp "0*1+3*(3+4)*0"
-- "0"
--
-- additive invertible
--
-- >>> freeExp "(1+2)+(-1+-2)"
-- "0"
--
-- distribution
--
-- > a ⋅ (b + c) = (a · b) + (a · c)
-- > (b + c) · a = (b · a) + (c · a)
--
-- left
--
-- >>> freeExp "2*(3+4)+2*5+2*6"
-- "(2*(3+4+5+6))"
--
-- right
--
-- >>> freeExp "(3+4)*2+5*2+6*2"
-- "((3+4+5+6)*2)"
--
-- mixed (left then right checks)
--
-- >>> freeExp "2*(3+4)*2+5*2+2*6*2"
-- "((5+(2*(3+4))+(2*6))*2)"
--
-- Note that @(2*(3+4+6)*2+5*2)@ is a valid alternative to what the current 'FreeRing' 'forget' function comes up with.
--
-- == TODO: optional extras:
--
-- - If +one is faster than +a
--
-- > (a . b) + a ==> a . (b + one)
--
-- - If a is scalar ...
--
-- lifting an (additive bag) to a multiplication sequence
--
-- > 3+3+3+3 ==> 3*4
--
-- - introducing exponents
--
-- > 3*3*3*3 ==> 3^4
data InformalTests

-- | Single bag a value
bagV :: (Ord a, Subtractive a) => a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV :: a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
a
  | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Additive a => a
zero = Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a
zero
  | a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
forall a. Additive a => a
zero = Map (FreeRing RingLaws a) Int
-> Bag AddCommGroup (FreeRing RingLaws a)
forall laws a. Map a Int -> Bag laws a
Bag (FreeRing RingLaws a -> Int -> Map (FreeRing RingLaws a) Int
forall k a. k -> a -> Map k a
Map.singleton (a -> FreeRing RingLaws a
forall laws a. a -> FreeRing laws a
FreeV (a -> FreeRing RingLaws a) -> a -> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Subtractive a => a -> a
negate a
a) (-Int
1))
  | Bool
otherwise = Map (FreeRing RingLaws a) Int
-> Bag AddCommGroup (FreeRing RingLaws a)
forall laws a. Map a Int -> Bag laws a
Bag (Map (FreeRing RingLaws a) Int
 -> Bag AddCommGroup (FreeRing RingLaws a))
-> Map (FreeRing RingLaws a) Int
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a b. (a -> b) -> a -> b
$ FreeRing RingLaws a -> Int -> Map (FreeRing RingLaws a) Int
forall k a. k -> a -> Map k a
Map.singleton (a -> FreeRing RingLaws a
forall laws a. a -> FreeRing laws a
FreeV a
a) Int
1

-- | Single bag a FreeRing
bagR :: (Ord a) => FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR :: FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR FreeRing RingLaws a
a
  | FreeRing RingLaws a
a FreeRing RingLaws a -> FreeRing RingLaws a -> Bool
forall a. Eq a => a -> a -> Bool
== Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty = Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a
zero
  | Bool
otherwise = Map (FreeRing RingLaws a) Int
-> Bag AddCommGroup (FreeRing RingLaws a)
forall laws a. Map a Int -> Bag laws a
Bag (Map (FreeRing RingLaws a) Int
 -> Bag AddCommGroup (FreeRing RingLaws a))
-> Map (FreeRing RingLaws a) Int
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a b. (a -> b) -> a -> b
$ FreeRing RingLaws a -> Int -> Map (FreeRing RingLaws a) Int
forall k a. k -> a -> Map k a
Map.singleton FreeRing RingLaws a
a Int
1

instance (Eq a, Ord a, Subtractive a, Multiplicative a) => Multiplicative (FreeRing RingLaws a) where
  one :: FreeRing RingLaws a
one = a -> FreeRing RingLaws a
forall laws a. a -> FreeRing laws a
FreeV a
forall a. Multiplicative a => a
one

  -- absorption law
  * :: FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
(*) FreeRing RingLaws a
_ (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty) = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty
  (*) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty) FreeRing RingLaws a
_ = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty
  -- multiplicative unital
  (*) (FreeV a
vl) (FreeV a
vr)
    | a
vl a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Multiplicative a => a
one = a -> FreeRing RingLaws a
forall laws a. a -> FreeRing laws a
FreeV a
vr
    | a
vr a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Multiplicative a => a
one = a -> FreeRing RingLaws a
forall laws a. a -> FreeRing laws a
FreeV a
vl
    | Bool
otherwise = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
vl Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a -> Seq a
<| a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
vr Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a -> Seq a
<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty)
  -- multiplicative unital
  (*) (FreeV a
v) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs) =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> (Seq (Bag AddCommGroup (FreeRing RingLaws a))
    -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bool
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> a -> Bool -> a
bool (a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
v Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a -> Seq a
<|) Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Multiplicative a => a
one) Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs
  (*) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs) (FreeV a
v) =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> (Seq (Bag AddCommGroup (FreeRing RingLaws a))
    -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bool
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> a -> Bool -> a
bool (Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a -> a -> Seq a
|> a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
v) Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Multiplicative a => a
one) Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs
  (*) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
as) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs) = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Seq (Bag AddCommGroup (FreeRing RingLaws a))
as Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Semigroup a => a -> a -> a
<> Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs

instance forall (a :: Type). (Ord a, Ring a) => Additive (FreeRing RingLaws a) where
  zero :: FreeRing RingLaws a
zero = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty

  -- additive unital guards
  + :: FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
(+) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty) FreeRing RingLaws a
a = FreeRing RingLaws a
a
  (+) FreeRing RingLaws a
a (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty) = FreeRing RingLaws a
a
  -- invertible check
  (+) (FreeV a
vl) (FreeV a
vr) =
    FreeRing RingLaws a
-> FreeRing RingLaws a -> Bool -> FreeRing RingLaws a
forall a. a -> a -> Bool -> a
bool
      (Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
vl Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
vr)
      (Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty)
      (a
vl a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Subtractive a => a -> a
negate a
vr)
  -- add another additive element to a (single-element list) bag
  (+) (FreeV a
v) (FreeR (Bag AddCommGroup (FreeRing RingLaws a)
b :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty)) = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
v Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ Bag AddCommGroup (FreeRing RingLaws a)
b
  (+) (FreeR (Bag AddCommGroup (FreeRing RingLaws a)
b :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty)) (FreeV a
v) = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
v Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ Bag AddCommGroup (FreeRing RingLaws a)
b
  -- multiplication expression being added to so
  -- create a new addition branch
  (+) (FreeV a
v) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs) =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$
      a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
v Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR (Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs)
  (+) (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs) (FreeV a
v) =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$
      a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
(Ord a, Subtractive a) =>
a -> Bag AddCommGroup (FreeRing RingLaws a)
bagV a
v Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR (Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs)
  (+) (FreeR (Bag AddCommGroup (FreeRing RingLaws a)
a :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty)) (FreeR (Bag AddCommGroup (FreeRing RingLaws a)
b :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty)) =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
a Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ Bag AddCommGroup (FreeRing RingLaws a)
b
  (+) FreeRing RingLaws a
as (FreeR (Bag AddCommGroup (FreeRing RingLaws a)
b :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty)) =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR FreeRing RingLaws a
as Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ Bag AddCommGroup (FreeRing RingLaws a)
b
  (+) (FreeR (Bag AddCommGroup (FreeRing RingLaws a)
a :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty)) FreeRing RingLaws a
bs =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR FreeRing RingLaws a
bs Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ Bag AddCommGroup (FreeRing RingLaws a)
a
  -- distributive
  -- > (a · as') + (a · bs') ==> a ⋅ (as' + bs')
  -- > (ras' . ra) + (rbs' . ra) ==> (ras' + rbs') . ra
  -- left-biased checking
  (+) f :: FreeRing RingLaws a
f@(FreeR ((Bag AddCommGroup (FreeRing RingLaws a)
al :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
as') :|> Bag AddCommGroup (FreeRing RingLaws a)
ar)) f' :: FreeRing RingLaws a
f'@(FreeR ((Bag AddCommGroup (FreeRing RingLaws a)
bl :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs') :|> Bag AddCommGroup (FreeRing RingLaws a)
br))
    | Bag AddCommGroup (FreeRing RingLaws a)
al Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a) -> Bool
forall a. Eq a => a -> a -> Bool
== Bag AddCommGroup (FreeRing RingLaws a)
bl = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton Bag AddCommGroup (FreeRing RingLaws a)
al) FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
forall a. Multiplicative a => a -> a -> a
* (Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
as' Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a -> a -> Seq a
:|> Bag AddCommGroup (FreeRing RingLaws a)
ar) FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
forall a. Additive a => a -> a -> a
+ Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs' Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a -> a -> Seq a
:|> Bag AddCommGroup (FreeRing RingLaws a)
br))
    | Bag AddCommGroup (FreeRing RingLaws a)
ar Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a) -> Bool
forall a. Eq a => a -> a -> Bool
== Bag AddCommGroup (FreeRing RingLaws a)
br = (Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Bag AddCommGroup (FreeRing RingLaws a)
al Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a -> Seq a
:<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
as') FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
forall a. Additive a => a -> a -> a
+ Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Bag AddCommGroup (FreeRing RingLaws a)
bl Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a -> Seq a
:<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs')) FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
forall a. Multiplicative a => a -> a -> a
* Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton Bag AddCommGroup (FreeRing RingLaws a)
ar)
    | Bool
otherwise =
      Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR FreeRing RingLaws a
f Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR FreeRing RingLaws a
f'
  (+) FreeRing RingLaws a
a FreeRing RingLaws a
b = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Bag AddCommGroup (FreeRing RingLaws a)
 -> Seq (Bag AddCommGroup (FreeRing RingLaws a)))
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a b. (a -> b) -> a -> b
$ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR FreeRing RingLaws a
a Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a -> a -> a
+ FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
forall a.
Ord a =>
FreeRing RingLaws a -> Bag AddCommGroup (FreeRing RingLaws a)
bagR FreeRing RingLaws a
b

instance (Show a, Ord a, Ring a) => Subtractive (FreeRing RingLaws a) where
  negate :: FreeRing RingLaws a -> FreeRing RingLaws a
negate (FreeV a
a) = a -> FreeRing RingLaws a
forall laws a. a -> FreeRing laws a
FreeV (a -> a
forall a. Subtractive a => a -> a
negate a
a)
  negate (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty) = Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty
  -- no multiply, negate everything in the bag
  negate (FreeR ((Bag Map (FreeRing RingLaws a) Int
m) :<| Seq (Bag AddCommGroup (FreeRing RingLaws a))
xs)) =
    Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR (Seq (Bag AddCommGroup (FreeRing RingLaws a))
 -> FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> FreeRing RingLaws a
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. a -> Seq a
Seq.singleton (Map (FreeRing RingLaws a) Int
-> Bag AddCommGroup (FreeRing RingLaws a)
forall laws a. Map a Int -> Bag laws a
Bag (Map (FreeRing RingLaws a) Int
 -> Bag AddCommGroup (FreeRing RingLaws a))
-> Map (FreeRing RingLaws a) Int
-> Bag AddCommGroup (FreeRing RingLaws a)
forall a b. (a -> b) -> a -> b
$ (Int -> Int)
-> Map (FreeRing RingLaws a) Int -> Map (FreeRing RingLaws a) Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Int -> Int
forall a. Subtractive a => a -> a
negate Map (FreeRing RingLaws a) Int
m) Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
-> Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Semigroup a => a -> a -> a
<> Seq (Bag AddCommGroup (FreeRing RingLaws a))
xs

instance (Show a, Eq a, Ord a, Ring a) => FreeAlgebra Exp (FreeRing RingLaws) a where
  forget :: Exp a -> FreeRing RingLaws a
forget (Value a
a) = a -> FreeRing RingLaws a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
a -> free a
lift a
a
  forget (Add Exp a
a Exp a
b) = Exp a -> FreeRing RingLaws a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Exp a
a FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
forall a. Additive a => a -> a -> a
+ Exp a -> FreeRing RingLaws a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Exp a
b
  forget (Mult Exp a
a Exp a
b) = Exp a -> FreeRing RingLaws a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Exp a
a FreeRing RingLaws a -> FreeRing RingLaws a -> FreeRing RingLaws a
forall a. Multiplicative a => a -> a -> a
* Exp a -> FreeRing RingLaws a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
initial a -> free a
forget Exp a
b

  lift :: a -> FreeRing RingLaws a
lift a
a = FreeRing RingLaws a
-> FreeRing RingLaws a -> Bool -> FreeRing RingLaws a
forall a. a -> a -> Bool -> a
bool (a -> FreeRing RingLaws a
forall laws a. a -> FreeRing laws a
FreeV a
a) (Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> FreeRing RingLaws a
forall laws a.
Seq (Bag AddCommGroup (FreeRing laws a)) -> FreeRing laws a
FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
forall a. Seq a
Empty) (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Additive a => a
zero)

  algebra :: FreeRing RingLaws a -> a
algebra (FreeV a
a) = a
a
  algebra (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty) = a
forall a. Additive a => a
zero
  algebra (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
xs) = (a -> a -> a) -> a -> Seq a -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> a -> a
forall a. Multiplicative a => a -> a -> a
(*) a
forall a. Multiplicative a => a
one (FreeRing RingLaws a -> a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra (FreeRing RingLaws a -> a)
-> (Bag AddCommGroup (FreeRing RingLaws a) -> FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a)
-> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bag AddCommGroup (FreeRing RingLaws a) -> FreeRing RingLaws a
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> a
algebra (Bag AddCommGroup (FreeRing RingLaws a) -> a)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> Seq a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Bag AddCommGroup (FreeRing RingLaws a))
xs)

  printf :: FreeRing RingLaws a -> Text
printf (FreeV a
v) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show a
v
  printf (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
Empty) = a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show @a (Additive a => a
forall a. Additive a => a
zero @a)
  printf (FreeR Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs) = Text -> [Text] -> Text
calate Text
"*" (Seq Text -> [Item (Seq Text)]
forall l. IsList l => l -> [Item l]
toList (Seq Text -> [Item (Seq Text)]) -> Seq Text -> [Item (Seq Text)]
forall a b. (a -> b) -> a -> b
$ Bag AddCommGroup (FreeRing RingLaws a) -> Text
printBagFreeR (Bag AddCommGroup (FreeRing RingLaws a) -> Text)
-> Seq (Bag AddCommGroup (FreeRing RingLaws a)) -> Seq Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Bag AddCommGroup (FreeRing RingLaws a))
bs)
    where
      printBagFreeR :: Bag AddCommGroup (FreeRing RingLaws a) -> Text
printBagFreeR Bag AddCommGroup (FreeRing RingLaws a)
b =
        Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool
          (Text -> [Text] -> Text
calate Text
"+" (FreeRing RingLaws a -> Text
forall (initial :: * -> *) (free :: * -> *) a.
FreeAlgebra initial free a =>
free a -> Text
printf (FreeRing RingLaws a -> Text) -> [FreeRing RingLaws a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bag AddCommGroup (FreeRing RingLaws a)
-> [Item (Bag AddCommGroup (FreeRing RingLaws a))]
forall l. IsList l => l -> [Item l]
toList Bag AddCommGroup (FreeRing RingLaws a)
b))
          (a -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show @a a
forall a. Additive a => a
zero)
          (Bag AddCommGroup (FreeRing RingLaws a)
b Bag AddCommGroup (FreeRing RingLaws a)
-> Bag AddCommGroup (FreeRing RingLaws a) -> Bool
forall a. Eq a => a -> a -> Bool
== Bag AddCommGroup (FreeRing RingLaws a)
forall a. Additive a => a
zero)

-- expression parsing helpers
data BadExpParse = BadExpParse deriving (Int -> BadExpParse -> ShowS
[BadExpParse] -> ShowS
BadExpParse -> String
(Int -> BadExpParse -> ShowS)
-> (BadExpParse -> String)
-> ([BadExpParse] -> ShowS)
-> Show BadExpParse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BadExpParse] -> ShowS
$cshowList :: [BadExpParse] -> ShowS
show :: BadExpParse -> String
$cshow :: BadExpParse -> String
showsPrec :: Int -> BadExpParse -> ShowS
$cshowsPrec :: Int -> BadExpParse -> ShowS
Show)

instance Exception BadExpParse

-- | Text parser for an expression. Parenthesis is imputed assuming multiplicative precedence and left-to-right default association.
--
-- > let t1 = "(4*(1+3)+(3+1)+6*(4+5*(11+6)*(3+2)))+(7+3+11*2)"
-- > putStrLn . printf . parseExp $ t1
-- ((((4*(1+3))+(3+1))+(6*(4+((5*(11+6))*(3+2)))))+((7+3)+(11*2)))
parseExp :: Text -> Exp Int
parseExp :: Text -> Exp Int
parseExp Text
t = (String -> Exp Int)
-> (Exp Int -> Exp Int) -> Either String (Exp Int) -> Exp Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (BadExpParse -> String -> Exp Int
forall a e. Exception e => e -> a
throw BadExpParse
BadExpParse) Exp Int -> Exp Int
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Either String (Exp Int) -> Exp Int)
-> Either String (Exp Int) -> Exp Int
forall a b. (a -> b) -> a -> b
$ Parser (Exp Int) -> Text -> Either String (Exp Int)
forall a. Parser a -> Text -> Either String a
A.parseOnly Parser (Exp Int)
expr Text
t

-- | Exp parser
-- > second printf $ A.parseOnly expr " ((1 + 3) + (4 + 5)) * (7 + 3 + 11 * 2)x"
-- Right "(((1+3)+(4+5))*((7+3)+(11*2)))"
expr :: A.Parser (Exp Int)
expr :: Parser (Exp Int)
expr = Parser (Exp Int)
-> Parser (Exp Int -> Exp Int -> Exp Int) -> Parser (Exp Int)
forall a. Parser a -> Parser (a -> a -> a) -> Parser a
branch Parser (Exp Int)
term Parser (Exp Int -> Exp Int -> Exp Int)
forall a. Parser (Exp a -> Exp a -> Exp a)
add

factor :: A.Parser (Exp Int)
factor :: Parser (Exp Int)
factor = Parser (Exp Int)
val Parser (Exp Int) -> Parser (Exp Int) -> Parser (Exp Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Exp Int) -> Parser (Exp Int)
forall a. Parser a -> Parser a
paren Parser (Exp Int)
expr

term :: A.Parser (Exp Int)
term :: Parser (Exp Int)
term = Parser (Exp Int)
-> Parser (Exp Int -> Exp Int -> Exp Int) -> Parser (Exp Int)
forall a. Parser a -> Parser (a -> a -> a) -> Parser a
branch Parser (Exp Int)
factor Parser (Exp Int -> Exp Int -> Exp Int)
forall a. Parser (Exp a -> Exp a -> Exp a)
mult

-- signed integer
--
-- > A.parse val " 5 "
-- Done " " (Value 5)
val :: A.Parser (Exp Int)
val :: Parser (Exp Int)
val = Parser ()
A.skipSpace Parser () -> Parser (Exp Int) -> Parser (Exp Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> Exp Int
forall a. a -> Exp a
Value (Int -> Exp Int) -> Parser Text Int -> Parser (Exp Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int -> Parser Text Int
forall a. Num a => Parser a -> Parser a
A.signed Parser Text Int
forall a. Integral a => Parser a
A.decimal)

add :: A.Parser (Exp a -> Exp a -> Exp a)
add :: Parser (Exp a -> Exp a -> Exp a)
add = (Parser ()
A.skipSpace Parser () -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Text Char
A.char Char
'+') Parser Text Char
-> (Exp a -> Exp a -> Exp a) -> Parser (Exp a -> Exp a -> Exp a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp a -> Exp a -> Exp a
forall a. Exp a -> Exp a -> Exp a
Add Parser (Exp a -> Exp a -> Exp a)
-> Parser () -> Parser (Exp a -> Exp a -> Exp a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
A.skipSpace

mult :: A.Parser (Exp a -> Exp a -> Exp a)
mult :: Parser (Exp a -> Exp a -> Exp a)
mult = (Parser ()
A.skipSpace Parser () -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Text Char
A.char Char
'*') Parser Text Char
-> (Exp a -> Exp a -> Exp a) -> Parser (Exp a -> Exp a -> Exp a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp a -> Exp a -> Exp a
forall a. Exp a -> Exp a -> Exp a
Mult Parser (Exp a -> Exp a -> Exp a)
-> Parser () -> Parser (Exp a -> Exp a -> Exp a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
A.skipSpace

paren :: A.Parser a -> A.Parser a
paren :: Parser a -> Parser a
paren Parser a
p = do
  ()
_ <- Parser ()
A.skipSpace
  Char
_ <- Char -> Parser Text Char
A.char Char
'('
  ()
_ <- Parser ()
A.skipSpace
  a
r <- Parser a
p
  ()
_ <- Parser ()
A.skipSpace
  Char
_ <- Char -> Parser Text Char
A.char Char
')'
  a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a
p

branch :: A.Parser a -> A.Parser (a -> a -> a) -> A.Parser a
branch :: Parser a -> Parser (a -> a -> a) -> Parser a
branch Parser a
p Parser (a -> a -> a)
op = do
  a
a <- Parser a
p
  a -> Parser a
more a
a
  where
    more :: a -> Parser a
more a
a' = (a -> Parser a
more (a -> Parser a) -> Parser a -> Parser a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((a -> a -> a) -> a -> a -> a
forall a b. (a -> b) -> a -> b
($) ((a -> a -> a) -> a -> a -> a)
-> Parser (a -> a -> a) -> Parser (a -> a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (a -> a -> a)
op Parser (a -> a -> a) -> Parser a -> Parser Text (a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a' Parser Text (a -> a) -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
p)) Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a'

-- | intercalate elements of an expression with an operator, and put brackets around this.
calate :: Text -> [Text] -> Text
calate :: Text -> [Text] -> Text
calate Text
_ [] = Text
forall a. Monoid a => a
mempty
calate Text
_ [Item [Text]
x] = Item [Text]
Text
x
calate Text
op [Text]
xs = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
op [Text]
xs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"