093c755ee50f1fdac7b3ec02ebd023dfe2963b42
[nofib.git] / real / rx / src / ForwardS.hs
1 module ForwardS
2
3 ( forwardS
4 , forwardSpublic
5 )
6
7 -- implements thomas genet's algorithm
8 -- for approximating term replacement in a finite automaton
9
10 -- we're looking at the system S x y z -> x z (y z)
11
12 -- this implementation is ugly ugly ugly
13 -- w.r.t. the rest of the system
14 -- the reduction rule of S is hardwired
15 -- as are the names of the constructors (S and @)
16
17 where
18
19 import Set
20 import FiniteMap
21
22 import Stuff
23 import Options
24
25 import TA
26 import FAtypes
27 import Ids
28
29 import Reuse
30
31 sons :: TNFA Int -> Int -> [(Int, Int)]
32 sons (TNFA cons all starts moves) p =
33 let
34 ts = lookupWithDefaultFM moves (error "ForwardS.sons.ts") p
35 lrs = [ (l, r)
36 | t <- setToList ts
37 , tconname (stcon t) == "@"
38 , let [l, r] = stargs t
39 ]
40 in
41 lrs
42
43
44
45 leaves :: TNFA Int -> Int -> [()]
46 leaves (TNFA cons all starts moves) p =
47 let
48 ts = lookupWithDefaultFM moves (error "ForwardS.leaves.ts") p
49 lrs = [ ()
50 | t <- setToList ts
51 , tconname (stcon t) == "S"
52 ]
53 in
54 lrs
55
56
57
58 forwardS :: Opts -> TNFA Int -> TNFA Int
59 -- look for all matches of S x y z
60 -- add new states from that to x z (y z)
61 forwardS opts a @ (TNFA cons all starts moves) =
62 let
63 quads = [ (t0, (x, y, z))
64 | t0 <- setToList all
65 , (t1, z) <- sons a t0
66 , (t2, y) <- sons a t1
67 , (t3, x) <- sons a t2
68 , () <- leaves a t3 -- this looks for S
69 ]
70
71 -- next free state
72 next = 1 + maximum (setToList all)
73
74 -- write new top state numbers to quads
75 -- warnig: the number 2 depends on the states used in "new" below
76 iquads = zip [next, next + 2 .. ] quads
77
78 -- this is a bit ugly
79 -- need to find the complete id information for the constructors
80 -- we hope they are there
81 ap = head [ con | con <- setToList cons, tconname con == "@" ]
82 s = head [ con | con <- setToList cons, tconname con == "S" ]
83
84 -- generate new states per quad
85 new (i, (t, (x, y, z))) =
86 [ (t , mksterm ap [i + 0, i + 1])
87 , (i + 0, mksterm ap [x, z])
88 , (i + 1, mksterm ap [y, z])
89 ]
90
91 newsl = [ p | iq <- iquads, p <- new iq ]
92
93 news = listToFM [ (a, unitSet t) | (a, t) <- newsl ]
94
95 moves' = moves `mergeFM` news
96 all' = all `unionSet` mkSet (keysFM moves')
97
98 r = TNFA cons all' starts moves'
99
100 addons = [ a | a <- keysFM news, a >= next ]
101 r' = reuse opts r addons
102
103 r'' = chose opts "reuse" r' r
104
105 in
106
107 trinfo opts "forwardS" r'' $
108
109 r''
110
111
112
113
114
115 forwardSpublic :: Opts -> [ TNFA Int ] -> TNFA Int
116
117 forwardSpublic opts args =
118 if length args /= 1
119 then error "forwardSpublic.args"
120 else
121 let [arg1] = args
122 in forwardS opts arg1
123
124
125
126 -- later:
127
128 -- iterate the forwardS operation
129 -- making the automaton deterministic and minimal
130 -- before and after each step
131 -- until process converges
132