> {-# 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) >