module Control.Arrow.SF where
import Prelude hiding (init , (.) , id)
import Control.Arrow
import Control.Category
newtype SF a b = SF { unSF :: a -> (b, SF a b) }
runSF :: SF a b -> [a] -> [b]
runSF (SF f0) = go f0 where
go f (x:xs) = let (y, SF f') = f x in y : go f' xs
go _ [] = []
instance Category SF where
id = sf_id
(.) = flip sf_comp
instance Arrow SF where
arr = sf_arr
first = sf_first
second = sf_second
instance ArrowLoop SF where
loop = sf_loop
instance ArrowChoice SF where
left = sf_left
right = sf_right
sf_id :: SF a a
sf_id = u where u = SF $ \x -> (x, u)
sf_comp :: SF a b -> SF b c -> SF a c
sf_comp f g = SF (g `comp` f) where
g `comp` f = \x ->
let (y, f') = unSF f x
(z, g') = unSF g y
in (z, SF (g' `comp` f'))
sf_arr :: (a -> b) -> SF a b
sf_arr f = u where u = SF $ \x -> (f x, u)
sf_first :: SF a b -> SF (a,x) (b,x)
sf_first = u where
u r = SF $ \(x,t) ->
let (y,r') = unSF r x
in ((y,t) , u r')
sf_second :: SF a b -> SF (x,a) (x,b)
sf_second = u where
u r = SF $ \(t,x) ->
let (y,r') = unSF r x
in ((t,y) , u r')
sf_left :: SF a b -> SF (Either a x) (Either b x)
sf_left = u where
u cont = SF $ \ei -> case ei of
Left x -> let (y,cont') = unSF cont x in (Left y, u cont')
Right z -> (Right z, u cont)
sf_right :: SF a b -> SF (Either x a) (Either x b)
sf_right = u where
u cont = SF $ \ei -> case ei of
Right x -> let (y,cont') = unSF cont x in (Right y, u cont')
Left z -> (Left z, u cont)
sf_loop :: SF (a,s) (b,s) -> SF a b
sf_loop f = SF (h f) where
h f x = let (~(y,z),f') = unSF f (x,z)
in (y, SF (h f'))
sf_eitherLoop :: SF (Either a c) (Either b c) -> SF a b
sf_eitherLoop big = SF (go1 big) where
go1 :: SF (Either a c) (Either b c) -> a -> (b, SF a b)
go1 big = \x -> (go2 big) (Left x) where
go2 :: SF (Either a c) (Either b c) -> Either a c -> (b, SF a b)
go2 big = \ei ->
let (ei',big') = unSF big ei
in case ei' of
Left y -> (y, SF (go1 big'))
Right z -> (go2 big') (Right z)
sf_init :: a -> SF a a
sf_init i = SF (h i) where h i x = (i, SF (h x))
sf_loopD :: s -> ((a,s) -> (b,s)) -> SF a b
sf_loopD j f = sf_loop (sf_arr f >>> sf_second (sf_init j))
sf_mealy_ :: s -> (a -> s -> (b,s)) -> SF a b
sf_mealy_ s0 f = go s0 where
go s = SF $ \x -> let (y,t) = f x s in (y, go t)
sf_mealy :: s -> (a -> s -> (b,s)) -> SF a (b,s)
sf_mealy s0 f = go s0 where
go s = SF $ \x -> let yt@(y,t) = f x s in (yt, go t)
sf_eitherMachine :: s -> (Either a s -> Either b s) -> SF a b
sf_eitherMachine s0 f = sf_eitherLoop (sf_arr f >>> sf_right (sf_init s0))
sf_delta :: SF a (a,a)
sf_delta = sf_arr $ \x -> (x,x)
sf_merge :: SF (Either a a) a
sf_merge = sf_arr $ \ei -> case ei of { Left x -> x ; Right y -> y }
sf_compMaybe :: SF a (Maybe b) -> SF b c -> SF a (Maybe c)
sf_compMaybe f g = SF (g `comp` f) where
g `comp` f = \x ->
let (my, f') = unSF f x
(mz, g') = case my of
Just y -> let (z,g') = unSF g y in (Just z, g')
Nothing -> (Nothing, g)
in (mz, SF (g' `comp` f'))
sf_liftMaybe :: SF a b -> SF (Maybe a) (Maybe b)
sf_liftMaybe = u where
u cont = SF $ \ei -> case ei of
Just x -> let (y,cont') = unSF cont x in (Just y, u cont')
Nothing -> (Nothing, u cont)
sf_justA :: SF a (Maybe a)
sf_justA = go where go = SF $ \x -> (Just x , go)
sf_nothingA :: SF x (Maybe a)
sf_nothingA = go where go = SF $ \_ -> (Nothing , go)