module Math.Operad.OrderedTree where
import Prelude hiding (mapM)
import Data.Foldable (Foldable, foldMap)
import Data.Traversable
import Data.List (sort, sortBy, intersperse, (\\))
import Control.Applicative
import Data.Ord
import Control.Monad.State hiding (mapM)
import Data.Monoid
import Math.Operad.PPrint
data (Ord a, Show a) => PreDecoratedTree a b = DTLeaf !b |
DTVertex {
vertexType :: !a,
subTrees :: ![PreDecoratedTree a b]}
deriving (Eq, Ord, Read, Show)
vertexArity :: (Ord a, Show a) => PreDecoratedTree a b -> Int
vertexArity t = length (subTrees t)
instance (Ord a, Show a) => Functor (PreDecoratedTree a) where
fmap f (DTLeaf b) = DTLeaf (f b)
fmap f (DTVertex t ts) = DTVertex t (map (fmap f) ts)
instance (Ord a, Show a) => Foldable (PreDecoratedTree a) where
foldMap f (DTLeaf b) = f b
foldMap f (DTVertex _ ts) = mconcat (map (foldMap f) ts)
instance (Ord a, Show a) => Traversable (PreDecoratedTree a) where
traverse f (DTLeaf b) = DTLeaf <$> f b
traverse f (DTVertex t ts) = DTVertex t <$> traverse (traverse f) ts
instance (Ord a, Show a, Show b) => PPrint (PreDecoratedTree a b) where
pp (DTLeaf x) = show x
pp (DTVertex t ts) = "m" ++ show t ++ "(" ++ concat (intersperse "," (map pp ts)) ++ ")"
glueTrees :: (Ord a, Show a) => PreDecoratedTree a (PreDecoratedTree a b) -> PreDecoratedTree a b
glueTrees (DTLeaf newRoot) = newRoot
glueTrees (DTVertex t ts) = DTVertex t (map glueTrees ts)
instance (Ord a, Show a) => Monad (PreDecoratedTree a) where
return = DTLeaf;
a >>= f = glueTrees (fmap f a)
type DecoratedTree a = PreDecoratedTree a Int
data (Ord a, Show a, TreeOrdering t) => OrderedTree a t = OT (DecoratedTree a) t deriving (Eq, Show, Read)
instance (Ord a, Show a, TreeOrdering t) => PPrint (OrderedTree a t) where
pp (OT dect _) = pp dect
instance (Ord a, Show a, TreeOrdering t) => Ord (OrderedTree a t) where
compare (OT s o1) (OT t _) = treeCompare o1 s t
ot :: (Ord a, Show a, TreeOrdering t) => DecoratedTree a -> OrderedTree a t
ot t = OT t ordering
dt :: (Ord a, Show a, TreeOrdering t) => OrderedTree a t -> DecoratedTree a
dt (OT t _) = t
class (Eq t, Show t) => TreeOrdering t where
treeCompare :: (Ord a, Show a) => t -> DecoratedTree a -> DecoratedTree a -> Ordering
treeCompare o t1 t2 = comparePathSequence o t1 (orderedPathSequence t1) t2 (orderedPathSequence t2)
comparePathSequence :: (Ord a, Show a) =>
t -> DecoratedTree a -> ([[a]],Shuffle) -> DecoratedTree a -> ([[a]],Shuffle) -> Ordering
ordering :: t
pathSequence :: (Ord a, Show a) => DecoratedTree a -> ([[a]],Shuffle)
pathSequence (DTLeaf j) = ([[]],[j])
pathSequence (DTVertex l ts) = let
pathSequences = map pathSequence $! ts
paths = concatMap fst $! pathSequences
leaves = concatMap snd $! pathSequences
in (map (l:) $! paths, leaves)
orderedPathSequence :: (Ord a, Show a) => DecoratedTree a -> ([[a]],Shuffle)
orderedPathSequence t = (map fst . sortBy (comparing snd) $ zip ps1 ps2, ps2) where (ps1, ps2) = pathSequence t
data RPathLex = RPathLex deriving (Eq, Ord, Show, Read)
reverseOrder :: Ordering -> Ordering
reverseOrder LT = GT
reverseOrder GT = LT
reverseOrder EQ = EQ
instance TreeOrdering RPathLex where
treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t
else if s == t then EQ
else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)
comparePathSequence _ _ (paths,perms) _ (patht,permt) = let
clS = zipWith (comparing length) paths patht
coS = zipWith compare paths patht
cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS
in
if any (/= EQ) cS then head (filter (/=EQ) cS)
else compare perms permt
ordering = RPathLex
data PathLex = PathLex deriving (Eq, Ord, Show, Read)
instance TreeOrdering PathLex where
treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t
else if s == t then EQ
else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)
comparePathSequence _ _ (paths,perms) _ (patht,permt) = let
clS = zipWith (comparing length) paths patht
coS = zipWith compare paths patht
cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS
in
if any (/= EQ) cs then head (filter (/=EQ) cs)
else compare perms permt
ordering = PathLex
data PathRLex = PathRLex deriving (Eq, Ord, Show, Read)
instance TreeOrdering PathRLex where
treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t
else if s == t then EQ
else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)
comparePathSequence _ _ (paths,perms) _ (patht,permt) = let
clS = zipWith (comparing length) paths patht
coS = zipWith compare paths patht
cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS
in
if any (/= EQ) cs then head (filter (/=EQ) cs)
else reverseOrder $ compare perms permt
ordering = PathRLex
data RPathRLex = RPathRLex deriving (Eq, Ord, Show, Read)
instance TreeOrdering RPathRLex where
treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t
else if s == t then EQ
else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)
comparePathSequence _ _ (paths,perms) _ (patht,permt) = let
clS = zipWith (comparing length) paths patht
coS = zipWith compare paths patht
cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS
in
if any (/= EQ) cS then head (filter (/=EQ) cS)
else reverseOrder $ compare perms permt
ordering = RPathRLex
data ForestLex = ForestLex deriving (Eq, Ord, Show)
instance TreeOrdering ForestLex where
treeCompare o s t = comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)
comparePathSequence _ (DTLeaf k) _ (DTLeaf l) _ = compare l k
comparePathSequence _ (DTLeaf _) _ _ _ = LT
comparePathSequence _ _ _ (DTLeaf _) _ = GT
comparePathSequence o s (paths, perms) t (patht, permt) = let
c1 = compare (vertexArity s) (vertexArity t)
c2 = compare (vertexType s) (vertexType t)
ls = map (sort . leafOrder) (sortBy (comparing minimalLeaf) (subTrees s))
lt = map (sort . leafOrder) (sortBy (comparing minimalLeaf) (subTrees t))
c3s = zipWith (\sl tl -> case comparing length sl tl of
LT -> LT
GT -> GT
EQ -> reverseOrder $ compare sl tl) ls lt
c3f = filter (/= EQ) c3s
c4f = filter (/= EQ) $ zipWith
(treeCompare o)
(sortBy (comparing minimalLeaf) (subTrees s))
(sortBy (comparing minimalLeaf) (subTrees t))
in
if c1 /= EQ then c1
else if c2 /= EQ then c2
else if not (null c3f) then head c3f
else if null c4f then EQ
else head c4f
ordering = ForestLex
corolla :: (Ord a, Show a) => a -> [Int] -> DecoratedTree a
corolla label leaflabels =
if null leaflabels
then error "The operadic Buchberger, and many other algorithms, require the absence of 0-ary operations."
else DTVertex label (map DTLeaf leaflabels)
leaf :: (Ord a, Show a) => Int -> DecoratedTree a
leaf n = DTLeaf n
isLeaf :: (Ord a, Show a) => DecoratedTree a -> Bool
isLeaf (DTLeaf _) = True
isLeaf _ = False
isCorolla :: (Ord a, Show a) => DecoratedTree a -> Bool
isCorolla = not . isLeaf
relabelLeaves :: (Ord a, Show a) => DecoratedTree a -> [b] -> PreDecoratedTree a b
relabelLeaves tree newLabels = fst $ runState (mapM (\_ -> do; (x:xs) <- get; put xs; return x) tree) newLabels
leafOrder :: (Ord a, Show a) => DecoratedTree a -> [Int]
leafOrder = foldMap (:[])
minimalLeaf :: (Ord a, Show a, Ord b) => PreDecoratedTree a b -> b
minimalLeaf (DTLeaf lbl) = lbl
minimalLeaf vertex = minimum $ map minimalLeaf (subTrees vertex)
nLeaves :: (Ord a, Show a) => DecoratedTree a -> Int
nLeaves (DTLeaf _) = 1
nLeaves vertex = sum $ map nLeaves (subTrees vertex)
arityDegree :: (Ord a, Show a) => DecoratedTree a -> Int
arityDegree t = nLeaves t 1
type Shuffle = [Int]
isSorted :: (Ord a, Show a) => [a] -> Bool
isSorted xs = and $ zipWith (<=) xs (tail xs)
isShuffle :: Shuffle -> Bool
isShuffle as = (sort as) == [1..length as] &&
any (\k -> isShuffleIJ as k (length ask)) [1..length as]
isShuffleIJ :: Shuffle -> Int -> Int -> Bool
isShuffleIJ as i j = isSorted [a | a <- as, a <= i] &&
isSorted [a | a <- as, a > i] &&
length as == i+j
isShuffleIPQ :: Shuffle -> Int -> Int -> Bool
isShuffleIPQ as i p = let
initSegment = take i as
finalSegment = drop i as
upperTree = take p finalSegment
latterTree = drop p finalSegment
in initSegment == [1 .. length initSegment] &&
isSorted upperTree &&
isSorted latterTree
applyPerm :: Show a => Shuffle -> [a] -> [a]
applyPerm s is =
map (is!!) (map (subtract 1) s)
invApplyPerm :: Shuffle -> [a] -> [a]
invApplyPerm sh lst = map snd . sortBy (comparing fst) $ zip sh lst
kSubsets :: Int -> [Int] -> [[Int]]
kSubsets 0 _ = [[]]
kSubsets k ss = if length ss == k then [ss]
else if length ss < k then []
else do
map sort $ (map ((head ss):) $ kSubsets (k1) (tail ss)) ++ kSubsets k (tail ss)
allShuffles :: Int -> Int -> Int -> [Shuffle]
allShuffles i p q = if p<0 || q<0 || i<0 then error "Positive numbers, please!" else
do
let later = [i+1..i+p+q]
pS <- kSubsets p later
let qS = later \\ pS
return $ [1..i] ++ pS ++ qS