> {-# OPTIONS_HADDOCK show-extensions #-}
> {-|
> Module    : LTK.Algebra
> Copyright : (c) 2021 Dakotah Lambert
> License   : MIT

> This module centralizes definitions of some commonly used
> algebraic properties.
>
> @since 1.0
> -}

> module LTK.Algebra
>     ( -- *Type
>       SynMon
>       -- *Tests
>     , isCommutative
>       -- *Generated Submonoids and Subsemigroups
>     , me
>     , emee
>     , ese
>       -- *Powers
>     , idempotents
>     , omega
>     ) where

> import Data.Set (Set)
> import qualified Data.Set as Set

> import LTK.FSA

> type S n e = (n, [Symbol e])
> type T n e = State (S n e)

> -- | A simpler way to denote syntactic monoids in type signatures.
> type SynMon n e = FSA ([Maybe n],[Symbol e]) e


Generated Submonoids
====================

For a monid M and idempotent e, Me is the set generated by
    {m : e is in the two-sided ideal of m}.

The class MeV, for some variety V, is the set of all monoids M
where for all idempotents e, e*Me*e is in V.

> -- |For a given idempotent \(e\), return the set generated by
> -- \(\{m : (\exists u,v)[umv=e]\}\).
> me :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
> me :: FSA (S n e) e -> T n e -> Set (T n e)
me FSA (S n e) e
monoid T n e
e = FSA (S n e) e -> Set (T n e)
forall e n. (Ord e, Ord n) => FSA n e -> Set (State n)
states (FSA (S n e) e -> Set (T n e))
-> (FSA (S n e) e -> FSA (S n e) e) -> FSA (S n e) e -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSA (S n e) e -> FSA (S n e) e
forall e n. (Ord e, Ord n) => FSA n e -> FSA n e
trimUnreachables
>               (FSA (S n e) e -> Set (T n e)) -> FSA (S n e) e -> Set (T n e)
forall a b. (a -> b) -> a -> b
$ Set e -> FSA (S n e) e -> FSA (S n e) e
forall a b. (Ord a, Ord b) => Set b -> FSA a b -> FSA a b
contractAlphabetTo Set e
syms FSA (S n e) e
monoid
>     where syms :: Set e
syms = (e -> Bool) -> Set e -> Set e
forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep (T n e -> Set (T n e) -> Bool
forall c a. (Container c a, Eq a) => a -> c -> Bool
contains T n e
e (Set (T n e) -> Bool) -> (e -> Set (T n e)) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Set (T n e)) -> Set (T n e)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
>                        (Set (Set (T n e)) -> Set (T n e))
-> (e -> Set (Set (T n e))) -> e -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T n e -> Set (T n e)) -> Set (T n e) -> Set (Set (T n e))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (FSA (S n e) e -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA (n, [Symbol e]) e
-> State (n, [Symbol e]) -> Set (State (n, [Symbol e]))
primitiveIdeal2 FSA (S n e) e
monoid) (Set (T n e) -> Set (Set (T n e)))
-> (e -> Set (T n e)) -> e -> Set (Set (T n e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Set (T n e)
s)
>                  (Set e -> Set e) -> Set e -> Set e
forall a b. (a -> b) -> a -> b
$ FSA (S n e) e -> Set e
forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet FSA (S n e) e
monoid
>           s :: e -> Set (T n e)
s e
x = Set (Set (T n e)) -> Set (T n e)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
>                 (Set (Set (T n e)) -> Set (T n e))
-> (Set (T n e) -> Set (Set (T n e))) -> Set (T n e) -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T n e -> Set (T n e)) -> Set (T n e) -> Set (Set (T n e))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (FSA (S n e) e -> [Symbol e] -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
monoid [e -> Symbol e
forall e. e -> Symbol e
Symbol e
x])
>                 (Set (T n e) -> Set (T n e)) -> Set (T n e) -> Set (T n e)
forall a b. (a -> b) -> a -> b
$ FSA (S n e) e -> Set (T n e)
forall n e. FSA n e -> Set (State n)
initials FSA (S n e) e
monoid

