--              Copyright (c) 1996 - 2004 Tim Barbour.

--	$Id: Combinators.hs,v 1.20 2001/11/21 21:24:32 trb Exp $	
module Combinators (
       s, k, i, fp,
       twin, dupl, swap,
       applyPair, cross, dotPair, dotCross, mapPair, applyFst, applySnd, applyArgs,
       betweenFst, betweenSnd,
       tripl, fst3, snd3, thd3, curry3, uncurry3, applyTriple, cross3,
       mapTriple, applyFst3, applySnd3, applyThd3, applyArgs3,
       rotl, rotr,
       rotl4, rotr4,
       applyFs,
       skipNothing, skipNothing3, skipNothing4
       ) where
-- applyPair is now cross
-- useTwice is now applyPair

-- the S combinator
-- is this defn correct ?
s :: (a -> b -> c) -> (a -> b) -> a -> c
s = \f g x -> (f x) (g x)

-- the K combinator
k :: a -> b -> a
k = \x y -> x

-- the I combinator
i :: a -> a
i = id

-- the fixpoint combinator
-- is this identical to Y ?
-- what is its type ?
fp f x | f x == x  = x
       | otherwise = fp f (f x)

-- was called dupl
-- but to what can we rename tripl ?
twin :: a -> (a,a)
twin x = (x,x)
-- for backward compatibility
dupl :: a -> (a,a)
dupl = twin

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

-- was apply2_1
-- apply a pair of functions to one argument
applyPair :: (a -> b, a -> c) -> a -> (b, c)
applyPair (f, g) x = (f x, g x)

-- was apply2_2
-- apply a pair of functions to a pair
cross :: (a -> b, c -> d) -> (a, c) -> (b, d)
cross (f, g) = applyPair (f . fst, g . snd)

-- compose a pair of functions onto one function
dotPair :: (a -> b, a -> c) -> (d -> a) -> (d -> b, d -> c)
dotPair (f, g) h = (f . h, g . h)	

-- compose a pair of functions onto a pair of functions
dotCross :: (a -> b, c -> d) -> (e -> a, f -> c) -> (e -> b, f -> d)
dotCross (f, g) (h, i) = (f . h, g . i)

mapPair :: (a -> b) -> (a, a) -> (b, b)
mapPair = cross . twin

applyFst :: (a -> b) -> (a, c) -> (b, c)
applyFst f = applyPair (f . fst, snd)

applySnd :: (a -> b) -> (c, a) -> (c, b)
applySnd f = applyPair (fst, f . snd)

applyArgs :: (a -> b) -> (c -> d) -> (b -> d -> e) -> (a -> c -> e)
--applyArgs af1 af2 f = (uncurry f) . curry (cross (af1, af2))	  
applyArgs af1 af2 f = \x y -> f (af1 x) (af2 y)

betweenFst :: (a -> b -> c) -> (a, d) -> (b, e) -> c
betweenFst = applyArgs fst fst

betweenSnd :: (a -> b -> c) -> (d, a) -> (e, b) -> c
betweenSnd = applyArgs snd snd

tripl :: a -> (a,a,a)
tripl x = (x,x,x)

fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x

snd3 :: (a,b,c) -> b
snd3 (_,x,_) = x

thd3 :: (a,b,c) -> c
thd3 (_,_,x) = x     

curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 f x y z =  f (x, y, z)

uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
uncurry3 f t = f (fst3 t) (snd3 t) (thd3 t)

applyTriple :: (a -> b, a -> c, a -> d) -> a -> (b,c,d)
applyTriple (f,g,h) x = (f x, g x, h x)

cross3 :: (a -> b, c -> d, e -> f) -> (a,c,e) -> (b,d,f)
cross3 (f,g,h) (x,y,z) = (f x, g y, h z)

mapTriple :: (a -> b) -> (a, a, a) -> (b, b, b)
mapTriple = cross3 . tripl	  

applyFst3 :: (a -> b) -> (a, c, d) -> (b, c, d)
applyFst3 f = applyTriple (f . fst3, snd3, thd3)

applySnd3 :: (a -> b) -> (c, a, d) -> (c, b, d)
applySnd3 f = applyTriple (fst3, f . snd3, thd3)

applyThd3 :: (a -> b) -> (c, d, a) -> (c, d, b)
applyThd3 f = applyTriple (fst3, snd3, f . thd3)

applyArgs3 :: (a -> b) -> (c -> d) -> (e -> f) -> (b -> d -> f -> g) -> (a -> c -> e -> g)
--applyArgs3 af1 af2 af3 f = (uncurry3 f) . curry3 (cross3 (af1, af2, af3))
applyArgs3 af1 af2 af3 f = \x y z -> f (af1 x) (af2 y) (af3 z)

rotl :: (a -> b -> c -> d) -> (b -> c -> a -> d)
rotl f y z x = f x y z

rotr :: (a -> b -> c -> d) -> (c -> a -> b -> d)
rotr f z x y = f x y z

rotl4 :: (a -> b -> c -> d -> e) -> (b -> c -> d -> a -> e)
rotl4 f y z t x = f x y z t

rotr4 :: (a -> b -> c -> d -> e) -> (d -> a -> b -> c -> e)
rotr4 f t x y z = f x y z t

applyFs :: [(a -> b)] -> a -> [b]
applyFs []     _ = []
applyFs (f:fs) x = f x : applyFs fs x

skipNothing :: (a -> b -> b) -> ((Maybe a) -> b -> b)
skipNothing f = \m acc -> maybe acc (flip f acc) m

skipNothing3 :: (a -> b -> c -> c) -> (a -> (Maybe b) -> c -> c)
skipNothing3 f = \x m acc -> maybe acc (rotr f acc x) m

skipNothing4 :: (a -> b -> c -> d -> d) -> (a -> b -> (Maybe c) -> d -> d)
skipNothing4 f = \x y m acc -> maybe acc (rotr4 f acc x y) m