1 -- applies a transformation to exactly one of all states of an automaton
    2 -- instance: reduce exactly one redex that may be situated aritrarily
    3 
    4 module FAsubtrans
    5 
    6 
    7 where
    8 
    9 import Set
   10 import FiniteMap
   11 
   12 import Stuff
   13 import Options
   14 
   15 import TA
   16 import FAtypes
   17 import Ids
   18 
   19 import FAmap
   20 import FAcmpct
   21 
   22 import FAuseful
   23 
   24 --import Trace
   25 
   26 --import List
   27 
   28 subtransTNFA :: Opts -> (Opts -> TNFA Int -> TNFA Int) -> TNFA Int -> TNFA Int
   29 
   30 subtransTNFA opts f a @ (TNFA cons all starts moves) =
   31     let
   32         n = maximum (setToList all)
   33         orig = n + 1   -- next unused state
   34         copy = n + 2   -- even more unused state
   35 
   36         o @ (TNFA ocons oall ostarts omoves) 
   37                 = mapTNFA opts (\ m -> (orig, m)) a
   38         c @ (TNFA ccons call cstarts cmoves) 
   39                 = mapTNFA opts (\ m -> (copy, m)) a
   40 
   41         -- stepping from the copy to the original:
   42         -- make exactly one argument point to the copy,
   43         -- all the others to the original
   44         -- that is, in the copy, there are no leaves here
   45         cmoves' = mapFM (\ w ts -> mkSet 
   46                 [ mksterm tc (as' ++ b : cs')
   47                 | t <- setToList ts
   48                 , tc <- [ stcon t ], args <- [ stargs t ]
   49                 , (as, b : cs) <- zip (inits args) (tails args)
   50                 , as' <- [[ (orig, a) | (_, a) <- as ]]
   51                 , cs' <- [[ (orig, c) | (_, c) <- cs ]]
   52                 ] ) cmoves
   53 
   54         -- the new automata
   55         ns = listToFM 
   56                 [ (w, mapTNFA opts (\ m -> (w, m))
   57                         (f opts (usefulTNFA opts     -- does this help?
   58                                 (TNFA cons all (unitSet w) moves))))
   59                 | w <- setToList all
   60                 ]
   61 
   62         ncons  = unionManySets [ cons  | TNFA cons _ _ _ <- eltsFM ns ]
   63         nall   = unionManySets [ all   | TNFA _ all  _ _ <- eltsFM ns ]
   64 
   65         -- the moves in them
   66         mmoves = foldl (plusFM_C unionSet) emptyFM 
   67                 [ moves | TNFA _ _ _ moves <- eltsFM ns ]
   68 
   69         -- the moves to them
   70         nmoves = listToFM 
   71                 [ ( (copy, w) , nstarts `bind` lookupset nmoves )
   72                 | w <- setToList all
   73                 , TNFA _ _ nstarts nmoves <- 
   74                         [ lookupWithDefaultFM ns (error "subtransTNFA.ns") w ]
   75                 ]
   76 
   77         -- all together now
   78         cons' = cons `unionSet` ncons
   79         all' = oall `unionSet` call `unionSet` nall
   80 
   81         starts' = cstarts
   82         moves' = plusFM_C unionSet 
   83                         (plusFM_C unionSet nmoves mmoves)
   84                         (plusFM_C unionSet omoves cmoves')
   85 
   86         d = TNFA cons' all' starts' moves'
   87         e = cmpctTNFA opts d
   88 
   89     in
   90 
   91 --      trace ("\nFAsubtrans.a = " ++ show a) $
   92 --      trace ("\nFAsubtrans.o = " ++ show o) $
   93 --      trace ("\nFAsubtrans.c = " ++ show c) $
   94 --      trace ("\nFAsubtrans.d = " ++ show d) $
   95 --      trace ("\nFAsubtrans.e = " ++ show e) $
   96 
   97         e
   98