module Math.Spe
(
Spe
, (.+.), assemble, (.*.), (<*.), prod, ordProd, (.^), (<^), (><), o
, dx, pointed, ofSize, nonEmpty
, contact
, set, one, x, kBal, bal, par, kList, list, cyc, perm, kSubset, subset
) where
import Data.List
import Control.Applicative
infixl 6 .+.
infixl 7 .*.
infixl 7 <*.
infixr 8 .^
infixr 8 <^
type Spe a c = [a] -> [c]
type BiPar a = Spe a ([a], [a])
(.+.) :: Spe a b -> Spe a c -> Spe a (Either b c)
(.+.) f g us = (Left <$> f us) ++ (Right <$> g us)
assemble :: [Spe a c] -> Spe a c
assemble fs us = fs >>= \f -> f us
biparL :: BiPar a
biparL [] = [([], [])]
biparL us@(u:ut) = ([], us) : [ (u:vs, zs) | (vs, zs) <- biparL ut ]
biparB :: BiPar a
biparB [] = [([], [])]
biparB (u:us) = biparB us >>= \(vs, zs) -> [(u:vs, zs), (vs, u:zs)]
mul :: BiPar a -> Spe a b -> Spe a c -> Spe a (b,c)
mul h f g us = h us >>= \(vs,zs) -> (,) <$> f vs <*> g zs
(.*.) :: Spe a b -> Spe a c -> Spe a (b, c)
(.*.) = mul biparB
(<*.) :: Spe a b -> Spe a c -> Spe a (b, c)
(<*.) = mul biparL
prod' :: BiPar a -> [Spe a b] -> Spe a [b]
prod' h fs us = zipWith ($) fs <$> kEnd h (length fs) us >>= sequence
kEnd :: BiPar a -> Int -> Spe a [[a]]
kEnd _ 0 [] = [[]]
kEnd _ 0 _ = []
kEnd h k us = h us >>= \(b,vs) -> (b:) <$> kEnd h (k1) vs
power :: BiPar a -> Spe a b -> Int -> Spe a [b]
power _ _ 0 = one
power _ f 1 = map return . f
power h f k = map concat . prod' h [power h f j, g, g]
where
(i,j) = divMod k 2; g = power h f i
prod :: [Spe a b] -> Spe a [b]
prod = prod' biparB
ordProd :: [Spe a b] -> Spe a [b]
ordProd = prod' biparL
(.^) :: Spe a b -> Int -> Spe a [b]
(.^) = power biparB
(<^) :: Spe a b -> Int -> Spe a [b]
(<^) = power biparL
(><) :: Spe a b -> Spe a c -> Spe a (b,c)
(><) f g us = (,) <$> f us <*> g us
o :: Spe [a] b -> Spe a c -> Spe a (b, [c])
o f g us = par us >>= f >< mapM g
dx :: Spe (Maybe a) b -> Spe a b
dx f us = f $ Nothing : (Just <$> us)
pointed :: Spe a b -> Spe a (b, a)
pointed f = f >< id
isOfLength :: [a] -> Int -> Bool
[] `isOfLength` n = n == 0
(_:us) `isOfLength` n = n > 0 && us `isOfLength` (n1)
ofSize :: Spe a c -> Int -> Spe a c
(f `ofSize` n) us | us `isOfLength` n = f us
| otherwise = []
nonEmpty :: Spe a c -> Spe a c
nonEmpty _ [] = []
nonEmpty f us = f us
contact :: Ord b => Int -> Spe Int b -> Spe Int b -> Bool
contact n f g = and [ sort (f [1..k]) == sort (g [1..k]) | k<-[1..n] ]
set :: Spe a [a]
set = return
one :: Spe a [b]
one us = [ [] | null us ]
x :: Spe a a
x = id `ofSize` 1
kBal :: Int -> Spe a [[a]]
kBal k = nonEmpty set .^ k
bal :: Spe a [[a]]
bal [] = [[]]
bal us = [ b:bs | (b, vs) <- init (biparB us), bs <- bal vs ]
par :: Spe a [[a]]
par [] = [[]]
par (u:us) = [ (u:b) : bs | (b, vs) <- biparB us, bs <- par vs ]
kList :: Int -> Spe a [a]
kList k = x .^ k
list :: Spe a [a]
list us = kList (length us) us
cyc :: Spe a [a]
cyc [] = []
cyc (u:us) = (u:) <$> list us
perm :: Spe a [[a]]
perm = map fst . (set `o` cyc)
kSubset :: Int -> Spe a [a]
kSubset k = map fst . (set `ofSize` k .*. set)
subset :: Spe a [a]
subset = map fst . biparB