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