> {-# LANGUAGE CPP, BangPatterns #-}

> module Control.SF.SF where

#if __GLASGOW_HASKELL__ >= 610
> import Control.Category
> import Prelude hiding ((.), id)
#endif

> import Control.Arrow
> import Control.Arrow.ArrowP
> import Control.Arrow.Operations


> newtype SF a b = SF { forall a b. SF a b -> a -> (b, SF a b)
runSF :: (a -> (b, SF a b)) }

#if __GLASGOW_HASKELL__ >= 610
> instance Category SF where
>   id :: forall a. SF a a
id = (a -> (a, SF a a)) -> SF a a
forall a b. (a -> (b, SF a b)) -> SF a b
SF a -> (a, SF a a)
forall {b}. b -> (b, SF b b)
h where h :: b -> (b, SF b b)
h b
x = (b
x, (b -> (b, SF b b)) -> SF b b
forall a b. (a -> (b, SF a b)) -> SF a b
SF b -> (b, SF b b)
h)
>   SF b c
g . :: forall b c a. SF b c -> SF a b -> SF a c
. SF a b
f = (a -> (c, SF a c)) -> SF a c
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF a b -> SF b c -> a -> (c, SF a c)
forall {a} {b} {b}. SF a b -> SF b b -> a -> (b, SF a b)
h SF a b
f SF b c
g)
>     where
>       h :: SF a b -> SF b b -> a -> (b, SF a b)
h SF a b
f SF b b
g a
x =
>         let (b
y, SF a b
f') = SF a b -> a -> (b, SF a b)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF a b
f a
x
>             (b
z, SF b b
g') = SF b b -> b -> (b, SF b b)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF b b
g b
y
>         in SF a b
f' SF a b -> (b, SF a b) -> (b, SF a b)
forall a b. a -> b -> b
`seq` SF b b
g' SF b b -> (b, SF a b) -> (b, SF a b)
forall a b. a -> b -> b
`seq` (b
z, (a -> (b, SF a b)) -> SF a b
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF a b -> SF b b -> a -> (b, SF a b)
h SF a b
f' SF b b
g'))

> instance Arrow SF where
>   arr :: forall b c. (b -> c) -> SF b c
arr b -> c
f = SF b c
g
>     where g :: SF b c
g = (b -> (c, SF b c)) -> SF b c
forall a b. (a -> (b, SF a b)) -> SF a b
SF (\b
x -> (b -> c
f b
x, SF b c
g))
>   first :: forall b c d. SF b c -> SF (b, d) (c, d)
first SF b c
f = ((b, d) -> ((c, d), SF (b, d) (c, d))) -> SF (b, d) (c, d)
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF b c -> (b, d) -> ((c, d), SF (b, d) (c, d))
forall {a} {a} {b}. SF a a -> (a, b) -> ((a, b), SF (a, b) (a, b))
g SF b c
f)
>     where
>       g :: SF a a -> (a, b) -> ((a, b), SF (a, b) (a, b))
g SF a a
f (a
x, b
z) = SF a a
f' SF a a -> ((a, b), SF (a, b) (a, b)) -> ((a, b), SF (a, b) (a, b))
forall a b. a -> b -> b
`seq` ((a
y, b
z), ((a, b) -> ((a, b), SF (a, b) (a, b))) -> SF (a, b) (a, b)
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF a a -> (a, b) -> ((a, b), SF (a, b) (a, b))
g SF a a
f'))
>         where (a
y, SF a a
f') = SF a a -> a -> (a, SF a a)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF a a
f a
x
>   SF b c
f &&& :: forall b c c'. SF b c -> SF b c' -> SF b (c, c')
&&& SF b c'
g = (b -> ((c, c'), SF b (c, c'))) -> SF b (c, c')
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF b c -> SF b c' -> b -> ((c, c'), SF b (c, c'))
forall {a} {a} {b}. SF a a -> SF a b -> a -> ((a, b), SF a (a, b))
h SF b c
f SF b c'
g)
>     where
>       h :: SF a a -> SF a b -> a -> ((a, b), SF a (a, b))
h SF a a
f SF a b
g a
x =
>         let (a
y, SF a a
f') = SF a a -> a -> (a, SF a a)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF a a
f a
x
>             (b
z, SF a b
g') = SF a b -> a -> (b, SF a b)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF a b
g a
x 
>         in ((a
y, b
z), (a -> ((a, b), SF a (a, b))) -> SF a (a, b)
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF a a -> SF a b -> a -> ((a, b), SF a (a, b))
h SF a a
f' SF a b
g'))
>   SF b c
f *** :: forall b c b' c'. SF b c -> SF b' c' -> SF (b, b') (c, c')
*** SF b' c'
g = ((b, b') -> ((c, c'), SF (b, b') (c, c'))) -> SF (b, b') (c, c')
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF b c -> SF b' c' -> (b, b') -> ((c, c'), SF (b, b') (c, c'))
forall {a} {a} {a} {b}.
SF a a -> SF a b -> (a, a) -> ((a, b), SF (a, a) (a, b))
h SF b c
f SF b' c'
g)
>     where
>       h :: SF a a -> SF a b -> (a, a) -> ((a, b), SF (a, a) (a, b))
h SF a a
f SF a b
g (a, a)
x =
>         let (a
y, SF a a
f') = SF a a -> a -> (a, SF a a)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF a a
f ((a, a) -> a
forall a b. (a, b) -> a
fst (a, a)
x)
>             (b
z, SF a b
g') = SF a b -> a -> (b, SF a b)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF a b
g ((a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
x) 
>         in ((a
y, b
z), ((a, a) -> ((a, b), SF (a, a) (a, b))) -> SF (a, a) (a, b)
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF a a -> SF a b -> (a, a) -> ((a, b), SF (a, a) (a, b))
h SF a a
f' SF a b
g'))
#else
> instance Arrow SF where
>   arr f = g
>     where g = SF (\x -> (f x, g))
>   f >>> g = SF (h f g)
>     where
>       h f g x =
>         let (y, f') = runSF f x
>             (z, g') = runSF g y
>         in (z, SF (h f' g'))
>   first f = SF (g f)
>     where
>       g f (x, z) = ((y, z), SF (g f'))
>         where (y, f') = runSF f x
>   f &&& g = SF (h f g)
>     where
>       h f g x =
>         let (y, f') = runSF f x
>             (z, g') = runSF g x 
>         in ((y, z), SF (h f' g'))
>   f *** g = SF (h f g)
>     where
>       h f g x =
>         let (y, f') = runSF f (fst x)
>             (z, g') = runSF g (snd x) 
>         in ((y, z), SF (h f' g'))
#endif

> instance ArrowLoop SF where
>   loop :: forall b d c. SF (b, d) (c, d) -> SF b c
loop SF (b, d) (c, d)
sf = (b -> (c, SF b c)) -> SF b c
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF (b, d) (c, d) -> b -> (c, SF b c)
forall {a} {b} {b}. SF (a, b) (b, b) -> a -> (b, SF a b)
g SF (b, d) (c, d)
sf)
>     where
>       g :: SF (a, b) (b, b) -> a -> (b, SF a b)
g SF (a, b) (b, b)
f a
x = SF (a, b) (b, b)
f' SF (a, b) (b, b) -> (b, SF a b) -> (b, SF a b)
forall a b. a -> b -> b
`seq` (b
y, (a -> (b, SF a b)) -> SF a b
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF (a, b) (b, b) -> a -> (b, SF a b)
g SF (a, b) (b, b)
f'))
>         where ((b
y, b
z), SF (a, b) (b, b)
f') = SF (a, b) (b, b) -> (a, b) -> ((b, b), SF (a, b) (b, b))
forall a b. SF a b -> a -> (b, SF a b)
runSF SF (a, b) (b, b)
f (a
x, b
z)

> instance ArrowChoice SF where
>    left :: forall b c d. SF b c -> SF (Either b d) (Either c d)
left SF b c
sf = (Either b d -> (Either c d, SF (Either b d) (Either c d)))
-> SF (Either b d) (Either c d)
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF b c -> Either b d -> (Either c d, SF (Either b d) (Either c d))
forall {a} {a} {b}.
SF a a -> Either a b -> (Either a b, SF (Either a b) (Either a b))
g SF b c
sf)
>        where 
>          g :: SF a a -> Either a b -> (Either a b, SF (Either a b) (Either a b))
g SF a a
f Either a b
x = case Either a b
x of
>                    Left a
a -> let (a
y, SF a a
f') = SF a a -> a -> (a, SF a a)
forall a b. SF a b -> a -> (b, SF a b)
runSF SF a a
f a
a in SF a a
f' SF a a
-> (Either a b, SF (Either a b) (Either a b))
-> (Either a b, SF (Either a b) (Either a b))
forall a b. a -> b -> b
`seq` (a -> Either a b
forall a b. a -> Either a b
Left a
y, (Either a b -> (Either a b, SF (Either a b) (Either a b)))
-> SF (Either a b) (Either a b)
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF a a -> Either a b -> (Either a b, SF (Either a b) (Either a b))
g SF a a
f'))
>                    Right b
b -> (b -> Either a b
forall a b. b -> Either a b
Right b
b, (Either a b -> (Either a b, SF (Either a b) (Either a b)))
-> SF (Either a b) (Either a b)
forall a b. (a -> (b, SF a b)) -> SF a b
SF (SF a a -> Either a b -> (Either a b, SF (Either a b) (Either a b))
g SF a a
f))
> 
> instance ArrowCircuit SF where
>   delay :: forall b. b -> SF b b
delay b
i = (b -> (b, SF b b)) -> SF b b
forall a b. (a -> (b, SF a b)) -> SF a b
SF (b -> b -> (b, SF b b)
forall {b}. b -> b -> (b, SF b b)
f b
i)
>     where f :: b -> b -> (b, SF b b)
f b
i b
x = (b
i, (b -> (b, SF b b)) -> SF b b
forall a b. (a -> (b, SF a b)) -> SF a b
SF (b -> b -> (b, SF b b)
f b
x))

> run :: SF a b -> [a] -> [b]
> run :: forall a b. SF a b -> [a] -> [b]
run SF a b
_ [] = []
> run (SF a -> (b, SF a b)
f) (a
x:[a]
xs) =
>   let (b
y, SF a b
f') = a -> (b, SF a b)
f a
x 
>   in b
y b -> [b] -> [b]
forall a b. a -> b -> b
`seq` SF a b
f' SF a b -> [b] -> [b]
forall a b. a -> b -> b
`seq` (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: SF a b -> [a] -> [b]
forall a b. SF a b -> [a] -> [b]
run SF a b
f' [a]
xs)
> 
> unfold :: SF () a -> [a]
> unfold :: forall a. SF () a -> [a]
unfold = (SF () a -> [()] -> [a]) -> [()] -> SF () a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip SF () a -> [()] -> [a]
forall a b. SF a b -> [a] -> [b]
run [()]
inp
>   where inp :: [()]
inp = () () -> [()] -> [()]
forall a. a -> [a] -> [a]
: [()]
inp
>
> 
> nth :: Int -> SF () a -> a
> nth :: forall a. Int -> SF () a -> a
nth Int
n (SF () -> (a, SF () a)
f) = a
x a -> a -> a
forall a b. a -> b -> b
`seq` if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then a
x else Int -> SF () a -> a
forall a. Int -> SF () a -> a
nth (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) SF () a
f'
>   where (a
x, SF () a
f') = () -> (a, SF () a)
f ()
> 
> nth' :: Int -> (b, ((), b) -> (a, b)) -> a
> nth' :: forall b a. Int -> (b, ((), b) -> (a, b)) -> a
nth' !Int
n (b
i, ((), b) -> (a, b)
f) = Int
n Int -> a -> a
forall a b. a -> b -> b
`seq` b
i b -> a -> a
forall a b. a -> b -> b
`seq` ((), b) -> (a, b)
f (((), b) -> (a, b)) -> a -> a
forall a b. a -> b -> b
`seq` Int -> b -> a
forall {t}. (Eq t, Num t) => t -> b -> a
aux Int
n b
i
>   where
>     aux :: t -> b -> a
aux !t
n !b
i = a
x a -> a -> a
forall a b. a -> b -> b
`seq` b
i' b -> a -> a
forall a b. a -> b -> b
`seq` if t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 then a
x else t -> b -> a
aux (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) b
i'
>       where (a
x, b
i') = ((), b) -> (a, b)
f ((), b
i)
>