From 3dd8fb8decc6f88a3f85645c87f59cad0975e88a Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 1 Feb 2010 09:56:58 +0000 Subject: [PATCH] commands mq and tq can take a tree with metas to guide generation --- src/compiler/GF/Command/Commands.hs | 50 ++++++++++++++++++----------- src/compiler/GF/Quiz.hs | 16 +++++---- src/runtime/haskell/PGF.hs | 1 + src/runtime/haskell/PGF/Generate.hs | 4 +++ 4 files changed, 47 insertions(+), 24 deletions(-) diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 0ca911031..39561654f 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -287,9 +287,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [ let pgfr = optRestricted opts gen <- newStdGen mprobs <- optProbs opts pgfr - let mt = case xs of - t:_ -> Just t - _ -> Nothing + let mt = mexp xs ts <- return $ generateRandomFrom mt mprobs gen pgfr (optType opts) returnFromExprs $ take (optNum opts) ts }), @@ -317,9 +315,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [ exec = \opts xs -> do let pgfr = optRestricted opts let dp = return $ valIntOpts "depth" 4 opts - let mt = case xs of - t:_ -> Just t - _ -> Nothing + let mt = mexp xs let ts = generateAllDepth mt pgfr (optType opts) dp returnFromExprs $ take (optNumInf opts) ts }), @@ -430,15 +426,19 @@ allCommands cod env@(pgf, mos) = Map.fromList [ ("mq", emptyCommandInfo { longname = "morpho_quiz", synopsis = "start a morphology quiz", - exec = \opts _ -> do + syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?", + exec = \opts xs -> do let lang = optLang opts let typ = optType opts - morphologyQuiz cod pgf lang typ + mprobs <- optProbs opts pgf + let mt = mexp xs + morphologyQuiz mt mprobs cod pgf lang typ return void, flags = [ ("lang","language of the quiz"), ("cat","category of the quiz"), - ("number","maximum number of questions") + ("number","maximum number of questions"), + ("probs","file with biased probabilities for generation") ] }), @@ -622,18 +622,26 @@ allCommands cod env@(pgf, mos) = Map.fromList [ }), ("tq", emptyCommandInfo { longname = "translation_quiz", + syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?", synopsis = "start a translation quiz", - exec = \opts _ -> do + exec = \opts xs -> do let from = valCIdOpts "from" (optLang opts) opts let to = valCIdOpts "to" (optLang opts) opts let typ = optType opts - translationQuiz cod pgf from to typ + let mt = mexp xs + mprobs <- optProbs opts pgf + translationQuiz mt mprobs cod pgf from to typ return void, flags = [ ("from","translate from this language"), ("to","translate to this language"), ("cat","translate in this category"), - ("number","the maximum number of questions") + ("number","the maximum number of questions"), + ("probs","file with biased probabilities for generation") + ], + examples = [ + ("tq -from=Eng -to=Swe -- any trees in startcat"), + ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form") ] }), ("se", emptyCommandInfo { @@ -970,6 +978,10 @@ allCommands cod env@(pgf, mos) = Map.fromList [ optMorpho opts = morpho (error "no morpho") id (head (optLangs opts)) + mexp xs = case xs of + t:_ -> Just t + _ -> Nothing + -- ps -f -g s returns g (f s) stringOps menv opts s = foldr (menvop . app) s (reverse opts) where app f = maybe id id (stringOp f) @@ -1014,14 +1026,16 @@ stringOpOptions = sort $ [ treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] -translationQuiz :: Encoding -> PGF -> Language -> Language -> Type -> IO () -translationQuiz cod pgf ig og typ = do - tts <- translationList pgf ig og typ infinity +translationQuiz :: Maybe Expr -> Maybe Probabilities -> Encoding -> + PGF -> Language -> Language -> Type -> IO () +translationQuiz mex mprobs cod pgf ig og typ = do + tts <- translationList mex mprobs pgf ig og typ infinity mkQuiz cod "Welcome to GF Translation Quiz." tts -morphologyQuiz :: Encoding -> PGF -> Language -> Type -> IO () -morphologyQuiz cod pgf ig typ = do - tts <- morphologyList pgf ig typ infinity +morphologyQuiz :: Maybe Expr -> Maybe Probabilities -> Encoding -> + PGF -> Language -> Type -> IO () +morphologyQuiz mex mprobs cod pgf ig typ = do + tts <- morphologyList mex mprobs pgf ig typ infinity mkQuiz cod "Welcome to GF Morphology Quiz." tts -- | the maximal number of precompiled quiz problems diff --git a/src/compiler/GF/Quiz.hs b/src/compiler/GF/Quiz.hs index 6a1e5aae5..9a3540645 100644 --- a/src/compiler/GF/Quiz.hs +++ b/src/compiler/GF/Quiz.hs @@ -24,9 +24,9 @@ import GF.Data.Operations import GF.Infra.UseIO import GF.Infra.Option import GF.Text.Coding +import PGF.Probabilistic import System.Random - import Data.List (nub) -- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002 @@ -39,18 +39,22 @@ mkQuiz cod msg tts = do teachDialogue qas msg translationList :: + Maybe Expr -> Maybe Probabilities -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] -translationList pgf ig og typ number = do - ts <- generateRandom pgf typ >>= return . take number +translationList mex mprobs pgf ig og typ number = do + gen <- newStdGen + let ts = take number $ generateRandomFrom mex mprobs gen pgf typ return $ map mkOne $ ts where mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t)) homonyms = nub . parse pgf ig typ . linearize pgf ig -morphologyList :: PGF -> Language -> Type -> Int -> IO [(String,[String])] -morphologyList pgf ig typ number = do - ts <- generateRandom pgf typ >>= return . take (max 1 number) +morphologyList :: + Maybe Expr -> Maybe Probabilities -> + PGF -> Language -> Type -> Int -> IO [(String,[String])] +morphologyList mex mprobs pgf ig typ number = do gen <- newStdGen + let ts = take (max 1 number) $ generateRandomFrom mex mprobs gen pgf typ let ss = map (tabularLinearizes pgf ig) ts let size = length (head (head ss)) let forms = take number $ randomRs (0,size-1) gen diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 6b6e3b1a3..895162e2e 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -79,6 +79,7 @@ module PGF( -- ** Generation generateRandom, generateAll, generateAllDepth, + generateRandomFrom, -- from initial expression, possibly weighed -- ** Morphological Analysis Lemma, Analysis, Morpho, diff --git a/src/runtime/haskell/PGF/Generate.hs b/src/runtime/haskell/PGF/Generate.hs index bda64b514..dee4f48fa 100644 --- a/src/runtime/haskell/PGF/Generate.hs +++ b/src/runtime/haskell/PGF/Generate.hs @@ -21,6 +21,10 @@ generateRandomFrom mex ps rg pgf ty = maybe (gen ty) (generateForMetas pgf gen) mex where gen ty = genRandomProb ps rg pgf ty + +-- generic algorithm for filling holes in a generator +---- for random, should be breadth-first, since now the first metas always get the same +---- value when a list is generated generateForMetas :: PGF -> (Type -> [Expr]) -> Expr -> [Expr] generateForMetas pgf gen exp = case exp of EApp f (EMeta _) -> [EApp g a | g <- gener f, a <- genArg g]