> {-# OPTIONS_HADDOCK show-extensions #-}
> {-|
> Module    : LTK.Decide.Acom
> Copyright : (c) 2022-2024 Dakotah Lambert
> License   : MIT

> This module implements an algorithm to decide whether a given FSA
> has a semigroup both Commutative and Aperiodic (Acom).  This is
> the class that LTT localizes (Almeida, 1989).
>
> https://doi.org/10.1016/0022-4049(89)90124-2
>
> @since 1.1
> -}
> module LTK.Decide.Acom (isAcom, isAcomM, isAcoms, comTest) where

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

> import LTK.FSA
> import LTK.Algebra(SynMon)


> -- |True iff the automaton recognizes a \(\langle 1,t\rangle\)-LTT
> -- stringset.
> isAcom :: (Ord n, Ord e) => FSA n e -> Bool
> isAcom :: forall n e. (Ord n, Ord e) => FSA n e -> Bool
isAcom = GeneratedAction -> Bool
forall s. FiniteSemigroupRep s => s -> Bool
isAcoms (GeneratedAction -> Bool)
-> (FSA n e -> GeneratedAction) -> FSA n e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSA n e -> GeneratedAction
forall n e. (Ord n, Ord e) => FSA n e -> GeneratedAction
syntacticSemigroup

> -- |True iff the monoid is aperiodic and commutative
> isAcomM :: (Ord n, Ord e) => SynMon n e -> Bool
> isAcomM :: forall n e. (Ord n, Ord e) => SynMon n e -> Bool
isAcomM = FSA ([Maybe n], [Symbol e]) e -> Bool
forall n e. (Ord n, Ord e) => FSA n e -> Bool
isAcom

> -- |True iff the semigroup is aperiodic and commutative
> --
> -- @since 1.2
> isAcoms :: FiniteSemigroupRep s => s -> Bool
> isAcoms :: forall s. FiniteSemigroupRep s => s -> Bool
isAcoms = (s -> Bool) -> (s -> Bool) -> s -> Bool
forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
both s -> Bool
forall s. FiniteSemigroupRep s => s -> Bool
isAperiodic s -> Bool
forall s. FiniteSemigroupRep s => s -> Bool
isCommutative

> -- |True iff the specified elements commute.
> comTest :: (Ord n, Ord e) =>
>           SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> Bool
> comTest :: forall n e.
(Ord n, Ord e) =>
SynMon n e -> Set (State ([Maybe n], [Symbol e])) -> Bool
comTest SynMon n e
m Set (State ([Maybe n], [Symbol e]))
qs
>     | Set (State ([Maybe n], [Symbol e])) -> Int
forall a. Set a -> Int
Set.size (SynMon n e -> Set (State ([Maybe n], [Symbol e]))
forall n e. FSA n e -> Set (State n)
initials SynMon n e
m) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 = Set (State ([Maybe n], [Symbol e])) -> Bool
forall a. Set a -> Bool
Set.null (SynMon n e -> Set (State ([Maybe n], [Symbol e]))
forall n e. FSA n e -> Set (State n)
initials SynMon n e
m)
>     | Bool
otherwise = (([Symbol e], [Symbol e]) -> Bool)
-> [([Symbol e], [Symbol e])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Symbol e], [Symbol e]) -> Bool
commutes ([([Symbol e], [Symbol e])] -> Bool)
-> [([Symbol e], [Symbol e])] -> Bool
forall a b. (a -> b) -> a -> b
$ Set ([Symbol e], [Symbol e]) -> [([Symbol e], [Symbol e])]
forall a. Set a -> [a]
Set.toList Set ([Symbol e], [Symbol e])
p
>     where p :: Set ([Symbol e], [Symbol e])
p = Set [Symbol e] -> Set ([Symbol e], [Symbol e])
forall a. Ord a => Set a -> Set (a, a)
pairs (Set [Symbol e] -> Set ([Symbol e], [Symbol e]))
-> Set [Symbol e] -> Set ([Symbol e], [Symbol e])
forall a b. (a -> b) -> a -> b
$ (State ([Maybe n], [Symbol e]) -> [Symbol e])
-> Set (State ([Maybe n], [Symbol e])) -> Set [Symbol e]
forall (s :: * -> *) b1 b a.
(Collapsible s, Container (s b1) b) =>
(a -> b) -> s a -> s b1
tmap (([Maybe n], [Symbol e]) -> [Symbol e]
forall a b. (a, b) -> b
snd (([Maybe n], [Symbol e]) -> [Symbol e])
-> (State ([Maybe n], [Symbol e]) -> ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
-> [Symbol e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State ([Maybe n], [Symbol e]) -> ([Maybe n], [Symbol e])
forall n. State n -> n
nodeLabel) Set (State ([Maybe n], [Symbol e]))
qs
>           i :: State ([Maybe n], [Symbol e])
i = Set (State ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
forall a. Set a -> a
Set.findMin (Set (State ([Maybe n], [Symbol e]))
 -> State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e]))
-> State ([Maybe n], [Symbol e])
forall a b. (a -> b) -> a -> b
$ SynMon n e -> Set (State ([Maybe n], [Symbol e]))
forall n e. FSA n e -> Set (State n)
initials SynMon n e
m
>           commutes :: ([Symbol e], [Symbol e]) -> Bool
commutes ([Symbol e], [Symbol e])
x = SynMon n e
-> [Symbol e]
-> State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow SynMon n e
m (([Symbol e] -> [Symbol e] -> [Symbol e])
-> ([Symbol e], [Symbol e]) -> [Symbol e]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Symbol e] -> [Symbol e] -> [Symbol e]
forall a. [a] -> [a] -> [a]
(++) ([Symbol e], [Symbol e])
x) State ([Maybe n], [Symbol e])
i
>                        Set (State ([Maybe n], [Symbol e]))
-> Set (State ([Maybe n], [Symbol e])) -> Bool
forall a. Eq a => a -> a -> Bool
== SynMon n e
-> [Symbol e]
-> State ([Maybe n], [Symbol e])
-> Set (State ([Maybe n], [Symbol e]))
forall n e.
(Ord n, Ord e) =>
FSA n e -> [Symbol e] -> State n -> Set (State n)
follow SynMon n e
m (([Symbol e] -> [Symbol e] -> [Symbol e])
-> ([Symbol e], [Symbol e]) -> [Symbol e]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (([Symbol e] -> [Symbol e] -> [Symbol e])
-> [Symbol e] -> [Symbol e] -> [Symbol e]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Symbol e] -> [Symbol e] -> [Symbol e]
forall a. [a] -> [a] -> [a]
(++)) ([Symbol e], [Symbol e])
x) State ([Maybe n], [Symbol e])
i

> pairs :: Ord a => Set a -> Set (a, a)
> pairs :: forall a. Ord a => 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 a b. (a -> b -> b) -> b -> Set a -> b
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