Ticket #2722: T2722.hs

File T2722.hs, 23.7 KB (added by igloo, 2 years ago)
Line 
1{-# LANGUAGE Arrows, GADTs, Rank2Types #-}
2
3module Main (main) where
4
5import Control.Arrow
6import qualified Control.Category
7
8type ObjIn = Event ()
9type ObjOut = (String, Int)
10type GameObj = SF ObjIn ObjOut
11
12testObj :: GameObj
13testObj = proc _hit -> do
14    returnA -< ("testObj", 1)
15
16process :: [GameObj] -> SF () [ObjOut]
17process objs = proc _ -> do
18    rec
19        gamestate <- par logic objs
20            -< gamestate
21    returnA -< gamestate
22
23logic :: [ObjOut] -> [sf] -> [(ObjIn, sf)]
24logic gamestate objs = map route objs
25  where
26    route obj =
27        (if null (foo gamestate) then NoEvent else NoEvent, obj)
28
29foo :: [ObjOut] -> [ObjOut]
30foo [] = []
31foo objs = concat (collisions objs)
32  where
33    collisions [] = []
34    collisions (out:_) =
35        [[out, out'] | out' <- objs, out `collide` out']
36
37collide :: ObjOut -> ObjOut -> Bool
38collide (_, _) (_, _) = True
39
40main :: IO ()
41main = do
42    putStrLn . show $ embed (process [testObj]) ((), [(1.0, Nothing)])
43
44----------------------------------------------------------------------
45
46type DTime = Double
47
48data SF a b = SF {sfTF :: a -> Transition a b}
49
50data SF' a b where
51    SFArr   :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b
52    SFSScan :: !(DTime -> a -> Transition a b)
53               -> !(c -> a -> Maybe (c, b)) -> !c -> b
54               -> SF' a b
55    SFEP   :: !(DTime -> Event a -> Transition (Event a) b)
56              -> !(c -> a -> (c, b, b)) -> !c -> b
57              -> SF' (Event a) b
58    SFCpAXA :: !(DTime -> a -> Transition a d)
59               -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d)
60               -> SF' a d
61    SF' :: !(DTime -> a -> Transition a b) -> SF' a b
62
63type Transition a b = (SF' a b, b)
64
65sfTF' :: SF' a b -> (DTime -> a -> Transition a b)
66sfTF' (SFArr tf _)       = tf
67sfTF' (SFSScan tf _ _ _) = tf
68sfTF' (SFEP tf _ _ _)    = tf
69sfTF' (SFCpAXA tf _ _ _) = tf
70sfTF' (SF' tf)           = tf
71
72sfArr :: FunDesc a b -> SF' a b
73sfArr FDI         = sfId
74sfArr (FDC b)     = sfConst b
75sfArr (FDE f fne) = sfArrE f fne
76sfArr (FDG f)     = sfArrG f
77
78sfId :: SF' a a
79sfId = sf
80    where
81        sf = SFArr (\_ a -> (sf, a)) FDI
82
83sfConst :: b -> SF' a b
84sfConst b = sf
85    where
86        sf = SFArr (\_ _ -> (sf, b)) (FDC b)
87
88sfArrE :: (Event a -> b) -> b -> SF' (Event a) b
89sfArrE f fne = sf
90    where
91        sf  = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea))
92                    (FDE f fne)
93
94sfArrG :: (a -> b) -> SF' a b
95sfArrG f = sf
96    where
97        sf = SFArr (\_ a -> (sf, f a)) (FDG f)
98
99sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b
100sfSScan f c b = sf
101    where
102        sf = SFSScan tf f c b
103        tf _ a = case f c a of
104                     Nothing       -> (sf, b)
105                     Just (c', b') -> (sfSScan f c' b', b')
106
107sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b
108sfEP f c bne = sf
109    where
110        sf = SFEP (\_ ea -> case ea of
111                                 NoEvent -> (sf, bne)
112                                 Event a -> let
113                                                (c', b, bne') = f c a
114                                            in
115                                                (sfEP f c' bne', b))
116                  f
117                  c
118                  bne
119
120data FunDesc a b where
121    FDI :: FunDesc a a
122    FDC :: b -> FunDesc a b
123    FDE :: (Event a -> b) -> b -> FunDesc (Event a) b
124    FDG :: (a -> b) -> FunDesc a b
125
126fdFun :: FunDesc a b -> (a -> b)
127fdFun FDI       = id
128fdFun (FDC b)   = const b
129fdFun (FDE f _) = f
130fdFun (FDG f)   = f
131
132fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c
133fdComp FDI           fd2     = fd2
134fdComp fd1           FDI     = fd1
135fdComp (FDC b)       fd2     = FDC ((fdFun fd2) b)
136fdComp _             (FDC c) = FDC c
137
138fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne)
139    where
140        f2 = fdFun fd2
141fdComp (FDG f1) (FDE f2 f2ne) = FDG f
142    where
143        f a = case f1 a of
144                  NoEvent -> f2ne
145                  f1a     -> f2 f1a
146fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1)
147
148fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d)
149fdPar FDI     FDI     = FDI
150fdPar FDI     (FDC d) = FDG (\(~(a, _)) -> (a, d))
151fdPar FDI     fd2     = FDG (\(~(a, c)) -> (a, (fdFun fd2) c))
152fdPar (FDC b) FDI     = FDG (\(~(_, c)) -> (b, c))
153fdPar (FDC b) (FDC d) = FDC (b, d)
154fdPar (FDC b) fd2     = FDG (\(~(_, c)) -> (b, (fdFun fd2) c))
155fdPar fd1     fd2     = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c))
156
157fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c)
158fdFanOut FDI     FDI     = FDG (\a -> (a, a))
159fdFanOut FDI     (FDC c) = FDG (\a -> (a, c))
160fdFanOut FDI     fd2     = FDG (\a -> (a, (fdFun fd2) a))
161fdFanOut (FDC b) FDI     = FDG (\a -> (b, a))
162fdFanOut (FDC b) (FDC c) = FDC (b, c)
163fdFanOut (FDC b) fd2     = FDG (\a -> (b, (fdFun fd2) a))
164fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne
165    where
166       f1f2 NoEvent      = f1f2ne
167       f1f2 ea@(Event _) = (f1 ea, f2 ea)
168
169       f1f2ne = (f1ne, f2ne)
170fdFanOut fd1 fd2 =
171    FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a))
172
173vfyNoEv :: Event a -> b -> b
174vfyNoEv NoEvent b = b
175vfyNoEv _       _  = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event."
176
177instance Control.Category.Category SF where
178     (.) = flip compPrim
179     id = SF $ \x -> (sfId,x)
180
181instance Arrow SF where
182    arr    = arrPrim
183    first  = firstPrim
184    second = secondPrim
185    (***)  = parSplitPrim
186    (&&&)  = parFanOutPrim
187
188{-# NOINLINE arrPrim #-}
189arrPrim :: (a -> b) -> SF a b
190arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)}
191
192{-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-}
193
194arrEPrim :: (Event a -> b) -> SF (Event a) b
195arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)}
196
197compPrim :: SF a b -> SF b c -> SF a c
198compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
199    where
200        tf0 a0 = (cpXX sf1 sf2, c0)
201            where
202                (sf1, b0) = tf10 a0
203                (sf2, c0) = tf20 b0
204
205cpXX :: SF' a b -> SF' b c -> SF' a c
206cpXX (SFArr _ fd1)       sf2               = cpAX fd1 sf2
207cpXX sf1                 (SFArr _ fd2)     = cpXA sf1 fd2
208cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =
209    sfSScan f (s1, b, s2, c) c
210    where
211        f (s1, b, s2, c) a =
212            let
213                (u, s1',  b') = case f1 s1 a of
214                                    Nothing       -> (True, s1, b)
215                                    Just (s1',b') -> (False,  s1', b')
216            in
217                case f2 s2 b' of
218                    Nothing | u         -> Nothing
219                            | otherwise -> Just ((s1', b', s2, c), c)
220                    Just (s2', c') -> Just ((s1', b', s2', c'), c')
221cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) =
222    sfSScan f (s1, eb, s2, cne) cne
223    where
224        f (s1, eb, s2, cne) a =
225            case f1 s1 a of
226                Nothing ->
227                    case eb of
228                        NoEvent -> Nothing
229                        Event b ->
230                            let (s2', c, cne') = f2 s2 b
231                            in
232                                Just ((s1, eb, s2', cne'), c)
233                Just (s1', eb') ->
234                    case eb' of
235                        NoEvent -> Just ((s1', eb', s2, cne), cne)
236                        Event b ->
237                            let (s2', c, cne') = f2 s2 b
238                            in
239                                Just ((s1', eb', s2', cne'), c)
240
241
242cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) =
243    sfSScan f (s1, bne, s2, c) c
244    where
245        f (s1, bne, s2, c) ea =
246            let (u, s1', b', bne') = case ea of
247                                         NoEvent -> (True, s1, bne, bne)
248                                         Event a ->
249                                             let (s1', b, bne') = f1 s1 a
250                                             in
251                                                  (False, s1', b, bne')
252            in
253                case f2 s2 b' of
254                    Nothing | u         -> Nothing
255                            | otherwise -> Just (seq s1' (s1', bne', s2, c), c)
256                    Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c')
257
258cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) =
259    sfEP f (s1, s2, cne) (vfyNoEv bne cne)
260    where
261        f (s1, s2, cne) a =
262            case f1 s1 a of
263                (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne)
264                (s1', Event b, NoEvent) ->
265                    let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne')
266                _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event."
267
268cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =
269    cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)
270cpXX sf1@(SFEP _ _ _ _) (SFCpAXA _ (FDG f21) sf22 fd23) =
271    cpXX (cpXG sf1 f21) (cpXA sf22 fd23)
272cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP _ _ _ _) =
273    cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2)
274cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =
275    cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23
276cpXX sf1 sf2 = SF' tf
277    where
278        tf dt a = (cpXX sf1' sf2', c)
279            where
280                (sf1', b) = (sfTF' sf1) dt a
281                (sf2', c) = (sfTF' sf2) dt b
282
283cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d
284cpAXA FDI     sf2 fd3     = cpXA sf2 fd3
285cpAXA fd1     sf2 FDI     = cpAX fd1 sf2
286cpAXA (FDC b) sf2 fd3     = cpCXA b sf2 fd3
287cpAXA _       _   (FDC d) = sfConst d
288cpAXA fd1     sf2 fd3     =
289    cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2
290    where
291        cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d)
292                    -> SF' b c -> SF' a d
293        cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) =
294            sfArr (fdComp (fdComp fd1 fd2) fd3)
295        cpAXAAux fd1 _ fd3 _ sf2@(SFSScan _ _ _ _) =
296            cpAX fd1 (cpXA sf2 fd3)
297        cpAXAAux fd1 _ fd3 _ sf2@(SFEP _ _ _ _) =
298            cpAX fd1 (cpXA sf2 fd3)
299        cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) =
300            cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3)
301        cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3
302            where
303                tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c)
304                    where
305                        (sf2', c) = (sfTF' sf2) dt (f1 a)
306
307cpAX :: FunDesc a b -> SF' b c -> SF' a c
308cpAX FDI           sf2 = sf2
309cpAX (FDC b)       sf2 = cpCX b sf2
310cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2
311cpAX (FDG f1)      sf2 = cpGX f1 sf2
312
313cpXA :: SF' a b -> FunDesc b c -> SF' a c
314cpXA sf1 FDI           = sf1
315cpXA _   (FDC c)       = sfConst c
316cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne
317cpXA sf1 (FDG f2)      = cpXG sf1 f2
318
319cpCX :: b -> SF' b c -> SF' a c
320cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b)
321
322cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c
323cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne)
324cpCX b (SFCpAXA _ fd21 sf22 fd23) =
325    cpCXA ((fdFun fd21) b) sf22 fd23
326cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI
327    where
328        tf dt _ = (cpCX b sf2', c)
329            where
330                (sf2', c) = (sfTF' sf2) dt b
331
332cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d
333cpCXA b sf2 FDI     = cpCX b sf2
334cpCXA _ _   (FDC c) = sfConst c
335cpCXA b sf2 fd3     = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2
336    where
337        cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d)
338                    -> SF' b c -> SF' a d
339        cpCXAAux _ b _ f3 (SFArr _ fd2)     = sfConst (f3 ((fdFun fd2) b))
340        cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c)
341            where
342                f' s _ = case f s b of
343                             Nothing -> Nothing
344                             Just (s', c') -> Just (s', f3 c')
345        cpCXAAux _ b _   f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne))
346        cpCXAAux _ b fd3 _  (SFCpAXA _ fd21 sf22 fd23) =
347            cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3)
348        cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3
349            where
350                tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c)
351                    where
352                        (sf2', c) = (sfTF' sf2) dt b
353
354cpGX :: (a -> b) -> SF' b c -> SF' a c
355cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2
356    where
357        cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c
358        cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)
359        cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
360        cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =
361            cpAXA (fdComp fd1 fd21) sf22 fd23
362        cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI
363            where
364                tf dt a = (cpGXAux fd1 f1 sf2', c)
365                    where
366                        (sf2', c) = (sfTF' sf2) dt (f1 a)
367
368cpXG :: SF' a b -> (b -> c) -> SF' a c
369cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1
370    where
371        cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c
372        cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)
373        cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b)
374            where
375                f' s a = case f s a of
376                             Nothing -> Nothing
377                             Just (s', b') -> Just (s', f2 b')
378        cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne)
379            where
380                f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne')
381        cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) =
382            cpAXA fd11 sf12 (fdComp fd22 fd2)
383        cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2
384            where
385                tf dt a = (cpXGAux fd2 f2 sf1', f2 b)
386                    where
387                        (sf1', b) = (sfTF' sf1) dt a
388
389cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c
390cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2
391    where
392        cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b
393                   -> SF' b c -> SF' (Event a) c
394        cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)
395        cpEXAux _ f1 _   (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
396        cpEXAux _ f1 f1ne (SFEP _ f2 s cne) =
397            sfEP f (s, cne) (vfyNoEv f1ne cne)
398            where
399                f scne@(s, cne) a =
400                    case (f1 (Event a)) of
401                        NoEvent -> (scne, cne, cne)
402                        Event b ->
403                            let (s', c, cne') = f2 s b in ((s', cne'), c, cne')
404        cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) =
405            cpAXA (fdComp fd1 fd21) sf22 fd23
406        cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI
407            where
408                tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c)
409                    where
410                        (sf2', c) =
411                            case ea of
412                                NoEvent -> (sfTF' sf2) dt f1ne
413                                _       -> (sfTF' sf2) dt (f1 ea)
414
415cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c
416cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1
417    where
418        cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c
419                   -> SF' a (Event b) -> SF' a c
420        cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)
421        cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb)
422            where
423                f' s a = case f s a of
424                             Nothing -> Nothing
425                             Just (s', NoEvent) -> Just (s', f2ne)
426                             Just (s', eb')     -> Just (s', f2 eb')
427        cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) =
428            sfEP f s (vfyNoEv ebne f2ne)
429            where
430                f s a =
431                    case f1 s a of
432                        (s', NoEvent, NoEvent) -> (s', f2ne,  f2ne)
433                        (s', eb,      NoEvent) -> (s', f2 eb, f2ne)
434                        _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event."
435        cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) =
436            cpAXA fd11 sf12 (fdComp fd13 fd2)
437        cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2
438            where
439                tf dt a = (cpXEAux fd2 f2 f2ne sf1',
440                           case eb of NoEvent -> f2ne; _ -> f2 eb)
441                    where
442                        (sf1', eb) = (sfTF' sf1) dt a
443
444firstPrim :: SF a b -> SF (a,c) (b,c)
445firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
446    where
447        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
448            where
449                (sf1, b0) = tf10 a0
450
451fpAux :: SF' a b -> SF' (a,c) (b,c)
452fpAux (SFArr _ FDI)       = sfId
453fpAux (SFArr _ (FDC b))   = sfArrG (\(~(_, c)) -> (b, c))
454fpAux (SFArr _ fd1)       = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))
455fpAux sf1 = SF' tf
456    where
457        tf dt ~(a, c) = (fpAux sf1', (b, c))
458            where
459                (sf1', b) = (sfTF' sf1) dt a
460
461secondPrim :: SF a b -> SF (c,a) (c,b)
462secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
463    where
464        tf0 ~(c0, a0) = (spAux sf1, (c0, b0))
465            where
466                (sf1, b0) = tf10 a0
467
468spAux :: SF' a b -> SF' (c,a) (c,b)
469spAux (SFArr _ FDI)       = sfId
470spAux (SFArr _ (FDC b))   = sfArrG (\(~(c, _)) -> (c, b))
471spAux (SFArr _ fd1)       = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))
472spAux sf1 = SF' tf
473    where
474        tf dt ~(c, a) = (spAux sf1', (c, b))
475            where
476                (sf1', b) = (sfTF' sf1) dt a
477
478parSplitPrim :: SF a b -> SF c d  -> SF (a,c) (b,d)
479parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
480    where
481        tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0))
482            where
483                (sf1, b0) = tf10 a0
484                (sf2, d0) = tf20 c0
485
486        psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d)
487        psXX (SFArr _ fd1)       (SFArr _ fd2)       = sfArr (fdPar fd1 fd2)
488        psXX (SFArr _ FDI)       sf2                 = spAux sf2
489        psXX (SFArr _ (FDC b))   sf2                 = psCX b sf2
490        psXX (SFArr _ fd1)       sf2                 = psAX (fdFun fd1) sf2
491        psXX sf1                 (SFArr _ FDI)       = fpAux sf1
492        psXX sf1                 (SFArr _ (FDC d))   = psXC sf1 d
493        psXX sf1                 (SFArr _ fd2)       = psXA sf1 (fdFun fd2)
494        psXX sf1 sf2 = SF' tf
495            where
496                tf dt ~(a, c) = (psXX sf1' sf2', (b, d))
497                    where
498                        (sf1', b) = (sfTF' sf1) dt a
499                        (sf2', d) = (sfTF' sf2) dt c
500
501        psCX :: b -> SF' c d -> SF' (a,c) (b,d)
502        psCX b (SFArr _ fd2)       = sfArr (fdPar (FDC b) fd2)
503        psCX b sf2                 = SF' tf
504            where
505                tf dt ~(_, c) = (psCX b sf2', (b, d))
506                    where
507                        (sf2', d) = (sfTF' sf2) dt c
508
509        psXC :: SF' a b -> d -> SF' (a,c) (b,d)
510        psXC (SFArr _ fd1)       d = sfArr (fdPar fd1 (FDC d))
511        psXC sf1                 d = SF' tf
512            where
513                tf dt ~(a, _) = (psXC sf1' d, (b, d))
514                    where
515                        (sf1', b) = (sfTF' sf1) dt a
516
517        psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d)
518        psAX f1 (SFArr _ fd2)       = sfArr (fdPar (FDG f1) fd2)
519        psAX f1 sf2                 = SF' tf
520            where
521                tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d))
522                    where
523                        (sf2', d) = (sfTF' sf2) dt c
524
525        psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d)
526        psXA (SFArr _ fd1)       f2 = sfArr (fdPar fd1 (FDG f2))
527        psXA sf1                 f2 = SF' tf
528            where
529                tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))
530                    where
531                        (sf1', b) = (sfTF' sf1) dt a
532
533parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
534parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
535    where
536        tf0 a0 = (pfoXX sf1 sf2, (b0, c0))
537            where
538                (sf1, b0) = tf10 a0
539                (sf2, c0) = tf20 a0
540
541        pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c)
542        pfoXX (SFArr _ fd1)       (SFArr _ fd2)       = sfArr(fdFanOut fd1 fd2)
543        pfoXX (SFArr _ FDI)       sf2                 = pfoIX sf2
544        pfoXX (SFArr _ (FDC b))   sf2                 = pfoCX b sf2
545        pfoXX (SFArr _ fd1)       sf2                 = pfoAX (fdFun fd1) sf2
546        pfoXX sf1                 (SFArr _ FDI)       = pfoXI sf1
547        pfoXX sf1                 (SFArr _ (FDC c))   = pfoXC sf1 c
548        pfoXX sf1                 (SFArr _ fd2)       = pfoXA sf1 (fdFun fd2)
549        pfoXX sf1 sf2 = SF' tf
550            where
551                tf dt a = (pfoXX sf1' sf2', (b, c))
552                    where
553                        (sf1', b) = (sfTF' sf1) dt a
554                        (sf2', c) = (sfTF' sf2) dt a
555
556        pfoIX :: SF' a c -> SF' a (a ,c)
557        pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2)
558        pfoIX sf2 = SF' tf
559            where
560                tf dt a = (pfoIX sf2', (a, c))
561                    where
562                        (sf2', c) = (sfTF' sf2) dt a
563
564        pfoXI :: SF' a b -> SF' a (b ,a)
565        pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)
566        pfoXI sf1 = SF' tf
567            where
568                tf dt a = (pfoXI sf1', (b, a))
569                    where
570                        (sf1', b) = (sfTF' sf1) dt a
571
572        pfoCX :: b -> SF' a c -> SF' a (b ,c)
573        pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2)
574        pfoCX b sf2 = SF' tf
575            where
576                tf dt a = (pfoCX b sf2', (b, c))
577                    where
578                        (sf2', c) = (sfTF' sf2) dt a
579
580        pfoXC :: SF' a b -> c -> SF' a (b ,c)
581        pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c))
582        pfoXC sf1 c = SF' tf
583            where
584                tf dt a = (pfoXC sf1' c, (b, c))
585                    where
586                        (sf1', b) = (sfTF' sf1) dt a
587
588        pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c)
589        pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2)
590        pfoAX f1 sf2 = SF' tf
591            where
592                tf dt a = (pfoAX f1 sf2', (f1 a, c))
593                    where
594                        (sf2', c) = (sfTF' sf2) dt a
595
596        pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c)
597        pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2))
598        pfoXA sf1 f2 = SF' tf
599            where
600                tf dt a = (pfoXA sf1' f2, (b, f2 a))
601                    where
602                        (sf1', b) = (sfTF' sf1) dt a
603
604instance ArrowLoop SF where
605    loop = loopPrim
606
607loopPrim :: SF (a,c) (b,c) -> SF a b
608loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
609    where
610        tf0 a0 = (loopAux sf1, b0)
611            where
612                (sf1, (b0, c0)) = tf10 (a0, c0)
613
614        loopAux :: SF' (a,c) (b,c) -> SF' a b
615        loopAux (SFArr _ FDI) = sfId
616        loopAux (SFArr _ (FDC (b, _))) = sfConst b
617        loopAux (SFArr _ fd1) =
618            sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b)
619        loopAux sf1 = SF' tf
620            where
621                tf dt a = (loopAux sf1', b)
622                    where
623                        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)
624
625par :: Functor col =>
626    (forall sf . (a -> col sf -> col (b, sf)))
627    -> col (SF b c)
628    -> SF a (col c)
629par rf sfs0 = SF {sfTF = tf0}
630    where
631        tf0 a0 =
632            let bsfs0 = rf a0 sfs0
633                sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
634                sfs   = fmap fst sfcs0
635                cs0   = fmap snd sfcs0
636            in
637                (parAux rf sfs, cs0)
638
639parAux :: Functor col =>
640    (forall sf . (a -> col sf -> col (b, sf)))
641    -> col (SF' b c)
642    -> SF' a (col c)
643parAux rf sfs = SF' tf
644    where
645        tf dt a =
646            let bsfs  = rf a sfs
647                sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
648                sfs'  = fmap fst sfcs'
649                cs    = fmap snd sfcs'
650            in
651                (parAux rf sfs', cs)
652
653embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
654embed sf0 (a0, dtas) = b0 : loop a0 sf dtas
655    where
656        (sf, b0) = (sfTF sf0) a0
657
658        loop _ _ [] = []
659        loop a_prev sf ((dt, ma) : dtas) =
660            b : (a `seq` b `seq` (loop a sf' dtas))
661            where
662                a        = maybe a_prev id ma
663                (sf', b) = (sfTF' sf) dt a
664
665----------------------------------------------------------------------
666
667data Event a = NoEvent
668             | Event a
669
670usrErr :: String -> String -> String -> a
671usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)