module Math.Operad.OrderedTree where
import Prelude hiding (mapM)
import Data.Foldable (Foldable, foldMap)
import Data.Traversable
import Data.List (sort, sortBy, intersperse, nub, findIndices)
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)) ++ ")"
vertexMap :: (Ord a, Show a, Ord b, Show b) =>
(a -> b) -> PreDecoratedTree a c -> PreDecoratedTree b c
vertexMap _ (DTLeaf i) = DTLeaf i
vertexMap f (DTVertex t ts) = DTVertex (f t) (map (vertexMap f) 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
reverseOrder :: Ordering -> Ordering
reverseOrder LT = GT
reverseOrder GT = LT
reverseOrder EQ = EQ
data PathPerm = PathPerm deriving (Eq, Ord, Show, Read)
instance TreeOrdering PathPerm 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 = PathPerm
data RPathPerm = RPathPerm deriving (Eq, Ord, Show, Read)
instance TreeOrdering RPathPerm 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 = RPathPerm
data PathRPerm = PathRPerm deriving (Eq, Ord, Show, Read)
instance TreeOrdering PathRPerm 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 = PathRPerm
data RPathRPerm = RPathRPerm deriving (Eq, Ord, Show, Read)
instance TreeOrdering RPathRPerm 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 = RPathRPerm
data PermPath = PermPath deriving (Eq, Ord, Show, Read)
instance TreeOrdering PermPath 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
test1 = compare perms permt
in
if test1 /= EQ then test1
else if any (/= EQ) cs then head (filter (/=EQ) cs) else EQ
ordering = PermPath
data PermRPath = PermRPath deriving (Eq, Ord, Show, Read)
instance TreeOrdering PermRPath 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
test1 = compare perms permt
in
if test1 /= EQ then test1
else if any (/= EQ) cS then head (filter (/=EQ) cS) else EQ
ordering = PermRPath
data RPermPath = RPermPath deriving (Eq, Ord, Show, Read)
instance TreeOrdering RPermPath 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
test1 = reverseOrder $ compare perms permt
in
if test1 /= EQ then test1
else if any (/= EQ) cs then head (filter (/=EQ) cs) else EQ
ordering = RPermPath
data RPermRPath = RPermRPath deriving (Eq, Ord, Show, Read)
instance TreeOrdering RPermRPath 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
test1 = reverseOrder $ compare perms permt
in
if test1 /= EQ then test1
else if any (/= EQ) cS then head (filter (/=EQ) cS) else EQ
ordering = RPermRPath
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)
applyAt :: (a -> a) -> Int -> [a] -> [a]
applyAt f n as = take n as ++ [f (as !! n)] ++ drop (n+1) as
lastNonzero :: (Num a) => [a] -> Int
lastNonzero as = let
ras = reverse as
dwz = dropWhile (==0) ras
lnzi = length dwz 1
in lnzi
allShPerm :: Int -> [Int] -> [[[Int]]]
allShPerm 0 as = [replicate (length as) []]
allShPerm n as = do
let
lastIndex = filter (>=0) [lastNonzero as]
indices = nub $ (findIndices (>1) as) ++ lastIndex
i <- indices
p <- allShPerm (n1) (applyAt (subtract 1) i as)
return (applyAt (++[n]) i p)
allShuffles :: Int -> Int -> Int -> [Shuffle]
allShuffles i p q = map concat $ allShPerm (i+p+q) ((replicate (i1) 1) ++ [p+1] ++ (replicate q 1))