> {-# OPTIONS_HADDOCK show-extensions #-}
> {-|
> Module    : Data.Representation.FiniteSemigroup.Order
> Copyright : (c) 2023 Dakotah Lambert
> License   : MIT

> This module provides support for quasiordered semigroups.
> -}

> module Data.Representation.FiniteSemigroup.Order
>     ( OrderedSemigroup(unordered,orel)
>     , odual, sdual
>     , assignOrder
>     , assignOrderBy
>     , fromBasesWith
>     , syntacticOrder
>     , trivialOrder
>     ) where

> import Data.Representation.FiniteSemigroup.Base

> import Data.IntSet (IntSet)
> import qualified Data.IntMap as IntMap
> import qualified Data.IntSet as IntSet

> -- |A semigroup alongside a preorder (reflexive and transitive).
> -- The constructor itself is not exported
> -- so as to enforce this condition.
> data OrderedSemigroup s
>     = OrderedSemigroup { forall s. OrderedSemigroup s -> s
unordered :: s
>                        , forall s. OrderedSemigroup s -> [(Int, Int)]
orel :: [(Int,Int)]
>                        } deriving (OrderedSemigroup s -> OrderedSemigroup s -> Bool
forall s. Eq s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrderedSemigroup s -> OrderedSemigroup s -> Bool
$c/= :: forall s. Eq s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
== :: OrderedSemigroup s -> OrderedSemigroup s -> Bool
$c== :: forall s. Eq s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
Eq, OrderedSemigroup s -> OrderedSemigroup s -> Bool
OrderedSemigroup s -> OrderedSemigroup s -> Ordering
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 {s}. Ord s => Eq (OrderedSemigroup s)
forall s. Ord s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
forall s.
Ord s =>
OrderedSemigroup s -> OrderedSemigroup s -> Ordering
forall s.
Ord s =>
OrderedSemigroup s -> OrderedSemigroup s -> OrderedSemigroup s
min :: OrderedSemigroup s -> OrderedSemigroup s -> OrderedSemigroup s
$cmin :: forall s.
Ord s =>
OrderedSemigroup s -> OrderedSemigroup s -> OrderedSemigroup s
max :: OrderedSemigroup s -> OrderedSemigroup s -> OrderedSemigroup s
$cmax :: forall s.
Ord s =>
OrderedSemigroup s -> OrderedSemigroup s -> OrderedSemigroup s
>= :: OrderedSemigroup s -> OrderedSemigroup s -> Bool
$c>= :: forall s. Ord s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
> :: OrderedSemigroup s -> OrderedSemigroup s -> Bool
$c> :: forall s. Ord s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
<= :: OrderedSemigroup s -> OrderedSemigroup s -> Bool
$c<= :: forall s. Ord s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
< :: OrderedSemigroup s -> OrderedSemigroup s -> Bool
$c< :: forall s. Ord s => OrderedSemigroup s -> OrderedSemigroup s -> Bool
compare :: OrderedSemigroup s -> OrderedSemigroup s -> Ordering
$ccompare :: forall s.
Ord s =>
OrderedSemigroup s -> OrderedSemigroup s -> Ordering
Ord)
> instance FiniteSemigroupRep s =>
>     FiniteSemigroupRep (OrderedSemigroup s) where
>         fsappend :: OrderedSemigroup s -> Int -> Int -> Int
fsappend = forall a. FiniteSemigroupRep a => a -> Int -> Int -> Int
fsappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. OrderedSemigroup s -> s
unordered
>         fstable :: OrderedSemigroup s -> FSMult
fstable = forall a. FiniteSemigroupRep a => a -> FSMult
fstable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. OrderedSemigroup s -> s
unordered
>         fssize :: OrderedSemigroup s -> Int
fssize = forall a. FiniteSemigroupRep a => a -> Int
fssize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. OrderedSemigroup s -> s
unordered
>         fsnbases :: OrderedSemigroup s -> Int
fsnbases = forall a. FiniteSemigroupRep a => a -> Int
fsnbases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. OrderedSemigroup s -> s
unordered

> -- |Associate the reflexive, transitive closure of the given relation
> -- as an order for the given semigroup.
> assignOrder :: FiniteSemigroupRep s =>
>                [(Int,Int)] -> s -> OrderedSemigroup s
> assignOrder :: forall s.
FiniteSemigroupRep s =>
[(Int, Int)] -> s -> OrderedSemigroup s
assignOrder [(Int, Int)]
o s
s = forall s. s -> [(Int, Int)] -> OrderedSemigroup s
OrderedSemigroup s
s ([(Int, Int)] -> [(Int, Int)]
rtclose [(Int, Int)]
o')
>     where o' :: [(Int, Int)]
o' = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Int
x,Int
x)) [Int
0..forall a. FiniteSemigroupRep a => a -> Int
fssize s
s forall a. Num a => a -> a -> a
- Int
1] forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
o

