9ba902237506fd6c152a5e53693eff2203b14d5f
[nofib.git] / real / rx / src / FAuseful.hs
1 module FAuseful
2
3 ( prods, precs
4 , usefulBDFA, usefulTNFA
5 )
6
7 where
8
9
10 import Set
11 import FiniteMap
12
13 import Stuff
14 import Options
15
16 import TA
17 import FAtypes
18
19 import FAconv
20
21 import FAkeepst
22
23 ---------------------------------------------------------------------------
24
25 -- producers: those that ->> leaves
26
27 prods :: Ord a => TCons -> FiniteMap (STerm a) (Set a) -> Set a
28 prods tcons m =
29
30 let ls = unionManySets -- find those that produce leaves
31 [ lookupset m (mksterm tc [])
32 | tc <- setToList tcons, tconarity tc == 0
33 ]
34
35 prhull known unknown | isEmptySet unknown = known
36 prhull known unknown =
37 let ps = unionManySets
38 [ lookupset m (mksterm tc a)
39 | tc <- setToList tcons, n <- [tconarity tc], n > 0
40 , a <- packs n 1 (setToList known) (setToList unknown)
41 ]
42 ks = known `unionSet` unknown
43 qs = ps `minusSet` ks
44 in prhull ks qs
45
46 in prhull emptySet ls
47
48 ------------------------------------------------------------------------
49
50 -- produceds: those that start ->> .
51
52 precs :: Ord a => FiniteMap a (Set (STerm a)) -> Set a -> Set a
53 precs m starts =
54 -- let h x = lookupWithDefaultFM m (error "precs") x
55 let h x = lookupset m x
56 `bind` \ t -> mkSet (stargs t)
57 in sethull h starts
58
59 ------------------------------------------------------------------------
60
61 usefulBDFA :: (Show a, Ord a) => Opts -> BDFA a -> BDFA a
62 usefulBDFA opts e1 =
63 let e2 @ (BNFA cons2 all2 starts2 moves2) = bdfa2bnfa opts e1
64 qs = prods cons2 moves2
65 e3 = keepstBNFA opts e2 qs
66 e4 @ (TNFA cons4 all4 starts4 moves4) = bnfa2tnfa opts e3
67 ps = precs moves4 starts4
68 e5 = keepstTNFA opts e4 ps
69 e6 = tnfa2bnfa opts e5
70 e7 = simplebnfa2bdfa opts e6
71 in
72
73 -- trace ("\nuseful.e1 = " ++ show e1) $
74 -- trace ("\nuseful.e2 = " ++ show e2) $
75 -- trace ("\nuseful.qs = " ++ show qs) $
76 -- trace ("\nuseful.e3 = " ++ show e3) $
77 -- trace ("\nuseful.e4 = " ++ show e4) $
78 -- trace ("\nuseful.ps = " ++ show ps) $
79 -- trace ("\nuseful.e5 = " ++ show e5) $
80 -- trace ("\nuseful.e6 = " ++ show e6) $
81 -- trace ("\nuseful.e7 = " ++ show e7) $
82
83 e7
84
85 ----------------------------------------------------------
86
87 usefulTNFA :: (Show a, Ord a) => Opts -> TNFA a -> TNFA a
88 -- keep only those states that produce leaves
89 -- and that are reachable from the start
90 usefulTNFA opts e1 =
91 let
92 e2 @ (BNFA cons2 all2 starts2 moves2) = tnfa2bnfa opts e1
93 qs = prods cons2 moves2
94 e3 = keepstBNFA opts e2 qs
95 e4 @ (TNFA cons4 all4 starts4 moves4) = bnfa2tnfa opts e3
96 ps = precs moves4 starts4
97 e5 = keepstTNFA opts e4 ps
98 in
99
100 -- trace ("\nuseful.e1 = " ++ show e1) $
101 -- trace ("\nuseful.e2 = " ++ show e2) $
102 -- trace ("\nuseful.qs = " ++ show qs) $
103 -- trace ("\nuseful.e3 = " ++ show e3) $
104 -- trace ("\nuseful.e4 = " ++ show e4) $
105 -- trace ("\nuseful.ps = " ++ show ps) $
106 -- trace ("\nuseful.e5 = " ++ show e5) $
107
108 e5