093c755ee50f1fdac7b3ec02ebd023dfe2963b42
1 module ForwardS
3 ( forwardS
4 , forwardSpublic
5 )
7 -- implements thomas genet's algorithm
8 -- for approximating term replacement in a finite automaton
10 -- we're looking at the system S x y z -> x z (y z)
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 @)
17 where
19 import Set
20 import FiniteMap
22 import Stuff
23 import Options
25 import TA
26 import FAtypes
27 import Ids
29 import Reuse
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
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
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 ]
71 -- next free state
72 next = 1 + maximum (setToList all)
74 -- write new top state numbers to quads
75 -- warnig: the number 2 depends on the states used in "new" below
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" ]
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 ]
91 newsl = [ p | iq <- iquads, p <- new iq ]
93 news = listToFM [ (a, unitSet t) | (a, t) <- newsl ]
95 moves' = moves `mergeFM` news
96 all' = all `unionSet` mkSet (keysFM moves')
98 r = TNFA cons all' starts moves'
100 addons = [ a | a <- keysFM news, a >= next ]
101 r' = reuse opts r addons
103 r'' = chose opts "reuse" r' r
105 in
107 trinfo opts "forwardS" r'' \$
109 r''
115 forwardSpublic :: Opts -> [ TNFA Int ] -> TNFA Int
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
126 -- later:
128 -- iterate the forwardS operation
129 -- making the automaton deterministic and minimal
130 -- before and after each step
131 -- until process converges