module Math.Spe
(
Spe, BTree (..)
, add, assemble, mul, mulL, prod, prodL, power, powerL
, compose, o, kDiff, diff
, set, one, x, ofSize, nonempty, kBal, bal, par, kList, list
, cyc, perm, kSubset, subset, btree
) where
import Data.List
type Spe a c = [a] -> [c]
type Splitter a = [a] -> [([a], [a])]
data BTree a = Empty | BNode a (BTree a) (BTree a) deriving (Show, Eq)
decompose :: Splitter a -> Int -> [a] -> [[[a]]]
decompose _ 0 [] = [[]]
decompose _ 0 _ = []
decompose h k xs = [ b:bs | (b,ys) <- h xs, bs <- decompose h (k1) ys ]
splitL :: Splitter a
splitL [] = [([], [])]
splitL xs@(x:xt) = ([], xs) : [ (x:as, bs) | (as, bs) <- splitL xt ]
splitB :: Splitter a
splitB [] = [([], [])]
splitB (x:xs) = splitB xs >>= \(ys, zs) -> [(x:ys, zs), (ys, x:zs)]
add :: Spe a b -> Spe a c -> Spe a (Either b c)
add f g xs = map Left (f xs) ++ map Right (g xs)
assemble :: [Spe a c] -> Spe a c
assemble fs xs = fs >>= \f -> f xs
genericMul :: Splitter a -> Spe a b -> Spe a c -> Spe a (b,c)
genericMul h f g xs = [ (y, z) | (ys, zs) <- h xs, y <- f ys, z <- g zs ]
mul = genericMul splitB
mulL = genericMul splitL
genericProd :: Splitter a -> [Spe a b] -> Spe a [b]
genericProd h fs xs =
let n = length fs
in [ zipWith ($) fs bs | bs <- decompose h n xs ] >>= sequence
prod = genericProd splitB
prodL = genericProd splitL
genericPower :: Splitter a -> Spe a b -> Int -> Spe a [b]
genericPower h f k = genericProd h $ replicate k f
power = genericPower splitB
powerL = genericPower splitL
compose :: Spe [a] b -> Spe a c -> Spe a (b, [c])
compose f g xs = [ (y, ys) | bs <- par xs, y <- f bs, ys <- mapM g bs ]
o = compose
kDiff :: Int -> Spe (Maybe a) b -> Spe a b
kDiff k f xs = f $ replicate k Nothing ++ map Just xs
diff = kDiff 1
set :: Spe a [a]
set = return
one :: Spe a [a]
one [] = [[]]
one _ = []
x :: Spe a [a]
x xs@[_] = [xs]
x _ = []
ofSize :: Spe a c -> Int -> Spe a c
(f `ofSize` n) xs | xs `isOfLength` n = f xs
| otherwise = []
isOfLength :: [a] -> Int -> Bool
[] `isOfLength` n = n == 0
(x:xs) `isOfLength` n = n > 0 && xs `isOfLength` (n1)
nonempty :: Spe a c -> Spe a c
nonempty _ [] = []
nonempty f xs = f xs
kBal :: Int -> Spe a [[a]]
kBal 0 = \xs -> [ [] | null xs ]
kBal k = nonempty set `power` k
bal :: Spe a [[a]]
bal [] = [[]]
bal xs = [ b:bs | (b, ys) <- init (splitB xs), bs <- bal ys ]
par :: Spe a [[a]]
par [] = [[]]
par (x:xs) = [ (x:b) : bs | (b, ys) <- splitB xs, bs <- par ys ]
kList :: Int -> Spe a [a]
kList 0 = one
kList k = map concat . (x `power` k)
list :: Spe a [a]
list xs = kList (length xs) xs
cyc :: Spe a [a]
cyc [] = []
cyc (x:xs) = map (x:) $ list xs
perm :: Spe a [[a]]
perm = map fst . (set `o` cyc)
kSubset :: Int -> Spe a ([a], [a])
kSubset k = (set `ofSize` k) `mul` set
subset :: Spe a ([a], [a])
subset = set `mul` set
btree :: Spe a (BTree a)
btree [] = [ Empty ]
btree xs = [ BNode a t1 t2 | ([a],(t1,t2)) <- (x `mul` (btree `mul` btree)) xs ]