(intermediate state) moving to TPDB.Pretty
[box] / src / exotic / Strategy.hs
1 {-# language PatternSignatures #-}
2
3 module Strategy where
4
5 import Control.Concurrent
6 import Data.Maybe ( catMaybes )
7 import Control.Monad ( forM )
8 import Control.Exception 
9 import System.IO
10
11 -- | TODO: these should be newtypes.
12 -- there should be some monad (or arrow?) instance
13 type Computer a b =  ( a -> IO ( Maybe b ) )
14 type Transformer a b c d =  ( a -> IO ( Maybe ( b, c -> d ) ) )
15
16 -- | if f is succesful, then p, else q.
17 -- this means we commit to the first branch once we start it.
18 committed_choice :: Transformer a b c d -> Computer b c
19                  -> Computer a d
20                  -> Computer a d
21 committed_choice f p q = \ c -> do
22   mf <- f c
23   case mf of
24       Nothing -> q c
25       Just ( d, g ) -> fmap (fmap g) $ p d
26
27 -- | like   parallel [ andthen f p, q ]
28 -- but as soon as  f  succeeds,   q  is killed,
29 -- meaning that then,  f p  must be successful.
30 parallel_committed_choice f p q = \ c -> do
31     out <- newChan
32     f_pid <- forkIO $ do mf <- f c ; writeChan out $ Left mf
33     q_pid <- forkIO $ do mx <- q c ; writeChan out $ Right mx
34     let waiter k = if 0 == k then return Nothing else do
35             res <- readChan out `Control.Exception.catch` \ ( e::AsyncException) -> do killThread f_pid ; killThread q_pid ; return $ Left Nothing
36             case res of
37                 Left ( Just (d, g)) -> do
38                     killThread q_pid
39                     fmap ( fmap g ) $ p d
40                 Right ( Just x ) -> do
41                     killThread f_pid
42                     return $ Just x
43                 _ -> waiter (k-1)
44     waiter 2
45
46 -- | start all in parallel (trying to prove the same claim).
47 -- first one wins (and kills others)
48 parallel :: [ Computer a b ] -> Computer a b
49 parallel ps c = do
50     out <- newChan
51     pids <- forM ps $ \ p -> forkIO $ do
52         o <- p c `Control.Exception.catch` \ (e :: AsyncException) -> do
53               hPutStrLn stderr "******* caught ***********"
54               return Nothing
55         writeChan out o
56     let handler 0 = return Nothing
57         handler k = do
58             res <- readChan out `Control.Exception.catch` \ ( e::AsyncException) -> do forM pids killThread ; return Nothing
59             case res of
60                 Nothing -> handler (k-1)
61                 Just x -> do
62                    hPutStrLn stderr "*************** result ***************"
63                    forM pids killThread 
64                    hPutStrLn stderr "*************** killed others ***************"
65                    return $ Just x
66     handler ( length ps )   `Control.Exception.catch`
67                 ( \ (e :: AsyncException) -> return Nothing )
68
69 sequential :: [ Computer a b ] -> Computer a b
70 sequential = foldr orelse ( \ _ -> return Nothing ) 
71
72 orelse :: Computer a b -> Computer a b -> Computer a b
73 orelse p q = \ c -> do
74   mp <- p c
75   case mp of
76     Just result -> return $ Just result
77     Nothing -> q c
78     
79 first = foldr1 orelse
80
81 pass :: Transformer a a a a
82 pass c = return $ Just ( c, id )
83
84 giveup :: Computer a b
85 giveup c = return Nothing
86
87 {-
88 sseq :: [ Transformer a b c d ] -> Transformer a b c d
89 sseq [ p ] = \ c -> andthen p c
90 sseq ( p : ps ) = \ c -> committed_choice p c ( sseq ps c )
91 -}
92
93 ppar :: [ Transformer a b c d ] -> Transformer a b c d
94 ppar ps = \ c -> do
95     out <- newChan
96     pids <- forM ps $ \ p -> forkIO $ do
97         o <- p c `Control.Exception.catch` \ (e :: AsyncException) -> do
98               hPutStrLn stderr "******* caught ***********"
99               return Nothing
100         writeChan out o
101     let handler 0 = return Nothing
102         handler k = do
103             res <- readChan out `Control.Exception.catch` \ ( e::AsyncException) -> do {- forM pids killThread ; -} return Nothing
104             case res of
105                 Nothing -> handler (k-1)
106                 Just x -> do
107                    hPutStrLn stderr "*************** result ***************"
108                    forM pids killThread 
109                    hPutStrLn stderr "*************** killed others ***************"
110                    return $ Just x
111     handler ( length ps )   `Control.Exception.catch`
112                 ( \ (e :: AsyncException) -> return Nothing )
113     
114
115 andthen :: Transformer a b c d -> Computer b c -> Computer a d
116 andthen p q = \ c -> do
117   mp <- p c
118   case mp of
119       Nothing -> return Nothing
120       Just ( d, f ) -> do
121           mq <- q d
122           case mq of
123               Nothing -> return Nothing
124               Just pr ->
125                   return $ Just $ f pr
126