> -- |Derive an order from the given function
> -- and associate it with the given semigroup.
> assignOrderBy :: FiniteSemigroupRep s =>
>               (s -> Int -> Int -> Bool) -> s -> OrderedSemigroup s
> assignOrderBy :: forall s.
FiniteSemigroupRep s =>
(s -> Int -> Int -> Bool) -> s -> OrderedSemigroup s
assignOrderBy s -> Int -> Int -> Bool
f s
s = forall s.
FiniteSemigroupRep s =>
[(Int, Int)] -> s -> OrderedSemigroup s
assignOrder [(Int, Int)]
o s
s
>     where o :: [(Int, Int)]
o = [(Int
x,Int
y) | Int
x <- [Int]
xs, Int
y <- [Int]
xs, s -> Int -> Int -> Bool
f s
s Int
x Int
y]
>           xs :: [Int]
xs = [Int
0 .. forall a. FiniteSemigroupRep a => a -> Int
fssize s
s forall a. Num a => a -> a -> a
- Int
1]

> -- |Create a 'GeneratedAction' alongside an order
> -- derived from the given function.
> fromBasesWith :: (GeneratedAction -> Int -> Int -> Bool) -> [[Int]]
>               -> OrderedSemigroup GeneratedAction
> fromBasesWith :: (GeneratedAction -> Int -> Int -> Bool)
-> [[Int]] -> OrderedSemigroup GeneratedAction
fromBasesWith GeneratedAction -> Int -> Int -> Bool
f = forall s.
FiniteSemigroupRep s =>
(s -> Int -> Int -> Bool) -> s -> OrderedSemigroup s
assignOrderBy GeneratedAction -> Int -> Int -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Int]] -> GeneratedAction
fromBases

> -- |The order where \(x\leq y\) if and only if
> -- whenever \(uyv\) maps the given object into the given set,
> -- so too does \(uxv\).
> syntacticOrder :: Int -> IntSet
>                -> GeneratedAction -> Int -> Int -> Bool
> syntacticOrder :: Int -> IntSet -> GeneratedAction -> Int -> Int -> Bool
syntacticOrder Int
q0 IntSet
f GeneratedAction
s Int
x Int
y = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int, Int) -> Bool
coimpl [(Int, Int)]
ps
>     where final :: IntSet
final = GeneratedAction -> IntSet -> Int -> IntSet
mapsInto GeneratedAction
s IntSet
f Int
q0
>           xs :: [Int]
xs = [Int
0 .. forall a. FiniteSemigroupRep a => a -> Int
fssize GeneratedAction
s forall a. Num a => a -> a -> a
- Int
1]
>           ps :: [(Int, Int)]
ps = [([Int] -> Int
eval [Int
u,Int
x,Int
v], [Int] -> Int
eval [Int
u,Int
y,Int
v]) | Int
u <- [Int]
xs, Int
v <- [Int]
xs]
>           eval :: [Int] -> Int
eval = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (forall a. FiniteSemigroupRep a => a -> Int -> Int -> Int
fsappend GeneratedAction
s)
>           coimpl :: (Int, Int) -> Bool
coimpl (Int, Int)
p = (forall a b. (a, b) -> a
fst (Int, Int)
p Int -> IntSet -> Bool
`IntSet.member` IntSet
final)
>                      Bool -> Bool -> Bool
|| (forall a b. (a, b) -> b
snd (Int, Int)
p Int -> IntSet -> Bool
`IntSet.notMember` IntSet
final)

> -- |The order where \(x\leq y\) if and only if \(x=y\).
> trivialOrder :: s -> Int -> Int -> Bool
> trivialOrder :: forall s. s -> Int -> Int -> Bool
trivialOrder s
_ = forall a. Eq a => a -> a -> Bool
(==)

> -- |Return the given semigroup with its order reversed.
> odual :: OrderedSemigroup s -> OrderedSemigroup s
> odual :: forall s. OrderedSemigroup s -> OrderedSemigroup s
odual OrderedSemigroup s
s = OrderedSemigroup s
s { orel :: [(Int, Int)]
orel = forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int)
p -> (forall a b. (a, b) -> b
snd (Int, Int)
p, forall a b. (a, b) -> a
fst (Int, Int)
p)) forall a b. (a -> b) -> a -> b
$ forall s. OrderedSemigroup s -> [(Int, Int)]
orel OrderedSemigroup s
s }
> -- |Return the given semigroup with its multiplication reversed.
> sdual :: FiniteSemigroupRep s =>
>          OrderedSemigroup s -> OrderedSemigroup FSMult
> sdual :: forall s.
FiniteSemigroupRep s =>
OrderedSemigroup s -> OrderedSemigroup FSMult
sdual OrderedSemigroup s
s = OrderedSemigroup s
s { unordered :: FSMult
unordered = forall a. FiniteSemigroupRep a => a -> FSMult
dual (forall s. OrderedSemigroup s -> s
unordered OrderedSemigroup s
s) }

