diff --git a/lib/resource-1.0/minimal/trees.tmp b/lib/resource-1.0/minimal/trees.tmp new file mode 100644 index 000000000..95a99e5bd --- /dev/null +++ b/lib/resource-1.0/minimal/trees.tmp @@ -0,0 +1,110 @@ +PredVP this_NP (AdvVP (ComplV2 break_V2 that_NP) (PositAdvAdj big_A)) +PredVP this_NP (AdvVP (ComplV2 break_V2 this_NP) (PositAdvAdj big_A)) +PredVP this_NP (AdvVP (ComplV3 add_V3 this_NP that_NP) (PositAdvAdj big_A)) +PredVP this_NP (AdvVP (ComplV3 add_V3 this_NP this_NP) (PositAdvAdj big_A)) +PredVP this_NP (AdvVP (PassV2 break_V2) (PositAdvAdj big_A)) +PredVP this_NP (AdvVP (ReflV2 break_V2) (PositAdvAdj big_A)) +PredVP this_NP (AdvVP (UseV sleep_V) (PositAdvAdj big_A)) +PredVP this_NP (ComplV2 (UseVQ wonder_VQ) that_NP) +PredVP this_NP (ComplV2 (UseVQ wonder_VQ) this_NP) +PredVP this_NP (ComplV2A paint_V2A that_NP (ComparA big_A that_NP)) +PredVP this_NP (ComplV2A paint_V2A that_NP (ComparA big_A this_NP)) +PredVP this_NP (ComplV2A paint_V2A that_NP (PositA big_A)) +PredVP this_NP (ComplV2A paint_V2A this_NP (ComparA big_A that_NP)) +PredVP this_NP (ComplV2A paint_V2A this_NP (ComparA big_A this_NP)) +PredVP this_NP (ComplV2A paint_V2A this_NP (PositA big_A)) +PredVP this_NP (ComplVA become_VA (ComparA big_A that_NP)) +PredVP this_NP (ComplVA become_VA (ComparA big_A this_NP)) +PredVP this_NP (ComplVA become_VA (PositA big_A)) +PredVP this_NP (PassV2 (UseVQ wonder_VQ)) +PredVP this_NP (ReflV2 (UseVQ wonder_VQ)) +PredVP this_NP (UseComp (CompNP that_NP)) +PredVP this_NP (UseComp (CompNP this_NP)) +PredVP this_NP (ProgrVP (ComplV2 break_V2 that_NP)) +PredVP this_NP (ProgrVP (ComplV2 break_V2 this_NP)) +PredVP this_NP (ProgrVP (ComplV3 add_V3 this_NP that_NP)) +PredVP this_NP (ProgrVP (ComplV3 add_V3 this_NP this_NP)) +PredVP this_NP (ProgrVP (PassV2 break_V2)) +PredVP this_NP (ProgrVP (ReflV2 break_V2)) +PredVP this_NP (ProgrVP (UseV sleep_V)) +GenericCl (AdvVP (ComplV2 break_V2 that_NP) (PositAdvAdj big_A)) +GenericCl (AdvVP (ComplV2 break_V2 this_NP) (PositAdvAdj big_A)) +GenericCl (AdvVP (ComplV3 add_V3 this_NP that_NP) (PositAdvAdj big_A)) +GenericCl (AdvVP (ComplV3 add_V3 this_NP this_NP) (PositAdvAdj big_A)) +GenericCl (AdvVP (PassV2 break_V2) (PositAdvAdj big_A)) +GenericCl (AdvVP (ReflV2 break_V2) (PositAdvAdj big_A)) +GenericCl (AdvVP (UseV sleep_V) (PositAdvAdj big_A)) +GenericCl (ComplV2 (UseVQ wonder_VQ) that_NP) +GenericCl (ComplV2 (UseVQ wonder_VQ) this_NP) +GenericCl (ComplV2A paint_V2A that_NP (ComparA big_A that_NP)) +GenericCl (ComplV2A paint_V2A that_NP (ComparA big_A this_NP)) +GenericCl (ComplV2A paint_V2A that_NP (PositA big_A)) +GenericCl (ComplV2A paint_V2A this_NP (ComparA big_A that_NP)) +GenericCl (ComplV2A paint_V2A this_NP (ComparA big_A this_NP)) +GenericCl (ComplV2A paint_V2A this_NP (PositA big_A)) +GenericCl (ComplVA become_VA (ComparA big_A that_NP)) +GenericCl (ComplVA become_VA (ComparA big_A this_NP)) +GenericCl (ComplVA become_VA (PositA big_A)) +GenericCl (PassV2 (UseVQ wonder_VQ)) +GenericCl (ReflV2 (UseVQ wonder_VQ)) +GenericCl (UseComp (CompNP that_NP)) +GenericCl (UseComp (CompNP this_NP)) +GenericCl (ProgrVP (ComplV2 break_V2 that_NP)) +GenericCl (ProgrVP (ComplV2 break_V2 this_NP)) +GenericCl (ProgrVP (ComplV3 add_V3 this_NP that_NP)) +GenericCl (ProgrVP (ComplV3 add_V3 this_NP this_NP)) +GenericCl (ProgrVP (PassV2 break_V2)) +GenericCl (ProgrVP (ReflV2 break_V2)) +GenericCl (ProgrVP (UseV sleep_V)) +ImpersCl (AdvVP (ComplV2 break_V2 that_NP) (PositAdvAdj big_A)) +ImpersCl (AdvVP (ComplV2 break_V2 this_NP) (PositAdvAdj big_A)) +ImpersCl (AdvVP (ComplV3 add_V3 this_NP that_NP) (PositAdvAdj big_A)) +ImpersCl (AdvVP (ComplV3 add_V3 this_NP this_NP) (PositAdvAdj big_A)) +ImpersCl (AdvVP (PassV2 break_V2) (PositAdvAdj big_A)) +ImpersCl (AdvVP (ReflV2 break_V2) (PositAdvAdj big_A)) +ImpersCl (AdvVP (UseV sleep_V) (PositAdvAdj big_A)) +ImpersCl (ComplV2 (UseVQ wonder_VQ) that_NP) +ImpersCl (ComplV2 (UseVQ wonder_VQ) this_NP) +ImpersCl (ComplV2A paint_V2A that_NP (ComparA big_A that_NP)) +ImpersCl (ComplV2A paint_V2A that_NP (ComparA big_A this_NP)) +ImpersCl (ComplV2A paint_V2A that_NP (PositA big_A)) +ImpersCl (ComplV2A paint_V2A this_NP (ComparA big_A that_NP)) +ImpersCl (ComplV2A paint_V2A this_NP (ComparA big_A this_NP)) +ImpersCl (ComplV2A paint_V2A this_NP (PositA big_A)) +ImpersCl (ComplVA become_VA (ComparA big_A that_NP)) +ImpersCl (ComplVA become_VA (ComparA big_A this_NP)) +ImpersCl (ComplVA become_VA (PositA big_A)) +ImpersCl (PassV2 (UseVQ wonder_VQ)) +ImpersCl (ReflV2 (UseVQ wonder_VQ)) +ImpersCl (UseComp (CompNP that_NP)) +ImpersCl (UseComp (CompNP this_NP)) +ImpersCl (ProgrVP (ComplV2 break_V2 that_NP)) +ImpersCl (ProgrVP (ComplV2 break_V2 this_NP)) +ImpersCl (ProgrVP (ComplV3 add_V3 this_NP that_NP)) +ImpersCl (ProgrVP (ComplV3 add_V3 this_NP this_NP)) +ImpersCl (ProgrVP (PassV2 break_V2)) +ImpersCl (ProgrVP (ReflV2 break_V2)) +ImpersCl (ProgrVP (UseV sleep_V)) +PredVP this_NP (ComplV2 break_V2 that_NP) +PredVP this_NP (ComplV2 break_V2 this_NP) +PredVP this_NP (ComplV3 add_V3 this_NP that_NP) +PredVP this_NP (ComplV3 add_V3 this_NP this_NP) +PredVP this_NP (PassV2 break_V2) +PredVP this_NP (ReflV2 break_V2) +PredVP this_NP (UseV sleep_V) +GenericCl (ComplV2 break_V2 that_NP) +GenericCl (ComplV2 break_V2 this_NP) +GenericCl (ComplV3 add_V3 this_NP that_NP) +GenericCl (ComplV3 add_V3 this_NP this_NP) +GenericCl (PassV2 break_V2) +GenericCl (ReflV2 break_V2) +GenericCl (UseV sleep_V) +ImpersCl (ComplV2 break_V2 that_NP) +ImpersCl (ComplV2 break_V2 this_NP) +ImpersCl (ComplV3 add_V3 this_NP that_NP) +ImpersCl (ComplV3 add_V3 this_NP this_NP) +ImpersCl (PassV2 break_V2) +ImpersCl (ReflV2 break_V2) +ImpersCl (UseV sleep_V) +ExistNP that_NP +ExistNP this_NP diff --git a/src/GF/Compile/Flatten.hs b/src/GF/Compile/Flatten.hs new file mode 100644 index 000000000..d985213bc --- /dev/null +++ b/src/GF/Compile/Flatten.hs @@ -0,0 +1,92 @@ +module Flatten where + +import Data.List +-- import GF.Data.Operations + +-- (AR 15/3/2006) +-- +-- A method for flattening grammars: create many flat rules instead of +-- a few deep ones. This is generally better for parsins. +-- The rules are obtained as follows: +-- 1. write a config file tellinq which constants are variables: format 'c : C' +-- 2. generate a list of trees with their types: format 't : T' +-- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin +-- rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as +-- found in the config file. +-- 4. You can go on and produce def or transfer rules similar to the lin rules +-- except for the keyword. +-- +-- So far this module is used outside gf. You can e.g. generate a list of +-- trees by 'gt', write it in a file, and then in ghci call +-- flattenGrammar + +type Ident = String --- +type Term = String --- +type Rule = String --- + +type Config = [(Ident,Ident)] + +flattenGrammar :: FilePath -> FilePath -> FilePath -> IO () +flattenGrammar conff tf out = do + conf <- readFile conff >>= return . lines + ts <- readFile tf >>= return . lines + writeFile out $ mkFlatten conf ts + +mkFlatten :: [String] -> [String] -> String +mkFlatten conff = unlines . concatMap getOne . zip [1..] where + getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y] + conf = getConfig conff + +mkRules :: Config -> Ident -> Term -> (Rule,Rule) +mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where + args = mkArgs conf ts + ty = concat [a ++ " -> " | a <- map snd args] ++ val + (ts,val) = let tt = lexTerm t in (init tt,last tt) +--- f = mkIdent t + fun c a = unwords [" fun", c, ":",a,";"] + lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"] + +mkArgs :: Config -> [Ident] -> [(Ident,Ident)] +mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]] + +mkIdent :: Term -> Ident +mkIdent = map mkChar where + mkChar c = case c of + '(' -> '6' + ')' -> '9' + ' ' -> '_' + _ -> c + +-- to get just the identifiers +lexTerm :: String -> [String] +lexTerm ss = case lex ss of + [([c],ws)] | isSpec c -> lexTerm ws + [(w@(_:_),ws)] -> w : lexTerm ws + _ -> [] + where + isSpec = flip elem "();:" + + +getConfig :: [String] -> Config +getConfig = map getOne . filter (not . null) where + getOne line = case lexTerm line of + v:c:_ -> (v,c) + +ex = putStrLn fs where + fs = + mkFlatten + ["man_N : N", + "sleep_V : V" + ] + ["PredVP (DefSg man_N) (UseV sleep_V) : Cl", + "PredVP (DefPl man_N) (UseV sleep_V) : Cl" + ] + +{- +-- result of ex + + fun fu1 : N -> V -> Cl ; + lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V) ; + fun fu2 : N -> V -> Cl ; + lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V) ; +-} \ No newline at end of file