1 module FA2Exp
    2 
    3 ( etnfa2exp
    4 , tnfa2exp
    5 
    6 , foldnonrec
    7 ) 
    8 
    9 where
   10 
   11 import Set
   12 import FiniteMap
   13 
   14 import Stuff
   15 import Options
   16 
   17 import TA
   18 import FAtypes
   19 import FAconv
   20 import FA
   21 
   22 import Ids
   23 import Syntax
   24 
   25 tnfa2exp :: (Show a, Ord a) => Opts -> TNFA a -> Exp
   26 tnfa2exp opts = etnfa2exp opts . tnfa2etnfa opts
   27 
   28 
   29 
   30 -----------------------------------------------------------------------
   31 
   32 
   33 etnfa2exp :: (Ord a, Show a) => Opts -> ETNFA a -> Exp
   34 etnfa2exp opts (ETNFA cons all starts moves eps) =
   35     let
   36         -- todo: this neither nice nor correct nor in the right place
   37         -- (the user might have overridden the latex format entry)
   38 
   39         plus = head [ id | (id, _) <- fids, idname id == "++" ]
   40 
   41         expset [] = Coll CSet []
   42         expset [x] = x
   43         expset xs = foldl1 (\ x y -> App plus [x, y]) xs
   44 
   45         leadsto = head [ id | (id, _) <- fids, idname id == "->" ]
   46 
   47         eall = mapSet var2id all
   48         estarts = expset (map var2exp (setToList starts))
   49         emoves = [ ( var2exp x
   50                  , expset (  map sterm2exp (setToList ts)
   51                        ++ map var2exp (setToList (lookupset eps x))) )
   52                | (x, ts) <- fmToList moves
   53                ]
   54         
   55         (cstarts, cmoves) =
   56             (chose opts "foldnonrec" (foldnonrec eall) id) $
   57             (chose opts "foldconst" (foldconst eall) id) $
   58                 (estarts, emoves)
   59 
   60 
   61     in  if (null cmoves && onoff opts "hidegrammar")
   62         then cstarts
   63         else
   64                  App (userfun 2 "grammar")       -- todo: wrong place
   65                 [ cstarts
   66                 , Coll CSet [ App leadsto [ x, y ] 
   67                         | (x, y) <- cmoves ]
   68                 ]
   69 
   70 ---------------------------------------------------------------------------
   71 
   72 varset r = mkSet (appids r)
   73 varsets xrs = unionManySets [ varset r | (x, r) <- xrs ]
   74 
   75 substMoves name val moves = 
   76     [ (x, substExp name val r) | (x, r) <- moves ]
   77 
   78 foldconst vars (starts, moves) =
   79     fixpoint (\ (starts, moves) ->
   80         case   [ (x, r) | (x, r) <- moves 
   81                 , isEmptySet  (varset r `intersectSet` vars)
   82                 ] of
   83             [] -> (starts, moves)
   84             (x, r) : _ -> 
   85 
   86 --           trace ("\nfoldconst " ++ show x ++ " => " ++ show r) $
   87 
   88 
   89                 ( substExp x r starts
   90                 , substMoves x r [ (y, s) | (y, s) <- moves, y /= x ] ) )
   91         (starts, moves)
   92 
   93 ------------------------------------------------------------------------
   94             
   95 foldnonrec vars (starts, moves) =
   96     fixpoint (\ (starts, moves) ->
   97         case   [ (x, r) | (x, r) <- moves 
   98                 , not (unAppId x `elementOf` varset r)
   99                 ] of
  100             [] -> (starts, moves)
  101             (x, r) : _ -> 
  102 
  103 --           trace ("\nfoldnonrec " ++ show x ++ " => " ++ show r) $
  104 
  105 
  106                 ( substExp x r starts
  107                 , substMoves x r [ (y, s) | (y, s) <- moves, y /= x ] ) )
  108         (starts, moves)
  109             
  110 
  111