diff options
| author | krasimir <krasimir@chalmers.se> | 2009-12-13 18:50:29 +0000 |
|---|---|---|
| committer | krasimir <krasimir@chalmers.se> | 2009-12-13 18:50:29 +0000 |
| commit | f85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch) | |
| tree | 667b886a5e3a4b026a63d4e3597f32497d824761 /src/PGF/Paraphrase.hs | |
| parent | d88a865faff59c98fc91556ff8700b10ee5f2df8 (diff) | |
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/PGF/Paraphrase.hs')
| -rw-r--r-- | src/PGF/Paraphrase.hs | 112 |
1 files changed, 0 insertions, 112 deletions
diff --git a/src/PGF/Paraphrase.hs b/src/PGF/Paraphrase.hs deleted file mode 100644 index 58d15b2e8..000000000 --- a/src/PGF/Paraphrase.hs +++ /dev/null @@ -1,112 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Paraphrase --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- Generate parapharases with def definitions. ------------------------------------------------------------------------------ - -module PGF.Paraphrase ( - paraphrase, - paraphraseN - ) where - -import PGF.Data -import PGF.Tree -import PGF.Macros (lookDef,isData) -import PGF.CId - -import Data.List (nub,sort,group) -import qualified Data.Map as Map - -import Debug.Trace ---- - -paraphrase :: PGF -> Expr -> [Expr] -paraphrase pgf = nub . paraphraseN 2 pgf - -paraphraseN :: Int -> PGF -> Expr -> [Expr] -paraphraseN i pgf = map tree2expr . paraphraseN' i pgf . expr2tree - -paraphraseN' :: Int -> PGF -> Tree -> [Tree] -paraphraseN' 0 _ t = [t] -paraphraseN' i pgf t = - step i t ++ [Fun g ts' | Fun g ts <- step (i-1) t, ts' <- sequence (map par ts)] - where - par = paraphraseN' (i-1) pgf - step 0 t = [t] - step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept] - def = fromDef pgf - -fromDef :: PGF -> Tree -> [Tree] -fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where - defDown t = [subst g u | let equ = equsFrom f, (u,g) <- match equ ts, trequ "U" f equ] - defUp t = [subst g u | equ <- equsTo f, (u,g) <- match [equ] ts, trequ "D" f equ] - - equsFrom f = [(ps,d) | Just equs <- [lookup f equss], (Fun _ ps,d) <- equs] - - equsTo f = [c | (_,equs) <- equss, c <- casesTo f equs] - - casesTo f equs = - [(ps,p) | (p,d@(Fun g ps)) <- equs, g==f, - isClosed d || (length equs == 1 && isLinear d)] - - equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | - (f,(_,_,eqs)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] - - trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True - -subst :: Subst -> Tree -> Tree -subst g e = case e of - Fun f ts -> Fun f (map substg ts) - Var x -> maybe e id $ lookup x g - _ -> e - where - substg = subst g - -type Subst = [(CId,Tree)] - --- this applies to pattern, hence don't need to consider abstractions -isClosed :: Tree -> Bool -isClosed t = case t of - Fun _ ts -> all isClosed ts - Var _ -> False - _ -> True - --- this applies to pattern, hence don't need to consider abstractions -isLinear :: Tree -> Bool -isLinear = nodup . vars where - vars t = case t of - Fun _ ts -> concatMap vars ts - Var x -> [x] - _ -> [] - nodup = all ((<2) . length) . group . sort - - -match :: [([Tree],Tree)] -> [Tree] -> [(Tree, Subst)] -match cases terms = case cases of - [] -> [] - (patts,_):_ | length patts /= length terms -> [] - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Just substs -> return (val, concat substs) - _ -> match cc terms - where - tryMatch (p,t) = case (p, t) of - (Var x, _) | notMeta t -> return [(x,t)] - (Fun p pp, Fun f tt) | p == f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - _ -> if p==t then return [] else Nothing - - notMeta e = case e of - Meta _ -> False - Fun f ts -> all notMeta ts - _ -> True - --- | Converts a pattern to tree. -patt2tree :: Patt -> Tree -patt2tree (PApp f ps) = Fun f (map patt2tree ps) -patt2tree (PLit l) = Lit l -patt2tree (PVar x) = Var x -patt2tree PWild = Meta 0 |
