diff --git a/src/GF/API.hs b/src/GF/API.hs index 15cccde51..49d7fd5a2 100644 --- a/src/GF/API.hs +++ b/src/GF/API.hs @@ -157,15 +157,16 @@ randomTreesIO opts gr n = do g = grammar gr mx = optIntOrN opts flagDepth 41 -generateTrees :: Options -> GFGrammar -> Int -> [Tree] -generateTrees opts gr n = +generateTrees :: Options -> GFGrammar -> [Tree] +generateTrees opts gr = optIntOrAll opts flagNumber - [tr | t <- Gen.generateTrees gr' cat n, Ok tr <- [mkTr t]] + [tr | t <- Gen.generateTrees gr' cat dpt mn, Ok tr <- [mkTr t]] where mkTr = annotate gr' . qualifTerm (absId gr) gr' = grammar gr cat = firstAbsCat opts gr - + dpt = maybe 3 id $ getOptInt opts flagDepth + mn = getOptInt opts flagAlts speechGenerate :: Options -> String -> IO () speechGenerate opts str = do diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index abfb44e5a..7e273025f 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -221,7 +221,8 @@ flagYes = oArg "yes" flagNo = oArg "no" -- integer flags -flagDepth = aOpt "depth" +flagDepth = aOpt "depth" +flagAlts = aOpt "alts" flagLength = aOpt "length" flagNumber = aOpt "number" diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index 8a0152e10..66a073ebc 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -53,8 +53,8 @@ data Command = | CLinearize [()] ---- parameters | CParse | CTranslate Language Language - | CGenerateRandom Int - | CGenerateTrees Int + | CGenerateRandom + | CGenerateTrees | CPutTerm | CWrapTerm Ident | CMorphoAnalyse @@ -174,7 +174,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of CTranslate il ol -> do let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa - CGenerateRandom n -> do + CGenerateRandom -> do let a' = case a of ASTrm _ -> s2t a @@ -186,9 +186,9 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of Ok trm' -> returnArg (ATrms [loc2tree trm']) sa Bad s -> returnArg (AError s) sa _ -> do - ts <- randomTreesIO opts gro (optIntOrN opts flagNumber n) + ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1) returnArg (ATrms ts) sa - CGenerateTrees n -> returnArg (ATrms $ generateTrees opts gro n) sa + CGenerateTrees -> returnArg (ATrms $ generateTrees opts gro) sa CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs index b4cd335a7..befdb8ea2 100644 --- a/src/GF/Shell/PShell.hs +++ b/src/GF/Shell/PShell.hs @@ -70,9 +70,9 @@ pCommand ws = case ws of "p" : s -> aString CParse s "t" : i:o: s -> aString (CTranslate (language i) (language o)) s - "gr" : [] -> aUnit (CGenerateRandom 1) - "gr" : t -> aTerm (CGenerateRandom 1) t - "gt" : n : [] -> aUnit (CGenerateTrees (readIntArg n)) + "gr" : [] -> aUnit CGenerateRandom + "gr" : t -> aTerm CGenerateRandom t + "gt" : [] -> aUnit CGenerateTrees "pt" : s -> aTerm CPutTerm s ----- "wt" : f : s -> aTerm (CWrapTerm (string2id f)) s "ma" : s -> aString CMorphoAnalyse s diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs index c39153308..9f8fb66d1 100644 --- a/src/GF/UseGrammar/Generate.hs +++ b/src/GF/UseGrammar/Generate.hs @@ -17,8 +17,8 @@ import List -- the main function takes an abstract syntax and returns a list of trees --- generateTrees :: GFCGrammar -> Cat -> Int -> [Exp] -generateTrees gr cat n = map str2tr $ generate gr' cat' n where +-- generateTrees :: GFCGrammar -> Cat -> Int -> Maybe Int -> [Exp] +generateTrees gr cat n mn = map str2tr $ generate gr' cat' n mn where gr' = gr2sgr gr cat' = prt $ snd cat @@ -39,17 +39,22 @@ str2tr (STr (f,ts)) = mkApp (trId f) (map str2tr ts) where ------------------------------------------ -- do the main thing with a simpler data structure +-- the first Int gives tree depth, the second constrains subtrees +-- chosen for each branch. A small number, such as 2, is a good choice +-- if the depth is large (more than 3) -generate :: SGrammar -> SCat -> Int -> [STree] -generate gr cat i = [t | (c,t) <- gen 0 [], c == cat] where + +generate :: SGrammar -> SCat -> Int -> Maybe Int -> [STree] +generate gr cat i mn = [t | (c,t) <- gen 0 [], c == cat] where gen :: Int -> [(SCat,STree)] -> [(SCat,STree)] gen n cts = if n==i then cts else gen (n+1) (nub [(c,STr (f, xs)) | (f,(cs,c)) <- gr, xs <- args cs cts] ++ cts) args :: [SCat] -> [(SCat,STree)] -> [[STree]] - args cs cts = combinations [[t | (k,t) <- cts, k == c] | c <- cs] + args cs cts = combinations [constr [t | (k,t) <- cts, k == c] | c <- cs] + constr = maybe id take mn type SGrammar = [SRule] type SIdent = String diff --git a/src/HelpFile b/src/HelpFile index de06920aa..513c6add0 100644 --- a/src/HelpFile +++ b/src/HelpFile @@ -162,9 +162,12 @@ gr, generate_random: gr Tree? -number generate this number of trees (not impl. with Tree argument) -depth use this number of search steps at most -gt, generate_trees: gt Int - Generates all trees up to the given depth. +gt, generate_trees: gt + Generates all trees up to a given depth. If the depth is large, + a small -alts is recommended flags: + -depth generate to this depth (default 3) + -alts take this number of alternatives at each branch (default unlimited) -cat generate in this category -lang use the abstract syntax of this grammar -number generate (at most) this number of trees diff --git a/src/HelpFile.hs b/src/HelpFile.hs index 07ae033b8..085f244f5 100644 --- a/src/HelpFile.hs +++ b/src/HelpFile.hs @@ -175,9 +175,12 @@ txtHelpFile = "\n -number generate this number of trees (not impl. with Tree argument)" ++ "\n -depth use this number of search steps at most" ++ "\n" ++ - "\ngt, generate_trees: gt Int" ++ - "\n Generates all trees up to the given depth." ++ + "\ngt, generate_trees: gt" ++ + "\n Generates all trees up to a given depth. If the depth is large," ++ + "\n a small -alts is recommended" ++ "\n flags:" ++ + "\n -depth generate to this depth (default 3)" ++ + "\n -alts take this number of alternatives at each branch (default unlimited)" ++ "\n -cat generate in this category" ++ "\n -lang use the abstract syntax of this grammar" ++ "\n -number generate (at most) this number of trees" ++ diff --git a/src/Today.hs b/src/Today.hs index 2377e1ccb..85bc90114 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Fri Apr 30 18:14:29 CEST 2004" +module Today where today = "Fri Apr 30 21:40:30 CEST 2004"