emee is e*Me*e: first follow the label of e from all the states,
then take the resulting labels and follow those from e.

> -- |For a given idempotent \(e\), return the set @me monoid e@
> -- multiplied on the left and right by \(e\).
> emee :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
> emee :: FSA (S n e) e -> T n e -> Set (T n e)
emee FSA (S n e) e
monoid T n e
e = (T n e -> Set (T n e) -> Set (T n e))
-> Set (T n e) -> Set (T n e) -> Set (T n e)
forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (Set (T n e) -> Set (T n e) -> Set (T n e)
forall c a. Container c a => c -> c -> c
union (Set (T n e) -> Set (T n e) -> Set (T n e))
-> (T n e -> Set (T n e)) -> T n e -> Set (T n e) -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Symbol e] -> T n e -> Set (T n e))
-> T n e -> [Symbol e] -> Set (T n e)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FSA (S n e) e -> [Symbol e] -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
monoid) T n e
e ([Symbol e] -> Set (T n e))
-> (T n e -> [Symbol e]) -> T n e -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T n e -> [Symbol e]
forall a c. State (a, c) -> c
s) Set (T n e)
forall c a. Container c a => c
empty
>                 (Set (T n e) -> Set (T n e))
-> (Set (T n e) -> Set (T n e)) -> Set (T n e) -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T n e -> Set (T n e) -> Set (T n e))
-> Set (T n e) -> Set (T n e) -> Set (T n e)
forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (Set (T n e) -> Set (T n e) -> Set (T n e)
forall c a. Container c a => c -> c -> c
union (Set (T n e) -> Set (T n e) -> Set (T n e))
-> (T n e -> Set (T n e)) -> T n e -> Set (T n e) -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSA (S n e) e -> [Symbol e] -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
monoid (T n e -> [Symbol e]
forall a c. State (a, c) -> c
s T n e
e)) Set (T n e)
forall c a. Container c a => c
empty
>                 (Set (T n e) -> Set (T n e)) -> Set (T n e) -> Set (T n e)
forall a b. (a -> b) -> a -> b
$ Set (T n e)
x
>     where x :: Set (T n e)
x = FSA (S n e) e -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA (n, [Symbol e]) e
-> State (n, [Symbol e]) -> Set (State (n, [Symbol e]))
me FSA (S n e) e
monoid T n e
e
>           s :: State (a, c) -> c
s = (a, c) -> c
forall a b. (a, b) -> b
snd ((a, c) -> c) -> (State (a, c) -> (a, c)) -> State (a, c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State (a, c) -> (a, c)
forall n. State n -> n
nodeLabel

ese is e*S*e: first go wherever you can from e, then take another e.

> -- |The semigroup multiplied on the left and right
> -- by the given idempotent.
> ese :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> Set (T n e)
> ese :: FSA (S n e) e -> T n e -> Set (T n e)
ese FSA (S n e) e
sg T n e
e = (T n e -> Set (T n e) -> Set (T n e))
-> Set (T n e) -> Set (T n e) -> Set (T n e)
forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (Set (T n e) -> Set (T n e) -> Set (T n e)
forall c a. Container c a => c -> c -> c
union (Set (T n e) -> Set (T n e) -> Set (T n e))
-> (T n e -> Set (T n e)) -> T n e -> Set (T n e) -> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSA (S n e) e -> [Symbol e] -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
sg (T n e -> [Symbol e]
forall a c. State (a, c) -> c
s T n e
e)) Set (T n e)
forall c a. Container c a => c
empty
>            (Set (T n e) -> Set (T n e)) -> Set (T n e) -> Set (T n e)
forall a b. (a -> b) -> a -> b
$ Set (T n e)
es
>     where es :: Set (T n e)
es = FSA (S n e) e -> T n e -> Set (T n e)
forall n e. (Ord n, Ord e) => FSA n e -> State n -> Set (State n)
primitiveIdealR FSA (S n e) e
sg T n e
e
>           s :: State (a, c) -> c
s = (a, c) -> c
forall a b. (a, b) -> b
snd ((a, c) -> c) -> (State (a, c) -> (a, c)) -> State (a, c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State (a, c) -> (a, c)
forall n. State n -> n
nodeLabel


Commutativity
=============

Testing commutativity by checking that all elements commute with one another.

> -- |True iff the supplied elements commute with one another
> -- in the provided monoid.
> isCommutative :: (Ord n, Ord e) =>
>                  FSA (n, [Symbol e]) e -> Set (State (n, [Symbol e])) ->
>                  Bool
> isCommutative :: FSA (n, [Symbol e]) e -> Set (State (n, [Symbol e])) -> Bool
isCommutative FSA (n, [Symbol e]) e
f Set (State (n, [Symbol e]))
ss = ((State (n, [Symbol e]), State (n, [Symbol e])) -> Bool)
-> Set (State (n, [Symbol e]), State (n, [Symbol e])) -> Bool
forall (s :: * -> *) a. Collapsible s => (a -> Bool) -> s a -> Bool
allS ((State (n, [Symbol e]) -> State (n, [Symbol e]) -> Bool)
-> (State (n, [Symbol e]), State (n, [Symbol e])) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry State (n, [Symbol e]) -> State (n, [Symbol e]) -> Bool
commute) (Set (State (n, [Symbol e]))
-> Set (State (n, [Symbol e]), State (n, [Symbol e]))
forall a. Ord a => Set a -> Set (a, a)
pairs Set (State (n, [Symbol e]))
ss)
>     where commute :: State (n, [Symbol e]) -> State (n, [Symbol e]) -> Bool
commute State (n, [Symbol e])
u State (n, [Symbol e])
v = FSA (n, [Symbol e]) e
-> [Symbol e]
-> State (n, [Symbol e])
-> Set (State (n, [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
f ((n, [Symbol e]) -> [Symbol e]
forall a b. (a, b) -> b
snd ((n, [Symbol e]) -> [Symbol e]) -> (n, [Symbol e]) -> [Symbol e]
forall a b. (a -> b) -> a -> b
$ State (n, [Symbol e]) -> (n, [Symbol e])
forall n. State n -> n
nodeLabel State (n, [Symbol e])
u) State (n, [Symbol e])
v Set (State (n, [Symbol e])) -> Set (State (n, [Symbol e])) -> Bool
forall a. Eq a => a -> a -> Bool
==
>                         FSA (n, [Symbol e]) e
-> [Symbol e]
-> State (n, [Symbol e])
-> Set (State (n, [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
f ((n, [Symbol e]) -> [Symbol e]
forall a b. (a, b) -> b
snd ((n, [Symbol e]) -> [Symbol e]) -> (n, [Symbol e]) -> [Symbol e]
forall a b. (a -> b) -> a -> b
$ State (n, [Symbol e]) -> (n, [Symbol e])
forall n. State n -> n
nodeLabel State (n, [Symbol e])
v) State (n, [Symbol e])
u


Powers
======

An element x is idempotent iff xx == x.
Here we use the syntactic monoid and simply exclude the identity
if it does not appear in the syntactic semigroup.

> -- |All elements \(e\) of the given monoid such that \(e*e=e\).
> -- Except the identity element.  Add that manually if you need it.
> idempotents :: (Ord n, Ord e) =>
>                FSA (n, [Symbol e]) e -> Set (T n e)
> idempotents :: FSA (n, [Symbol e]) e -> Set (T n e)
idempotents FSA (n, [Symbol e]) e
f = (T n e -> Bool) -> Set (T n e) -> Set (T n e)
forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep T n e -> Bool
isIdem (Set (T n e) -> Set (T n e))
-> (Set (Transition (n, [Symbol e]) e) -> Set (T n e))
-> Set (Transition (n, [Symbol e]) e)
-> Set (T n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transition (n, [Symbol e]) e -> T n e)
-> Set (Transition (n, [Symbol e]) e) -> Set (T n e)
forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap Transition (n, [Symbol e]) e -> T n e
forall n e. Transition n e -> State n
destination (Set (Transition (n, [Symbol e]) e) -> Set (T n e))
-> Set (Transition (n, [Symbol e]) e) -> Set (T n e)
forall a b. (a -> b) -> a -> b
$ FSA (n, [Symbol e]) e -> Set (Transition (n, [Symbol e]) e)
forall n e. FSA n e -> Set (Transition n e)
transitions FSA (n, [Symbol e]) e
f
>     where isIdem :: T n e -> Bool
isIdem T n e
x = FSA (n, [Symbol e]) e -> [Symbol e] -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (n, [Symbol e]) e
f ((n, [Symbol e]) -> [Symbol e]
forall a b. (a, b) -> b
snd ((n, [Symbol e]) -> [Symbol e]) -> (n, [Symbol e]) -> [Symbol e]
forall a b. (a -> b) -> a -> b
$ T n e -> (n, [Symbol e])
forall n. State n -> n
nodeLabel T n e
x) T n e
x Set (T n e) -> Set (T n e) -> Bool
forall a. Eq a => a -> a -> Bool
== T n e -> Set (T n e)
forall c a. Container c a => a -> c
singleton T n e
x

> -- |@omega monoid s@ is the unique element \(t\) where \(t*t\) = \(t\)
> -- and \(t\) is in \(\{s, s^2, s^3, \ldots\}\).
> -- In other words, \(t\) is the unique idempotent element
> -- in this set.
> -- This method used here assumes @monoid@ is aperiodic and finite
> -- and uses this to skip many otherwise necessary checks.
> omega :: (Ord n, Ord e) => FSA (S n e) e -> T n e -> T n e
> omega :: FSA (S n e) e -> T n e -> T n e
omega FSA (S n e) e
monoid T n e
s = (T n e, T n e) -> T n e
forall a b. (a, b) -> a
fst
>                  ((T n e, T n e) -> T n e)
-> ((T n e, T n e) -> (T n e, T n e)) -> (T n e, T n e) -> T n e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((T n e, T n e) -> Bool)
-> ((T n e, T n e) -> (T n e, T n e))
-> (T n e, T n e)
-> (T n e, T n e)
forall a. (a -> Bool) -> (a -> a) -> a -> a
until ((T n e -> T n e -> Bool) -> (T n e, T n e) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry T n e -> T n e -> Bool
forall a. Eq a => a -> a -> Bool
(==)) (\(T n e
_,T n e
b) -> (T n e
b, T n e -> T n e
f T n e
b))
>                  ((T n e, T n e) -> T n e) -> (T n e, T n e) -> T n e
forall a b. (a -> b) -> a -> b
$ (T n e
s, T n e -> T n e
f T n e
s)
>     where f :: T n e -> T n e
f T n e
x = Set (T n e) -> T n e
forall a. Set a -> a
Set.findMin (Set (T n e) -> T n e) -> Set (T n e) -> T n e
forall a b. (a -> b) -> a -> b
$ FSA (S n e) e -> [Symbol e] -> T n e -> Set (T n e)
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow FSA (S n e) e
monoid (S n e -> [Symbol e]
forall a b. (a, b) -> b
snd (T n e -> S n e
forall n. State n -> n
nodeLabel T n e
x)) T n e
x


Helpers
=======

> pairs :: Ord a => Set a -> Set (a, a)
> pairs :: Set a -> Set (a, a)
pairs Set a
xs = (a -> Set (a, a) -> Set (a, a))
-> Set (a, a) -> Set a -> Set (a, a)
forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (Set (a, a) -> Set (a, a) -> Set (a, a)
forall c a. Container c a => c -> c -> c
union (Set (a, a) -> Set (a, a) -> Set (a, a))
-> (a -> Set (a, a)) -> a -> Set (a, a) -> Set (a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set (a, a)
forall a. a -> Set (a, a)
f) Set (a, a)
forall c a. Container c a => c
empty Set a
xs
>     where f :: a -> Set (a, a)
f a
x = (a -> (a, a)) -> Set a -> Set (a, a)
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic ((,) a
x) Set a
xs