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