> -- |Given a relation as a collection of pairs,
> -- return its reflexive transitive closure.
> rtclose :: [(Int,Int)] -> [(Int,Int)]
> rtclose :: [(Int, Int)] -> [(Int, Int)]
rtclose [(Int, Int)]
ps = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
>              (\(Int, IntSet)
p -> forall a b. (a -> b) -> [a] -> [b]
map ((,) (forall a b. (a, b) -> a
fst (Int, IntSet)
p)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IntSet.toList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (Int, IntSet)
p)
>              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IntMap.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
>              forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
(==)) (\(IntMap IntSet
_,IntMap IntSet
a) -> (IntMap IntSet
a, IntMap IntSet -> IntMap IntSet
go IntMap IntSet
a))
>              forall a b. (a -> b) -> a -> b
$ (IntMap IntSet
base, IntMap IntSet -> IntMap IntSet
go IntMap IntSet
base)
>     where xs :: [Int]
xs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int, Int)
p [Int]
a -> forall a b. (a, b) -> a
fst (Int, Int)
p forall a. a -> [a] -> [a]
: forall a b. (a, b) -> b
snd (Int, Int)
p forall a. a -> [a] -> [a]
: [Int]
a) [] [(Int, Int)]
ps
>           base :: IntMap IntSet
base = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IntMap.fromListWith IntSet -> IntSet -> IntSet
IntSet.union
>                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> IntSet
IntSet.singleton)
>                  forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Int
x,Int
x)) [Int]
xs) forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
ps
>           go :: IntMap IntSet -> IntMap IntSet
go IntMap IntSet
m = forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map
>                  (forall b. (Int -> b -> b) -> b -> IntSet -> b
IntSet.foldr
>                   (\Int
a IntSet
b -> IntSet -> IntSet -> IntSet
IntSet.union (IntMap IntSet
m forall a. IntMap a -> Int -> a
IntMap.! Int
a) IntSet
b)
>                   IntSet
IntSet.empty)
>                  IntMap IntSet
m

> -- |Given a relation, remove all elements of the form $(x,x)$,
> -- then, for each element of the form $(x,z)$,
> -- if, for some $y$, $(x,y)$ and $(y,z)$ are both elements
> -- of what remains after removing $(x,z)$, then remove $(x,z)$.
> rtreduce :: [(Int,Int)] -> [(Int,Int)]
> rtreduce :: [(Int, Int)] -> [(Int, Int)]
rtreduce [(Int, Int)]
ps = [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
tred [] [(Int, Int)]
r
>     where r :: [(Int, Int)]
r = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==)) [(Int, Int)]
ps
>           tred :: [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
tred [(Int, Int)]
xs [] = forall a. [a] -> [a]
reverse [(Int, Int)]
xs
>           tred [(Int, Int)]
xs (~(Int
a,Int
b):[(Int, Int)]
ys)
>               = let ps' :: [(Int, Int)]
ps' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==))
>                           forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> [(Int, Int)]
rtclose ([(Int, Int)]
xs forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
ys)
>                     sucs :: IntSet
sucs = [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) -> b
snd
>                            forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Int
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Int, Int)]
ps'
>                     pres :: IntSet
pres = [Int] -> IntSet
IntSet.fromList
>                            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Int
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, Int)]
ps'
>                     xs' :: [(Int, Int)]
xs' = if ( IntSet -> Bool
IntSet.null
>                              forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IntSet.intersection IntSet
sucs IntSet
pres)
>                           then (Int
a,Int
b)forall a. a -> [a] -> [a]
:[(Int, Int)]
xs
>                           else [(Int, Int)]
xs
>                 in [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
tred [(Int, Int)]
xs' [(Int, Int)]
ys

> -- |From the documentation: precedence of function application is 10
> app_prec :: Int
> app_prec :: Int
app_prec = Int
10

> instance (FiniteSemigroupRep s, Show s) =>
>     Show (OrderedSemigroup s) where
>         showsPrec :: Int -> OrderedSemigroup s -> ShowS
showsPrec Int
d OrderedSemigroup s
os
>             = 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
"assignOrder "
>               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, Int)] -> [(Int, Int)]
rtreduce forall a b. (a -> b) -> a -> b
$ forall s. OrderedSemigroup s -> [(Int, Int)]
orel OrderedSemigroup s
os)
>               forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
>               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) (forall s. OrderedSemigroup s -> s
unordered OrderedSemigroup s
os)

> instance (FiniteSemigroupRep s, Read s) =>
>     Read (OrderedSemigroup s) where
>         readsPrec :: Int -> ReadS (OrderedSemigroup s)
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 s.
FiniteSemigroupRep s =>
[(Int, Int)] -> s -> OrderedSemigroup s
assignOrder [(Int, Int)]
ps s
u, String
z)
>                      | (String
"assignOrder",String
s) <- ReadS String
lex String
x
>                      , ([(Int, Int)]
ps,String
t) <- forall a. Read a => Int -> ReadS a
readsPrec (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) String
s
>                      , (s
u,String
z) <- forall a. Read a => Int -> ReadS a
readsPrec (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) String
t]) String
r