module Lava.Patterns where



import Control.Monad

import Lava.Model



infixr 6 .<., .>.

(.<.) :: (b -> c) -> (a -> b) -> (a -> c)
(.<.) = (.)

(.>.) :: (a -> b) -> (b -> c) -> (a -> c)
(.>.) = flip (.)

swap :: (a,b) -> (b,a)
swap (a,b) = (b,a)

swapl :: [a] -> [a]
swapl [a,b] = [b,a]

copy :: a -> (a,a)
copy a = (a,a)

halveList :: [a] -> ([a],[a])
halveList as = (as1,as2)
  where
    half      = length as `div` 2
    (as1,as2) = splitAt half as

zipp :: ([a],[b]) -> [(a,b)]
zipp ([],[])      = []
zipp (a:as, b:bs) = (a,b) : zipp (as, bs)
zipp _ = error "Lava.Patterns.zipp: Different lengths"

unzipp :: [(a,b)] -> ([a],[b])
unzipp = unzip

riffle :: [a] -> [a]
riffle = halveList .>. zipp .>. unpair

unriffle :: [a] -> [a]
unriffle = pair .>. unzipp .>. append

pair :: [a] -> [(a,a)]
pair (x:y:xs) = (x,y) : pair xs
pair _        = []

unpair :: [(a,a)] -> [a]
unpair []          = []
unpair ((x,y):xys) = x : y : unpair xys

append :: ([a],[a]) -> [a]
append = uncurry (++)

mon :: Monad m => (a -> b) -> (a -> m b)
mon = (return .)
  -- Make a function monadic, e.g. so that it can be composed with other monadic
  -- computations using (>=>).



infixr 5 ->-, -<-
infixr 4 -|-

(->-) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
(->-) = (>=>)

(-<-) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
(-<-) = (<=<)

serial :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
serial = (>=>)

compose :: Monad m => [a -> m a] -> (a -> m a)
compose []     = return
compose (c:cs) = c >=> compose cs

composeN :: Monad m => Int -> (a -> m a) -> (a -> m a)
composeN n = compose . replicate n

(-|-) :: Monad m => (a -> m b) -> (c -> m d) -> ((a,c) -> m (b,d))
circ1 -|- circ2 = \(a,c) -> liftM2 (,) (circ1 a) (circ2 c)

par :: Monad m => (a -> m b) -> (c -> m d) -> ((a,c) -> m (b,d))
par = (-|-)

parl :: Monad m => ([a] -> m [b]) -> ([a] -> m [b]) -> ([a] -> m [b])
parl circ1 circ2 = halveList .>. (circ1 -|- circ2) ->- mon append

two :: Monad m => ([a] -> m [b]) -> ([a] -> m [b])
two circ = parl circ circ

ilv :: Monad m => ([a] -> m [b]) -> ([a] -> m [b])
ilv circ = unriffle .>. two circ ->- mon riffle

iter
    :: Monad m
    => Int -> ((a -> m b) -> (a -> m b)) -> ((a -> m b) -> (a -> m b))
iter 0 comb = id
iter n comb = comb . iter (n-1) comb

twoN :: Monad m => Int -> ([a] -> m [b]) -> ([a] -> m [b])
twoN n = iter n two

ilvN :: Monad m => Int -> ([a] -> m [b]) -> ([a] -> m [b])
ilvN n = iter n ilv

bfly :: Monad m => Int -> ([a] -> m [a]) -> ([a] -> m [a])
bfly 0 circ = return
bfly n circ = ilv (bfly (n-1) circ) ->- twoN (n-1) circ

pmap :: Monad m => ((a,a) -> m (b,b)) -> ([a] -> m [b])
pmap circ = pair .>. mapM circ ->- mon unpair

tri :: Monad m => (a -> m a) -> ([a] -> m [a])
tri circ []     = return []
tri circ (a:as) = liftM (a:) $ (tri circ -<- mapM circ) as

mirror :: Monad m => ((a,b) -> m (c,d)) -> ((b,a) -> m (d,c))
mirror circ = swap .>. circ ->- mon swap

row :: Monad m => ((a,b) -> m (c,a)) -> ((a,[b]) -> m ([c],a))
row circ (a,[])    = return ([],a)
row circ (a, b:bs) = do
    (c,a')   <- circ (a,b)
    (cs,a'') <- row circ (a',bs)
    return (c:cs, a'')

column :: Monad m => ((a,b) -> m (b,c)) -> (([a],b) -> m (b,[c]))
column = mirror . row . mirror

grid :: Monad m => ((a,b) -> m (b,a)) -> (([a],[b]) -> m ([b],[a]))
grid = row . column