> {-# OPTIONS_HADDOCK hide,show-extensions #-}
> {-# LANGUAGE Safe #-}
>
> module Data.Representation.FiniteSemigroup.Base
> (
> FiniteSemigroupRep(..)
> , FSMult(getTable)
> , GeneratedAction(bases,completion)
>
> , fromBases
> , mapsInto
> , independentBases
> , subsemigroup
> , asActions
>
> , localSubsemigroup
> , localSubmonoids
> , emee
> , dual
> , monoid
> , projectedSubsemigroup
>
>
>
> , ideal2
> , jleq
>
> , neutralElement
> , adjoinOne
> , zeroElement
> , adjoinZero
> , idempotents
> , omega
> , omegas
> , lClasses
> , rClasses
> ) where
>
> import Data.List ((\\), elemIndex, sort, sortBy, transpose)
> import Data.Ord (comparing)
> import qualified Data.List.NonEmpty as NE
> import Data.IntSet (IntSet)
> import qualified Data.Set as Set
> import qualified Data.IntSet as IntSet
> import Safe
>
>
>
>
>
>
> class FiniteSemigroupRep a where
>
> fsappend :: a -> Int -> Int -> Int
> fsappend a
s Int
x Int
y = forall a. a -> [a] -> Int -> a
atDef (-Int
1) (forall a. a -> [a] -> Int -> a
atDef [] (FSMult -> [[Int]]
getTable (forall a. FiniteSemigroupRep a => a -> FSMult
fstable a
s)) Int
x) Int
y
>
>
> fstable :: a -> FSMult
> fstable a
s
> = let es :: [Int]
es = [Int
0..(forall a. FiniteSemigroupRep a => a -> Int
fssize a
s forall a. Num a => a -> a -> a
- Int
1)]
> in Int -> [[Int]] -> FSMult
FSMult (forall a. FiniteSemigroupRep a => a -> Int
fsnbases a
s)
> forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> forall a b. (a -> b) -> [a] -> [b]
map (\Int
y -> forall a. FiniteSemigroupRep a => a -> Int -> Int -> Int
fsappend a
s Int
x Int
y) [Int]
es) [Int]
es
>
> fssize :: a -> Int
> fssize = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
fstable
>
> fsnbases :: a -> Int
> fsnbases = forall a. FiniteSemigroupRep a => a -> Int
fssize
> {-# MINIMAL (fsappend,fssize)|fstable #-}
A multiplication table can define a semigroup,
but we shall not allow direct creation of such objects
outside of this module, in order to ensure associativity.
>
>
>
> data FSMult = FSMult { FSMult -> Int
basisRows :: Int
> , FSMult -> [[Int]]
getTable :: [[Int]]
> } deriving (FSMult -> FSMult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FSMult -> FSMult -> Bool
$c/= :: FSMult -> FSMult -> Bool
== :: FSMult -> FSMult -> Bool
$c== :: FSMult -> FSMult -> Bool
Eq, Eq FSMult
FSMult -> FSMult -> Bool
FSMult -> FSMult -> Ordering
FSMult -> FSMult -> FSMult
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 :: FSMult -> FSMult -> FSMult
$cmin :: FSMult -> FSMult -> FSMult
max :: FSMult -> FSMult -> FSMult
$cmax :: FSMult -> FSMult -> FSMult
>= :: FSMult -> FSMult -> Bool
$c>= :: FSMult -> FSMult -> Bool
> :: FSMult -> FSMult -> Bool
$c> :: FSMult -> FSMult -> Bool
<= :: FSMult -> FSMult -> Bool
$c<= :: FSMult -> FSMult -> Bool
< :: FSMult -> FSMult -> Bool
$c< :: FSMult -> FSMult -> Bool
compare :: FSMult -> FSMult -> Ordering
$ccompare :: FSMult -> FSMult -> Ordering
Ord)
> instance FiniteSemigroupRep FSMult where
> fstable :: FSMult -> FSMult
fstable FSMult
t = FSMult
t
> fsnbases :: FSMult -> Int
fsnbases = FSMult -> Int
basisRows
Operations on Semigroups
========================
>
>
> idempotents :: FiniteSemigroupRep s => s -> IntSet
> idempotents :: forall s. FiniteSemigroupRep s => s -> IntSet
idempotents = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, [Int]) -> IntSet -> IntSet
f IntSet
IntSet.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
fstable
> where f :: (Int, [Int]) -> IntSet -> IntSet
f ~(Int
p,[Int]
x) = if forall a. [a] -> Int -> Maybe a
atMay [Int]
x Int
p forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
p
> then (Int
p Int -> IntSet -> IntSet
`IntSet.insert`)
> else forall a. a -> a
id
>
>
> omegas :: FiniteSemigroupRep s => s -> [Int]
> omegas :: forall s. FiniteSemigroupRep s => s -> [Int]
omegas s
s = forall a b. (a -> b) -> [a] -> [b]
map (forall s. FiniteSemigroupRep s => s -> Int -> Int
omega s
s) [Int
0..forall a. FiniteSemigroupRep a => a -> Int
fssize s
s forall a. Num a => a -> a -> a
- Int
1]
>
>
>
> omega :: FiniteSemigroupRep s => s -> Int -> Int
> omega :: forall s. FiniteSemigroupRep s => s -> Int -> Int
omega s
s Int
x = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> (a -> a) -> a -> a
until (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==)) (Int -> (Int, Int)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (Int -> (Int, Int)
go Int
x)
> where go :: Int -> (Int, Int)
go Int
a = let y :: Int
y = forall a. FiniteSemigroupRep a => a -> Int -> Int -> Int
fsappend s
s Int
x Int
a
> in (Int
y, forall a. FiniteSemigroupRep a => a -> Int -> Int -> Int
fsappend s
s Int
y Int
y)
>
> dual :: FiniteSemigroupRep s => s -> FSMult
> dual :: forall a. FiniteSemigroupRep a => a -> FSMult
dual s
s = Int -> [[Int]] -> FSMult
FSMult (forall a. FiniteSemigroupRep a => a -> Int
fsnbases s
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [[a]] -> [[a]]
transpose forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
>
>
>
>
> rClasses :: FiniteSemigroupRep s => s -> [NE.NonEmpty Int]
> rClasses :: forall s. FiniteSemigroupRep s => s -> [NonEmpty Int]
rClasses = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy (forall b a. Eq b => (a -> b) -> a -> a -> Bool
equal forall a b. (a, b) -> a
fst)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Int, [Int])
p -> ((Int, [Int]) -> IntSet
row (Int, [Int])
p, forall a b. (a, b) -> a
fst (Int, [Int])
p)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
fstable
> where row :: (Int, [Int]) -> IntSet
row (Int, [Int])
p = [Int] -> IntSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) (Int, [Int])
p
>
>
>
>
> lClasses :: FiniteSemigroupRep s => s -> [NE.NonEmpty Int]
> lClasses :: forall s. FiniteSemigroupRep s => s -> [NonEmpty Int]
lClasses = forall s. FiniteSemigroupRep s => s -> [NonEmpty Int]
rClasses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
dual
>
>
>
>
> localSubsemigroup :: FiniteSemigroupRep s => s -> Int -> FSMult
> localSubsemigroup :: forall s. FiniteSemigroupRep s => s -> Int -> FSMult
localSubsemigroup s
s Int
i = FSMult -> [Int] -> FSMult
restrict FSMult
t [Int]
xs
> where t :: FSMult
t = forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
> si :: [Int]
si = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. a -> [a] -> Int -> a
atDef []) Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
dual FSMult
t
> xs :: [Int]
xs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. NonEmpty a -> a
NE.head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip [Int] -> [Int] -> [Int]
backpermute [Int]
si forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. a -> [a] -> Int -> a
atDef []) Int
i forall a b. (a -> b) -> a -> b
$ FSMult -> [[Int]]
getTable FSMult
t
>
>
>
>
> localSubmonoids :: FiniteSemigroupRep s => s -> [FSMult]
> localSubmonoids :: forall s. FiniteSemigroupRep s => s -> [FSMult]
localSubmonoids s
s = forall a b. (a -> b) -> [a] -> [b]
map (forall s. FiniteSemigroupRep s => s -> Int -> FSMult
localSubsemigroup s
s)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IntSet.toList forall a b. (a -> b) -> a -> b
$ forall s. FiniteSemigroupRep s => s -> IntSet
idempotents s
s
>
>
>
> neutralElement :: FiniteSemigroupRep s => s -> Maybe Int
> neutralElement :: forall s. FiniteSemigroupRep s => s -> Maybe Int
neutralElement s
s
> = forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
> forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&)) (FSMult -> [[Bool]]
proper FSMult
t) (FSMult -> [[Bool]]
proper forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
dual FSMult
t)
> where t :: FSMult
t = forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
> proper :: FSMult -> [[Bool]]
proper = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(==) [Int
0..]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable
>
>
>
>
> zeroElement :: FiniteSemigroupRep s => s -> Maybe Int
> zeroElement :: forall s. FiniteSemigroupRep s => s -> Maybe Int
zeroElement s
s = forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
> forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) (FSMult -> [Bool]
f FSMult
t) (FSMult -> [Bool]
f forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
dual FSMult
t)
> where alleq :: a -> t a -> Bool
alleq a
x t a
xs = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== a
x) t a
xs
> f :: FSMult -> [Bool]
f = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {t :: * -> *} {a}. (Foldable t, Eq a) => a -> t a -> Bool
alleq [Int
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable
> t :: FSMult
t = forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
>
>
>
> projectedSubsemigroup :: FiniteSemigroupRep s => s -> FSMult
> projectedSubsemigroup :: forall a. FiniteSemigroupRep a => a -> FSMult
projectedSubsemigroup s
s = FSMult -> [Int] -> FSMult
restrict FSMult
t ([Int
0..forall a. FiniteSemigroupRep a => a -> Int
fssize FSMult
t forall a. Num a => a -> a -> a
- Int
1] forall a. Eq a => [a] -> [a] -> [a]
\\ [Int]
n)
> where t :: FSMult
t = forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
> n :: [Int]
n = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Int -> [Int]
f forall a b. (a -> b) -> a -> b
$ forall s. FiniteSemigroupRep s => s -> Maybe Int
neutralElement FSMult
t
> f :: Int -> [Int]
f Int
x = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
==Int
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ FSMult -> [[Int]]
getTable FSMult
t
> then [Int
x] else []
Ideals and Orders
=================
>
>
>
> ideal2 :: FiniteSemigroupRep s => s -> Int -> IntSet
> ideal2 :: forall s. FiniteSemigroupRep s => s -> Int -> IntSet
ideal2 s
s Int
i = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> IntSet
IntSet.fromList)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [Int] -> [a]
backpermuteDef []
> (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) [Int
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
dual s
s)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. NonEmpty a -> a
NE.head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
iforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. a -> [a] -> Int -> a
atDef []) Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
>
>
> jleq :: FiniteSemigroupRep s => s -> Int -> Int -> Bool
> jleq :: forall s. FiniteSemigroupRep s => s -> Int -> Int -> Bool
jleq s
s Int
x Int
y = Int
x Int -> IntSet -> Bool
`IntSet.member` forall s. FiniteSemigroupRep s => s -> Int -> IntSet
ideal2 s
s Int
y
>
>
> me :: FiniteSemigroupRep s => s -> [IntSet]
> me :: forall s. FiniteSemigroupRep s => s -> [IntSet]
me s
s = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> [IntSet] -> [IntSet]
f (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const IntSet
IntSet.empty) [Int]
is)
> [Int
0 .. forall a. FiniteSemigroupRep a => a -> Int
fsnbases s
s forall a. Num a => a -> a -> a
- Int
1]
> where is :: [Int]
is = IntSet -> [Int]
IntSet.toList forall a b. (a -> b) -> a -> b
$ forall s. FiniteSemigroupRep s => s -> IntSet
idempotents s
s
> f :: Int -> [IntSet] -> [IntSet]
f Int
b [IntSet]
a = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
($) (forall a b. (a -> b) -> [a] -> [b]
map (Int -> IntSet -> Int -> IntSet -> IntSet
g Int
b (forall s. FiniteSemigroupRep s => s -> Int -> IntSet
ideal2 s
s Int
b)) [Int]
is) [IntSet]
a
> g :: Int -> IntSet -> Int -> IntSet -> IntSet
g Int
b IntSet
p Int
i = if Int
i Int -> IntSet -> Bool
`IntSet.member` IntSet
p
> then Int -> IntSet -> IntSet
IntSet.insert Int
b else forall a. a -> a
id
>
>
>
>
>
> emee :: FiniteSemigroupRep s => s -> [FSMult]
> emee :: forall s. FiniteSemigroupRep s => s -> [FSMult]
emee s
s = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> IntSet -> FSMult
f (IntSet -> [Int]
IntSet.toList forall a b. (a -> b) -> a -> b
$ forall s. FiniteSemigroupRep s => s -> IntSet
idempotents s
s) (forall s. FiniteSemigroupRep s => s -> [IntSet]
me s
s)
> where t :: FSMult
t = forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
> f :: Int -> IntSet -> FSMult
f Int
e = FSMult -> [Int] -> FSMult
restrict FSMult
t
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. NonEmpty a -> a
NE.head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. FiniteSemigroupRep a => a -> Int -> Int -> Int
fsappend s
s) Int
e [Int
e,Int
x])
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IntSet.toList
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. FiniteSemigroupRep s => s -> IntSet -> IntSet
subsemigroup s
s
Adjoining Elements
==================
>
>
> adjoinOne :: FiniteSemigroupRep s => s -> FSMult
> adjoinOne :: forall a. FiniteSemigroupRep a => a -> FSMult
adjoinOne s
s = Int -> [[Int]] -> FSMult
FSMult (forall a. FiniteSemigroupRep a => a -> Int
fsnbases s
s forall a. Num a => a -> a -> a
+ Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {c}. (Num c, Enum c) => [[c]] -> [[c]]
f
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a. Enum a => a -> a
succ)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
> where f :: [[c]] -> [[c]]
f [[c]]
xs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. a -> b -> a
const [c
0..] ([]forall a. a -> [a] -> [a]
:[[c]]
xs) forall a. a -> [a] -> [a]
: [[c]]
xs
>
>
> adjoinZero :: FiniteSemigroupRep s => s -> FSMult
> adjoinZero :: forall a. FiniteSemigroupRep a => a -> FSMult
adjoinZero s
s = Int -> [[Int]] -> FSMult
FSMult (forall a. FiniteSemigroupRep a => a -> Int
fsnbases s
s forall a. Num a => a -> a -> a
+ Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {c}. Num c => [[c]] -> [[c]]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Int
0 forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Enum a => a -> a
succ)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s
> where f :: [[c]] -> [[c]]
f [[c]]
xs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. a -> b -> a
const (forall a. a -> [a]
repeat c
0) ([]forall a. a -> [a] -> [a]
:[[c]]
xs) forall a. a -> [a] -> [a]
: [[c]]
xs
>
>
> monoid :: FiniteSemigroupRep s => s -> FSMult
> monoid :: forall a. FiniteSemigroupRep a => a -> FSMult
monoid s
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. FiniteSemigroupRep a => a -> FSMult
adjoinOne s
s) (forall a b. a -> b -> a
const (forall a. FiniteSemigroupRep a => a -> FSMult
fstable s
s)) forall a b. (a -> b) -> a -> b
$ forall s. FiniteSemigroupRep s => s -> Maybe Int
neutralElement s
s
Generated Actions
=================
>
>
>
> data GeneratedAction
> = GeneratedAction { GeneratedAction -> [[Int]]
bases :: [[Int]]
> , GeneratedAction -> [[Int]]
completion :: [[Int]]
> }
> deriving (GeneratedAction -> GeneratedAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GeneratedAction -> GeneratedAction -> Bool
$c/= :: GeneratedAction -> GeneratedAction -> Bool
== :: GeneratedAction -> GeneratedAction -> Bool
$c== :: GeneratedAction -> GeneratedAction -> Bool
Eq, Eq GeneratedAction
GeneratedAction -> GeneratedAction -> Bool
GeneratedAction -> GeneratedAction -> Ordering
GeneratedAction -> GeneratedAction -> GeneratedAction
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 :: GeneratedAction -> GeneratedAction -> GeneratedAction
$cmin :: GeneratedAction -> GeneratedAction -> GeneratedAction
max :: GeneratedAction -> GeneratedAction -> GeneratedAction
$cmax :: GeneratedAction -> GeneratedAction -> GeneratedAction
>= :: GeneratedAction -> GeneratedAction -> Bool
$c>= :: GeneratedAction -> GeneratedAction -> Bool
> :: GeneratedAction -> GeneratedAction -> Bool
$c> :: GeneratedAction -> GeneratedAction -> Bool
<= :: GeneratedAction -> GeneratedAction -> Bool
$c<= :: GeneratedAction -> GeneratedAction -> Bool
< :: GeneratedAction -> GeneratedAction -> Bool
$c< :: GeneratedAction -> GeneratedAction -> Bool
compare :: GeneratedAction -> GeneratedAction -> Ordering
$ccompare :: GeneratedAction -> GeneratedAction -> Ordering
Ord)
>
>
>
>
> fromBases :: [[Int]] -> GeneratedAction
> fromBases :: [[Int]] -> GeneratedAction
fromBases [] = GeneratedAction { bases :: [[Int]]
bases = [[Int
0]], completion :: [[Int]]
completion = [[Int
0]] }
> fromBases [[Int]]
ys = GeneratedAction
> { bases :: [[Int]]
bases = [[Int]]
xs
> , completion :: [[Int]]
completion = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set [Int]
xs'
> forall a b. (a -> b) -> a -> b
$ Set [Int] -> Set [Int] -> Set [Int]
go forall a. Set a
Set.empty Set [Int]
xs'
> }
> where xs :: [[Int]]
xs = forall a. Set a -> [a]
Set.toList Set [Int]
xs'
> xs' :: Set [Int]
xs' = forall a. Ord a => [a] -> Set a
Set.fromList [[Int]]
ys
> go :: Set [Int] -> Set [Int] -> Set [Int]
go Set [Int]
done Set [Int]
new
> | forall a. Set a -> Bool
Set.null Set [Int]
new = Set [Int]
done
> | Bool
otherwise = Set [Int] -> Set [Int] -> Set [Int]
go Set [Int]
d (forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set [Int]
n Set [Int]
d)
> where d :: Set [Int]
d = Set [Int]
done forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set [Int]
new
> n :: Set [Int]
n = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
> forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\[Int]
b -> forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ([Int] -> [Int] -> [Int]
backpermute [Int]
b) Set [Int]
new) [[Int]]
xs
>
>
>
> mapsInto :: GeneratedAction -> IntSet -> Int -> IntSet
> mapsInto :: GeneratedAction -> IntSet -> Int -> IntSet
mapsInto GeneratedAction
s IntSet
h Int
q = [Int] -> IntSet
IntSet.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ( forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> IntSet -> Bool
`IntSet.member` IntSet
h)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> Int -> Maybe a
atMay Int
q )
> forall a b. (a -> b) -> a -> b
$ (GeneratedAction -> [[Int]]
bases GeneratedAction
s forall a. [a] -> [a] -> [a]
++ GeneratedAction -> [[Int]]
completion GeneratedAction
s)
>
>
> subsemigroup :: FiniteSemigroupRep s => s -> IntSet -> IntSet
> subsemigroup :: forall s. FiniteSemigroupRep s => s -> IntSet -> IntSet
subsemigroup s
s IntSet
xs = IntSet -> IntSet -> IntSet
go IntSet
IntSet.empty IntSet
xs
> where is :: [Int]
is = IntSet -> [Int]
IntSet.toList IntSet
xs
> go :: IntSet -> IntSet -> IntSet
go IntSet
done IntSet
new
> | IntSet -> Bool
IntSet.null IntSet
new = IntSet
done
> | Bool
otherwise = IntSet -> IntSet -> IntSet
go IntSet
d (IntSet -> IntSet -> IntSet
IntSet.difference IntSet
n IntSet
d)
> where d :: IntSet
d = IntSet
done IntSet -> IntSet -> IntSet
`IntSet.union` IntSet
new
> n :: IntSet
n = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions
> forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> (Int -> Int) -> IntSet -> IntSet
IntSet.map (forall a. FiniteSemigroupRep a => a -> Int -> Int -> Int
fsappend s
s Int
i) IntSet
new) [Int]
is
>
>
>
> asActions :: FiniteSemigroupRep s => s -> [Int] -> GeneratedAction
> asActions :: forall s. FiniteSemigroupRep s => s -> [Int] -> GeneratedAction
asActions s
s [Int]
is = [[Int]] -> GeneratedAction
fromBases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. a -> [a] -> [Int] -> [a]
backpermuteDef []) [Int]
is
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
adjoinOne forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
dual s
s
> instance FiniteSemigroupRep GeneratedAction where
> fsappend :: GeneratedAction -> Int -> Int -> Int
fsappend GeneratedAction
s Int
a Int
b = let c :: [[Int]]
c = GeneratedAction -> [[Int]]
bases GeneratedAction
s forall a. [a] -> [a] -> [a]
++ GeneratedAction -> [[Int]]
completion GeneratedAction
s
> x :: [Int]
x = forall a. a -> [a] -> Int -> a
atDef [] [[Int]]
c Int
a
> y :: [Int]
y = forall a. a -> [a] -> Int -> a
atDef [] [[Int]]
c Int
b
> in forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe Int
elemIndex ([Int] -> [Int] -> [Int]
backpermute [Int]
y [Int]
x) [[Int]]
c
> fssize :: GeneratedAction -> Int
fssize GeneratedAction
s = forall (t :: * -> *) a. Foldable t => t a -> Int
length (GeneratedAction -> [[Int]]
bases GeneratedAction
s) forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (GeneratedAction -> [[Int]]
completion GeneratedAction
s)
> fsnbases :: GeneratedAction -> Int
fsnbases = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. GeneratedAction -> [[Int]]
bases
>
>
>
>
> independentBases :: FiniteSemigroupRep s => s -> [[Int]]
> independentBases :: forall s. FiniteSemigroupRep s => s -> [[Int]]
independentBases = [[Int]] -> [[Int]] -> [[Int]]
go [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
adjoinOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
dual
> where go :: [[Int]] -> [[Int]] -> [[Int]]
go [[Int]]
keep ([Int]
x:[[Int]]
xs)
> | [Int]
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` GeneratedAction -> [[Int]]
completion ([[Int]] -> GeneratedAction
fromBases (forall a. [a] -> [a]
reverse [[Int]]
keep forall a. [a] -> [a] -> [a]
++ [[Int]]
xs))
> = [[Int]] -> [[Int]] -> [[Int]]
go [[Int]]
keep [[Int]]
xs
> | Bool
otherwise = [[Int]] -> [[Int]] -> [[Int]]
go ([Int]
xforall a. a -> [a] -> [a]
:[[Int]]
keep) [[Int]]
xs
> go [[Int]]
keep [[Int]]
_ = forall a. [a] -> [a]
reverse [[Int]]
keep
There is almost certainly a more efficient procedure
for basis-extraction that makes use of the J-order.
What it might be is a question for later.
Helper Functions
================
> backpermute :: [Int] -> [Int] -> [Int]
> backpermute :: [Int] -> [Int] -> [Int]
backpermute = forall a. a -> [a] -> [Int] -> [a]
backpermuteDef (-Int
1)
The call 'backpermute xs is' is equivalent to grabbing the elements
of xs at the given indices 'map (flip (atDef (-1)) xs) is';
however, on lists the lookup is a linear-time operation,
so doing it n times becomes quadratic.
We can improve this by first doing an nlgn sort
to get the indices in order.
Then one single linear scan will suffice to extract the elements,
and we can sort again to put things where they belong.
> backpermuteDef :: a -> [a] -> [Int] -> [a]
> backpermuteDef :: forall a. a -> [a] -> [Int] -> [a]
backpermuteDef a
a [a]
xs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. [a] -> [(Int, b)] -> [(a, b)]
extract [a]
xs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. Num a => [(a, b)] -> [(a, b)]
deltas forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int
0,Int
0)forall a. a -> [a] -> [a]
:)
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0::Int ..]
> where deltas :: [(a, b)] -> [(a, b)]
deltas ((a, b)
x:(a, b)
y:[(a, b)]
ys) = (forall a b. (a, b) -> a
fst (a, b)
y forall a. Num a => a -> a -> a
- forall a b. (a, b) -> a
fst (a, b)
x, forall a b. (a, b) -> b
snd (a, b)
y) forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)]
deltas ((a, b)
yforall a. a -> [a] -> [a]
:[(a, b)]
ys)
> deltas [(a, b)]
_ = []
> extract :: [a] -> [(Int, b)] -> [(a, b)]
extract [a]
ys ((Int, b)
p:[(Int, b)]
ps) = b -> [a] -> [(Int, b)] -> [(a, b)]
grab (forall a b. (a, b) -> b
snd (Int, b)
p) (forall a. Int -> [a] -> [a]
drop (forall a b. (a, b) -> a
fst (Int, b)
p) [a]
ys) [(Int, b)]
ps
> extract [a]
_ [(Int, b)]
_ = []
> grab :: b -> [a] -> [(Int, b)] -> [(a, b)]
grab b
i [a]
ys [(Int, b)]
ns = case [a]
ys of
> (a
y:[a]
_) -> ( a
y,b
i) forall a. a -> [a] -> [a]
: [a] -> [(Int, b)] -> [(a, b)]
extract [a]
ys [(Int, b)]
ns
> [a]
_ -> ( a
a,b
i) forall a. a -> [a] -> [a]
: [a] -> [(Int, b)] -> [(a, b)]
extract [a]
ys [(Int, b)]
ns
> equal :: Eq b => (a -> b) -> a -> a -> Bool
> equal :: forall b a. Eq b => (a -> b) -> a -> a -> Bool
equal a -> b
f a
x a
y = a -> b
f a
x forall a. Eq a => a -> a -> Bool
== a -> b
f a
y
>
>
>
> restrict :: FSMult -> [Int] -> FSMult
> restrict :: FSMult -> [Int] -> FSMult
restrict FSMult
t [Int]
xs
> = [[Int]] -> FSMult
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Eq a => a -> [a] -> Maybe Int
elemIndex [Int]
xs))
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip [Int] -> [Int] -> [Int]
backpermute [Int]
xs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. a -> [a] -> [Int] -> [a]
backpermuteDef []) [Int]
xs
> forall a b. (a -> b) -> a -> b
$ FSMult -> [[Int]]
getTable FSMult
t
> where f :: [[Int]] -> FSMult
f [[Int]]
m = Int -> [[Int]] -> FSMult
FSMult (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
m) [[Int]]
m
I/O
===
>
> app_prec :: Int
> app_prec :: Int
app_prec = Int
10
> instance Show GeneratedAction where
> showsPrec :: Int -> GeneratedAction -> ShowS
showsPrec Int
d GeneratedAction
ga
> = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
app_prec) forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"fromBases "
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) (GeneratedAction -> [[Int]]
bases GeneratedAction
ga)
> instance Read GeneratedAction where
> readsPrec :: Int -> ReadS GeneratedAction
readsPrec Int
d String
r
> = forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
app_prec)
> (\String
x -> [ ([[Int]] -> GeneratedAction
fromBases [[Int]]
bs, String
t)
> | (String
"fromBases",String
s) <- ReadS String
lex String
x
> , ([[Int]]
bs,String
t) <- forall a. Read a => Int -> ReadS a
readsPrec (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) String
s]) String
r
We do not want people giving us arbitrary tables
which might not be associative.
But we really do want to be able to see things.
And since Show/Read are supposed to be inverses,
let's make it happen: go via fromBases and all will be fine.
> instance Show FSMult where
> showsPrec :: Int -> FSMult -> ShowS
showsPrec Int
d FSMult
mt
> = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
app_prec)
> forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"fstable "
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( Bool -> ShowS -> ShowS
showParen Bool
True
> forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"fromBases " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) [[Int]]
bs)
> where bs :: [[Int]]
bs = forall a. Int -> [a] -> [a]
take (FSMult -> Int
basisRows FSMult
mt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSMult -> [[Int]]
getTable
> forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FiniteSemigroupRep a => a -> FSMult
adjoinOne forall a b. (a -> b) -> a -> b
$ forall a. FiniteSemigroupRep a => a -> FSMult
dual FSMult
mt
> instance Read FSMult where
> readsPrec :: Int -> ReadS FSMult
readsPrec Int
d String
r
> = forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
app_prec)
> (\String
x -> [ (forall a. FiniteSemigroupRep a => a -> FSMult
fstable (GeneratedAction
bs :: GeneratedAction), String
t)
> | (String
"fstable",String
s) <- ReadS String
lex String
x
> , (GeneratedAction
bs,String
t) <- forall a. Read a => Int -> ReadS a
readsPrec (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) String
s]) String
r