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 .)
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 (n1) 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 (n1) circ) ->- twoN (n1) 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