diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 63e3208b5..10322715b 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -278,8 +278,8 @@ allCommands env@(pgf, mos) = Map.fromList [ ], exec = \opts _ -> do let file = optFile opts - mprobs <- optProbs opts pgf - let conf = configureExBased pgf (optMorpho opts) mprobs (optLang opts) + pgf <- optProbs opts pgf + let conf = configureExBased pgf (optMorpho opts) (optLang opts) (file',ws) <- parseExamplesInGrammar conf file if null ws then return () else putStrLn ("unknown words: " ++ unwords ws) return (fromString ("wrote " ++ file')), @@ -309,15 +309,11 @@ allCommands env@(pgf, mos) = Map.fromList [ ("probs", "file with biased probabilities (format 'f 0.4' one by line)") ], exec = \opts xs -> do - let pgfr = optRestricted opts + pgf <- optProbs opts (optRestricted opts) gen <- newStdGen - mprobs <- optProbs opts pgfr - let sel = case mprobs of - Just probs -> WeightSel gen probs - Nothing -> RandSel gen let ts = case mexp xs of - Just ex -> generateRandomFrom sel pgfr ex - Nothing -> generateRandom sel pgfr (optType opts) + Just ex -> generateRandomFrom gen pgf ex + Nothing -> generateRandom gen pgf (optType opts) returnFromExprs $ take (optNum opts) ts }), ("gt", emptyCommandInfo { @@ -389,8 +385,11 @@ allCommands env@(pgf, mos) = Map.fromList [ " .gfo compiled GF source", " .pgf precompiled grammar in Portable Grammar Format" ], + flags = [ + ("probs","file with biased probabilities for generation") + ], options = [ - -- ["prob", "retain", "gfo", "src", "no-cpu", "cpu", "quiet", "verbose"] + -- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"] ("retain","retain operations (used for cc command)"), ("src", "force compilation from source"), ("v", "be verbose - show intermediate status information") @@ -461,9 +460,9 @@ allCommands env@(pgf, mos) = Map.fromList [ exec = \opts xs -> do let lang = optLang opts let typ = optType opts - mprobs <- optProbs opts pgf + pgf <- optProbs opts pgf let mt = mexp xs - morphologyQuiz mt mprobs pgf lang typ + morphologyQuiz mt pgf lang typ return void, flags = [ ("lang","language of the quiz"), @@ -639,9 +638,8 @@ allCommands env@(pgf, mos) = Map.fromList [ "'function probability', e.g. 'youPol_Pron 0.01'." ], exec = \opts ts -> do - mprobs <- optProbs opts pgf - let probs = maybe (defaultProbabilities pgf) id mprobs - let tds = rankTreesByProbs probs ts + pgf <- optProbs opts pgf + let tds = rankTreesByProbs pgf ts if isOpt "v" opts then putStrLn $ unlines [showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds] @@ -667,8 +665,8 @@ allCommands env@(pgf, mos) = Map.fromList [ let to = valCIdOpts "to" (optLang opts) opts let typ = optType opts let mt = mexp xs - mprobs <- optProbs opts pgf - translationQuiz mt mprobs pgf from to typ + pgf <- optProbs opts pgf + translationQuiz mt pgf from to typ return void, flags = [ ("from","translate from this language"), @@ -887,7 +885,7 @@ allCommands env@(pgf, mos) = Map.fromList [ if null (functionsToCat pgf id) then empty else space $$ - vcat [ppFun fid (ty,0,Just []) | (fid,ty) <- functionsToCat pgf id]) + vcat [ppFun fid (ty,0,Just [],0) | (fid,ty) <- functionsToCat pgf id]) Nothing -> do putStrLn ("unknown category of function identifier "++show id) return void [e] -> case inferExpr pgf e of @@ -979,12 +977,11 @@ allCommands env@(pgf, mos) = Map.fromList [ "" -> [] cats -> mapMaybe readType (chunks ',' cats) - optProbs opts pgfr = case valStrOpts "probs" "" opts of - "" -> return Nothing + optProbs opts pgf = case valStrOpts "probs" "" opts of + "" -> return pgf file -> do - ps <- readProbabilitiesFromFile file pgf ---- pgfr! --- putStrLn $ showProbabilities ps - return $ Just ps + probs <- readProbabilitiesFromFile file pgf + return (setProbabilities probs pgf) optFile opts = valStrOpts "file" "_gftmp" opts @@ -1038,7 +1035,7 @@ allCommands env@(pgf, mos) = Map.fromList [ | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf - funsigs pgf = [(f,ty) | (f,(ty,_,_)) <- Map.assocs (funs (abstract pgf))] + funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))] showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;" morphos opts s = @@ -1096,16 +1093,14 @@ stringOpOptions = sort $ [ treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] -translationQuiz :: Maybe Expr -> Maybe Probabilities -> - PGF -> Language -> Language -> Type -> IO () -translationQuiz mex mprobs pgf ig og typ = do - tts <- translationList mex mprobs pgf ig og typ infinity +translationQuiz :: Maybe Expr -> PGF -> Language -> Language -> Type -> IO () +translationQuiz mex pgf ig og typ = do + tts <- translationList mex pgf ig og typ infinity mkQuiz "Welcome to GF Translation Quiz." tts -morphologyQuiz :: Maybe Expr -> Maybe Probabilities -> - PGF -> Language -> Type -> IO () -morphologyQuiz mex mprobs pgf ig typ = do - tts <- morphologyList mex mprobs pgf ig typ infinity +morphologyQuiz :: Maybe Expr -> PGF -> Language -> Type -> IO () +morphologyQuiz mex pgf ig typ = do + tts <- morphologyList mex pgf ig typ infinity mkQuiz "Welcome to GF Morphology Quiz." tts -- | the maximal number of precompiled quiz problems diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index ecb533c3f..7c1290d7e 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -42,6 +42,7 @@ import PGF.CId import PGF.Data import PGF.Macros import PGF.Optimize +import PGF.Probabilistic -- | Compiles a number of source files and builds a 'PGF' structure for them. @@ -55,9 +56,13 @@ link :: Options -> Ident -> SourceGrammar -> IOE PGF link opts cnc gr = do let isv = (verbAtLeast opts Normal) putPointE Normal opts "linking ... " $ do - gc <- ioeIO (mkCanon2pgf opts cnc gr) - ioeIO $ putStrLn "OK" - return $ if flag optOptimizePGF opts then optimizePGF gc else gc + pgf <- ioeIO (mkCanon2pgf opts cnc gr) + probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf) + ioeIO $ putStrLn "OK" + pgf <- return $ setProbabilities probs + $ if flag optOptimizePGF opts then optimizePGF pgf else pgf + ioeIO $ putStrLn (showProbabilities (getProbabilities pgf)) + return pgf batchCompile :: Options -> [FilePath] -> IOE SourceGrammar batchCompile opts files = do diff --git a/src/compiler/GF/Compile/ExampleBased.hs b/src/compiler/GF/Compile/ExampleBased.hs index 20fa4d62f..46fb8b5d7 100644 --- a/src/compiler/GF/Compile/ExampleBased.hs +++ b/src/compiler/GF/Compile/ExampleBased.hs @@ -59,9 +59,7 @@ convertFile conf src file = do appn t >> mapM_ (appn . (" --- " ++)) tt >> return [] appn ")" return ws - rank ts = case probs conf of - Just probs -> [showExpr [] t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs probs ts] - _ -> map (showExpr []) ts + rank ts = [showExpr [] t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts] appf = appendFile file appn s = appf s >> appf "\n" appv s = appn ("--- " ++ s) >> putStrLn s @@ -69,11 +67,10 @@ convertFile conf src file = do data ExConfiguration = ExConf { resource_pgf :: PGF, resource_morpho :: Morpho, - probs :: Maybe Probabilities, verbose :: Bool, language :: Language } -configureExBased :: PGF -> Morpho -> Maybe Probabilities -> Language -> ExConfiguration -configureExBased pgf morpho mprobs lang = ExConf pgf morpho mprobs False lang +configureExBased :: PGF -> Morpho -> Language -> ExConfiguration +configureExBased pgf morpho lang = ExConf pgf morpho False lang diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 9b0f9293d..05ec88e72 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -57,14 +57,14 @@ canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do where flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)] - funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty)) | + funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) | (f,AbsFun (Just (L _ ty)) ma pty) <- Map.toAscList (M.jments abm)] cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) | (c,AbsCat (Just (L _ cont))) <- Map.toAscList (M.jments abm)] catfuns cat = - (map snd . sortBy (compare `on` fst)) + (map (\x -> (0,snd x)) . sortBy (compare `on` fst)) [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat] mkConcr am cm@(lang,mo) = do diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index ecc70cb5e..765a0e959 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -200,7 +200,7 @@ hSkeleton gr = fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) valtyps (_, (_,x)) (_, (_,y)) = compare x y valtypg (_, (_,x)) (_, (_,y)) = x == y - jty (f,(ty,_,_)) = (f,catSkeleton ty) + jty (f,(ty,_,_,_)) = (f,catSkeleton ty) updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton updateSkeleton cat skel rule = diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index b81e0c5d3..1e9b00169 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -33,8 +33,8 @@ pgf2js pgf = abstract2js :: String -> Abstr -> JS.Expr abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] -absdef2js :: (CId,(Type,Int,Maybe [Equation])) -> JS.Property -absdef2js (f,(typ,_,_)) = +absdef2js :: (CId,(Type,Int,Maybe [Equation],Double)) -> JS.Property +absdef2js (f,(typ,_,_,_)) = let (args,cat) = M.catSkeleton typ in JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs index e23f4e7f4..a9dc551f2 100644 --- a/src/compiler/GF/Compile/PGFtoLProlog.hs +++ b/src/compiler/GF/Compile/PGFtoLProlog.hs @@ -13,13 +13,13 @@ grammar2lambdaprolog_mod pgf = render $ text "module" <+> ppCId (absname pgf) <> char '.' $$ space $$ vcat [ppClauses cat fns | (cat,(_,fs)) <- Map.toList (cats (abstract pgf)), - let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | f <- fs]] + let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]] where ppClauses cat fns = text "/*" <+> ppCId cat <+> text "*/" $$ - vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing)) <- fns] $$ + vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$ space $$ - vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs)) <- fns] $$ + vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_)) <- fns] $$ space grammar2lambdaprolog_sig pgf = render $ @@ -27,10 +27,10 @@ grammar2lambdaprolog_sig pgf = render $ space $$ vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$ space $$ - vcat [ppFun f ty <> dot | (f,(ty,_,Nothing)) <- Map.toList (funs (abstract pgf))] $$ + vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$ space $$ vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$ - vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _)) <- Map.toList (funs (abstract pgf))] + vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))] ppCat :: CId -> [Hypo] -> Doc ppCat c hyps = text "kind" <+> ppKind c <+> text "type" @@ -157,8 +157,8 @@ expr2goal abstr scope goals i (EApp e1 e2) args = in expr2goal abstr scope goals' i' e1 (e2':args) expr2goal abstr scope goals i (EFun f) args = case Map.lookup f (funs abstr) of - Just (_,_,Just _) -> let e = EFun (mkVar i) - in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) - _ -> (goals,i,foldl EApp (EFun f) args) + Just (_,_,Just _,_) -> let e = EFun (mkVar i) + in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) + _ -> (goals,i,foldl EApp (EFun f) args) expr2goal abstr scope goals i (EVar j) args = (goals,i,foldl EApp (EVar j) args) diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs index d5839916b..9f456ca93 100644 --- a/src/compiler/GF/Compile/PGFtoProlog.hs +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -62,22 +62,22 @@ plAbstract (name, Abstr aflags funs cats) = clauseHeader "%% def(?Fun, ?Expr)" (concatMap plFundef (Map.assocs funs)) -plCat :: (CId, ([Hypo],[CId])) -> String +plCat :: (CId, ([Hypo],[(Double,CId)])) -> String plCat (cat, (hypos,_)) = plFact "cat" (plTypeWithHypos typ) where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos args = reverse [EFun x | (_,x) <- subst] typ = DTyp hypos' cat args -plFun :: (CId, (Type, Int, Maybe [Equation])) -> String -plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') +plFun :: (CId, (Type, Int, Maybe [Equation], Double)) -> String +plFun (fun, (typ,_,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') where typ' = snd $ alphaConvert emptyEnv typ plTypeWithHypos :: Type -> [String] plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)] -plFundef :: (CId, (Type,Int,Maybe [Equation])) -> [String] -plFundef (fun, (_,_,Nothing )) = [] -plFundef (fun, (_,_,Just eqs)) = [plFact "def" [plp fun, plp fundef']] +plFundef :: (CId, (Type,Int,Maybe [Equation],Double)) -> [String] +plFundef (fun, (_,_,Nothing ,_)) = [] +plFundef (fun, (_,_,Just eqs,_)) = [plFact "def" [plp fun, plp fundef']] where fundef' = snd $ alphaConvert emptyEnv eqs diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index a45d46a39..aac652768 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -155,7 +155,7 @@ data Flags = Flags { optGFLibPath :: Maybe FilePath, optRecomp :: Recomp, optPrinter :: [Printer], - optProb :: Bool, + optProbsFile :: Maybe FilePath, optRetainResource :: Bool, optName :: Maybe String, optAbsName :: Maybe String, @@ -255,7 +255,7 @@ defaultFlags = Flags { optGFLibPath = Nothing, optRecomp = RecompIfNewer, optPrinter = [], - optProb = False, + optProbsFile = Nothing, optRetainResource = False, optName = Nothing, @@ -329,7 +329,7 @@ optDescr = Option [] ["strip"] (NoArg (printer PrinterStrip)) "Remove name qualifiers when pretty-printing.", Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", - Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", + Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.", Option ['n'] ["name"] (ReqArg name "NAME") (unlines ["Use NAME as the name of the output. This is used in the output file names, ", "with suffixes depending on the formats, and, when relevant, ", @@ -399,7 +399,7 @@ optDescr = gfLibPath x = set $ \o -> o { optGFLibPath = Just x } recomp x = set $ \o -> o { optRecomp = x } printer x = set $ \o -> o { optPrinter = x : optPrinter o } - prob x = set $ \o -> o { optProb = x } + probsFile x = set $ \o -> o { optProbsFile = Just x } name x = set $ \o -> o { optName = Just x } absName x = set $ \o -> o { optAbsName = Just x } diff --git a/src/compiler/GF/Quiz.hs b/src/compiler/GF/Quiz.hs index 1a221c21d..0b37660c8 100644 --- a/src/compiler/GF/Quiz.hs +++ b/src/compiler/GF/Quiz.hs @@ -38,32 +38,24 @@ mkQuiz msg tts = do teachDialogue qas msg translationList :: - Maybe Expr -> Maybe Probabilities -> - PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] -translationList mex mprobs pgf ig og typ number = do + Maybe Expr -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] +translationList mex pgf ig og typ number = do gen <- newStdGen - let sel = case mprobs of - Just probs -> WeightSel gen probs - Nothing -> RandSel gen - let ts = take number $ case mex of - Just ex -> generateRandomFrom sel pgf ex - Nothing -> generateRandom sel pgf typ + let ts = take number $ case mex of + Just ex -> generateRandomFrom gen pgf ex + Nothing -> generateRandom gen pgf typ return $ map mkOne $ ts where mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t)) homonyms = parse pgf ig typ . linearize pgf ig morphologyList :: - Maybe Expr -> Maybe Probabilities -> - PGF -> Language -> Type -> Int -> IO [(String,[String])] -morphologyList mex mprobs pgf ig typ number = do + Maybe Expr -> PGF -> Language -> Type -> Int -> IO [(String,[String])] +morphologyList mex pgf ig typ number = do gen <- newStdGen - let sel = case mprobs of - Just probs -> WeightSel gen probs - Nothing -> RandSel gen - let ts = take (max 1 number) $ case mex of - Just ex -> generateRandomFrom sel pgf ex - Nothing -> generateRandom sel pgf typ + let ts = take (max 1 number) $ case mex of + Just ex -> generateRandomFrom gen pgf ex + Nothing -> generateRandom 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/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs index f3f05d3d7..40976dc02 100644 --- a/src/compiler/GF/Speech/VoiceXML.hs +++ b/src/compiler/GF/Speech/VoiceXML.hs @@ -39,7 +39,7 @@ grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) "" type Skeleton = [(CId, [(CId, [CId])])] pgfSkeleton :: PGF -> Skeleton -pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs]) +pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | (_,f) <- fs]) | (c,(_,fs)) <- Map.toList (cats (abstract pgf))] -- diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index e71992ecc..c750e66fe 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -105,8 +105,6 @@ module PGF( generateFrom, generateFromDepth, generateRandom, generateRandomDepth, generateRandomFrom, generateRandomFromDepth, - - RandomSelector(..), -- ** Morphological Analysis Lemma, Analysis, Morpho, @@ -269,8 +267,8 @@ functions pgf = Map.keys (funs (abstract pgf)) functionType pgf fun = case Map.lookup fun (funs (abstract pgf)) of - Just (ty,_,_) -> Just ty - Nothing -> Nothing + Just (ty,_,_,_) -> Just ty + Nothing -> Nothing -- | Converts an expression to normal form compute :: PGF -> Expr -> Expr @@ -280,20 +278,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId]) browse pgf id = fmap (\def -> (def,producers,consumers)) definition where definition = case Map.lookup id (funs (abstract pgf)) of - Just (ty,_,Just eqs) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ - if null eqs - then empty - else text "def" <+> vcat [let scope = foldl pattScope [] patts - ds = map (ppPatt 9 scope) patts - in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) - Just (ty,_,Nothing ) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty) + Just (ty,_,Just eqs,_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ + if null eqs + then empty + else text "def" <+> vcat [let scope = foldl pattScope [] patts + ds = map (ppPatt 9 scope) patts + in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) + Just (ty,_,Nothing, _) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty) Nothing -> case Map.lookup id (cats (abstract pgf)) of Just (hyps,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) Nothing -> Nothing (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf)) where - accum f (ty,_,_) (plist,clist) = + accum f (ty,_,_,_) (plist,clist) = let !plist' = if id `elem` ps then f : plist else plist !clist' = if id `elem` cs then f : clist else clist in (plist',clist') diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index ec119fc0d..f82d33644 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -25,8 +25,8 @@ data PGF = PGF { data Abstr = Abstr { aflags :: Map.Map CId Literal, -- ^ value of a flag - funs :: Map.Map CId (Type,Int,Maybe [Equation]), -- ^ type, arrity and definition of function - cats :: Map.Map CId ([Hypo],[CId]) -- ^ 1. context of a category + funs :: Map.Map CId (Type,Int,Maybe [Equation],Double), -- ^ type, arrity and definition of function + probability + cats :: Map.Map CId ([Hypo],[(Double, CId)]) -- ^ 1. context of a category -- ^ 2. functions of a category. The order in the list is important, -- this is the order in which the type singatures are given in the source. -- The termination of the exhaustive generation might depend on this. diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 9ab25bbcb..71e35be5e 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -318,22 +318,22 @@ data Value | VClosure Env Expr | VImplArg Value -type Sig = ( Map.Map CId (Type,Int,Maybe [Equation]) -- type and def of a fun - , Int -> Maybe Expr -- lookup for metavariables +type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double) -- type and def of a fun + , Int -> Maybe Expr -- lookup for metavariables ) type Env = [Value] eval :: Sig -> Env -> Expr -> Value eval sig env (EVar i) = env !! i eval sig env (EFun f) = case Map.lookup f (fst sig) of - Just (_,a,meqs) -> case meqs of - Just eqs -> if a == 0 - then case eqs of - Equ [] e : _ -> eval sig [] e - _ -> VConst f [] - else VApp f [] - Nothing -> VApp f [] - Nothing -> error ("unknown function "++showCId f) + Just (_,a,meqs,_) -> case meqs of + Just eqs -> if a == 0 + then case eqs of + Equ [] e : _ -> eval sig [] e + _ -> VConst f [] + else VApp f [] + Nothing -> VApp f [] + Nothing -> error ("unknown function "++showCId f) eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2] eval sig env (EAbs b x e) = VClosure env (EAbs b x e) eval sig env (EMeta i) = case snd sig i of @@ -347,12 +347,12 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value apply sig env e [] = eval sig env e apply sig env (EVar i) vs = applyValue sig (env !! i) vs apply sig env (EFun f) vs = case Map.lookup f (fst sig) of - Just (_,a,meqs) -> case meqs of - Just eqs -> if a <= length vs - then match sig f eqs vs - else VApp f vs - Nothing -> VApp f vs - Nothing -> error ("unknown function "++showCId f) + Just (_,a,meqs,_) -> case meqs of + Just eqs -> if a <= length vs + then match sig f eqs vs + else VApp f vs + Nothing -> VApp f vs + Nothing -> error ("unknown function "++showCId f) apply sig env (EApp e1 e2) vs = apply sig env e1 (eval sig env e2 : vs) apply sig env (EAbs _ x e) (v:vs) = apply sig (v:env) e vs apply sig env (EMeta i) vs = case snd sig i of diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index 58f0209a8..7a80a5ea8 100644 --- a/src/runtime/haskell/PGF/Forest.hs +++ b/src/runtime/haskell/PGF/Forest.hs @@ -72,7 +72,7 @@ bracketedTokn f@(Forest abs cnc forest root) = cat = case isLindefCId fun of Just cat -> cat Nothing -> case Map.lookup fun (funs abs) of - Just (DTyp _ cat _,_,_) -> cat + Just (DTyp _ cat _,_,_,_) -> cat largs = map (render forest) args ltable = mkLinTable cnc isTrusted [] funid largs in ((cat,fid),either (const []) id $ getAbsTrees f arg Nothing,ltable) diff --git a/src/runtime/haskell/PGF/Generate.hs b/src/runtime/haskell/PGF/Generate.hs index 797e5e229..55bfd72d9 100644 --- a/src/runtime/haskell/PGF/Generate.hs +++ b/src/runtime/haskell/PGF/Generate.hs @@ -3,8 +3,6 @@ module PGF.Generate , generateFrom, generateFromDepth , generateRandom, generateRandomDepth , generateRandomFrom, generateRandomFromDepth - - , RandomSelector(..) ) where import PGF.CId @@ -17,6 +15,7 @@ import PGF.Probabilistic import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Control.Monad +import Control.Monad.Identity import System.Random -- | Generates an exhaustive possibly infinite list of @@ -44,24 +43,24 @@ generateFromDepth pgf e dp = generateForMetas False pgf (\ty -> generateAllDepth -- | Generates an infinite list of random abstract syntax expressions. -- This is usefull for tree bank generation which after that can be used -- for grammar testing. -generateRandom :: RandomGen g => RandomSelector g -> PGF -> Type -> [Expr] -generateRandom sel pgf ty = - generate sel pgf ty Nothing +generateRandom :: RandomGen g => g -> PGF -> Type -> [Expr] +generateRandom g pgf ty = + generate (Identity g) pgf ty Nothing -- | A variant of 'generateRandom' which also takes as argument -- the upper limit of the depth of the generated expression. -generateRandomDepth :: RandomGen g => RandomSelector g -> PGF -> Type -> Maybe Int -> [Expr] -generateRandomDepth sel pgf ty dp = generate sel pgf ty dp +generateRandomDepth :: RandomGen g => g -> PGF -> Type -> Maybe Int -> [Expr] +generateRandomDepth g pgf ty dp = generate (Identity g) pgf ty dp -- | Random generation based on template -generateRandomFrom :: RandomGen g => RandomSelector g -> PGF -> Expr -> [Expr] -generateRandomFrom sel pgf e = - generateForMetas True pgf (\ty -> generate sel pgf ty Nothing) e +generateRandomFrom :: RandomGen g => g -> PGF -> Expr -> [Expr] +generateRandomFrom g pgf e = + generateForMetas True pgf (\ty -> generate (Identity g) pgf ty Nothing) e -- | Random generation based on template with a limitation in the depth. -generateRandomFromDepth :: RandomGen g => RandomSelector g -> PGF -> Expr -> Maybe Int -> [Expr] -generateRandomFromDepth sel pgf e dp = - generateForMetas True pgf (\ty -> generate sel pgf ty dp) e +generateRandomFromDepth :: RandomGen g => g -> PGF -> Expr -> Maybe Int -> [Expr] +generateRandomFromDepth g pgf e dp = + generateForMetas True pgf (\ty -> generate (Identity g) pgf ty dp) e @@ -103,8 +102,8 @@ prove abs scope tty@(TTyp env (DTyp [] cat es)) dp = do clauses cat = do fn <- select abs cat case Map.lookup fn (funs abs) of - Just (ty,_,_) -> return (fn,ty) - Nothing -> mzero + Just (ty,_,_,_) -> return (fn,ty) + Nothing -> mzero mkEnv env [] = return (env,[]) mkEnv env ((bt,x,ty):hypos) = do @@ -175,46 +174,23 @@ instance Selector () where Just (_,fns) -> iter s fns Nothing -> CFail) where - iter s [] = CFail - iter s (fn:fns) = CBranch (COk () s fn) (iter s fns) + iter s [] = CFail + iter s ((_,fn):fns) = CBranch (COk () s fn) (iter s fns) --- | The random selector data type is used to specify the random number generator --- and the distribution among the functions with the same result category. --- The distribution is even for 'RandSel' and weighted for 'WeightSel'. -data RandomSelector g = RandSel g - | WeightSel g Probabilities +instance RandomGen g => Selector (Identity g) where + splitSelector (Identity g) = let (g1,g2) = split g + in (Identity g1, Identity g2) -instance RandomGen g => Selector (RandomSelector g) where - splitSelector (RandSel g) = let (g1,g2) = split g - in (RandSel g1, RandSel g2) - splitSelector (WeightSel g probs) = let (g1,g2) = split g - in (WeightSel g1 probs, WeightSel g2 probs) - - select abs cat = GenM (\sel s -> case sel of - RandSel g -> case Map.lookup cat (cats abs) of - Just (_,fns) -> do_rand g s (length fns) fns - Nothing -> CFail - WeightSel g probs -> case Map.lookup cat (catProbs probs) of - Just fns -> do_weight g s 1.0 fns - Nothing -> CFail) + select abs cat = GenM (\(Identity g) s -> + case Map.lookup cat (cats abs) of + Just (_,fns) -> do_rand g s 1.0 fns + Nothing -> CFail) where - do_rand g s n [] = CFail - do_rand g s n fns = let n' = n-1 - (i,g') = randomR (0,n') g + do_rand g s p [] = CFail + do_rand g s p fns = let (d,g') = randomR (0.0,p) g (g1,g2) = split g' - (fn,fns') = pick i fns - in CBranch (COk (RandSel g1) s fn) (do_rand g2 s n' fns') - - do_weight g s p [] = CFail - do_weight g s p fns = let (d,g') = randomR (0.0,p) g - (g1,g2) = split g' - (p',fn,fns') = hit d fns - in CBranch (COk (RandSel g1) s fn) (do_weight g2 s (p-p') fns') - - pick :: Int -> [a] -> (a,[a]) - pick 0 (x:xs) = (x,xs) - pick n (x:xs) = let (x',xs') = pick (n-1) xs - in (x',x:xs') + (p',fn,fns') = hit d fns + in CBranch (COk (Identity g1) s fn) (do_rand g2 s (p-p') fns') hit :: Double -> [(Double,a)] -> (Double,a,[(Double,a)]) hit d (px@(p,x):xs) diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs index 1daeb50f6..49cc4564c 100644 --- a/src/runtime/haskell/PGF/Linearize.hs +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -96,7 +96,7 @@ linTree pgf lang e = Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set] where toApp fid (PApply funid pargs) = - let Just (ty,_,_) = Map.lookup f (funs (abstract pgf)) + let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf)) (args,res) = catSkeleton ty in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])] toApp _ (PCoerce fid) = diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index ae984cfdf..40c2a754f 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -21,18 +21,18 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) } lookType :: PGF -> CId -> Type lookType pgf f = case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of - (ty,_,_) -> ty + (ty,_,_,_) -> ty lookDef :: PGF -> CId -> Maybe [Equation] lookDef pgf f = case lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) of - (_,a,eqs) -> eqs + (_,a,eqs,_) -> eqs isData :: PGF -> CId -> Bool isData pgf f = case Map.lookup f (funs (abstract pgf)) of - Just (_,_,Nothing) -> True -- the encoding of data constrs - _ -> False + Just (_,_,Nothing,_) -> True -- the encoding of data constrs + _ -> False lookValCat :: PGF -> CId -> CId lookValCat pgf = valCat . lookType pgf @@ -65,7 +65,7 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang functionsToCat :: PGF -> CId -> [(CId,Type)] functionsToCat pgf cat = - [(f,ty) | f <- fs, Just (ty,_,_) <- [Map.lookup f $ funs $ abstract pgf]] + [(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]] where (_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf @@ -81,7 +81,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF restrictPGF cond pgf = pgf { abstract = abstr { funs = Map.filterWithKey (\c _ -> cond c) (funs abstr), - cats = Map.map (\(hyps,fs) -> (hyps,filter cond fs)) (cats abstr) + cats = Map.map (\(hyps,fs) -> (hyps,filter (cond . snd) fs)) (cats abstr) } } ---- restrict concrs also, might be needed where diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs index 3835b73c7..8213518ff 100644 --- a/src/runtime/haskell/PGF/Paraphrase.hs +++ b/src/runtime/haskell/PGF/Paraphrase.hs @@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where isClosed d || (length equs == 1 && isLinear d)] equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | - (f,(_,_,Just eqs)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] + (f,(_,_,Just eqs,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index ae23b96da..a7a34bc00 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -28,17 +28,17 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$ ppFlag :: CId -> Literal -> Doc ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';' -ppCat :: CId -> ([Hypo],[CId]) -> Doc +ppCat :: CId -> ([Hypo],[(Double,CId)]) -> Doc ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' -ppFun :: CId -> (Type,Int,Maybe [Equation]) -> Doc -ppFun f (t,_,Just eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ - if null eqs - then empty - else text "def" <+> vcat [let scope = foldl pattScope [] patts - ds = map (ppPatt 9 scope) patts - in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] -ppFun f (t,_,Nothing) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' +ppFun :: CId -> (Type,Int,Maybe [Equation],Double) -> Doc +ppFun f (t,_,Just eqs,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ + if null eqs + then empty + else text "def" <+> vcat [let scope = foldl pattScope [] patts + ds = map (ppPatt 9 scope) patts + in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] +ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' ppCnc :: Language -> Concr -> Doc ppCnc name cnc = diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs index a256983c9..873f17be4 100644 --- a/src/runtime/haskell/PGF/Probabilistic.hs +++ b/src/runtime/haskell/PGF/Probabilistic.hs @@ -2,6 +2,8 @@ module PGF.Probabilistic ( Probabilities(..) , mkProbabilities -- :: PGF -> M.Map CId Double -> Probabilities , defaultProbabilities -- :: PGF -> Probabilities + , getProbabilities + , setProbabilities , showProbabilities -- :: Probabilities -> String , readProbabilitiesFromFile -- :: FilePath -> PGF -> IO Probabilities @@ -15,7 +17,7 @@ import PGF.Macros import qualified Data.Map as Map import Data.List (sortBy,partition) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, fromJust) -- | An abstract data structure which represents -- the probabilities for the different functions in a grammar. @@ -51,7 +53,7 @@ mkProbabilities pgf probs = cats1 = Map.map (\(_,fs) -> fill fs) (cats (abstract pgf)) in Probs funs1 cats1 where - fill fs = pad [(Map.lookup f probs,f) | f <- fs] + fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs] where pad :: [(Maybe Double,a)] -> [(Double,a)] pad pfs = [(fromMaybe deflt mb_p,f) | (mb_p,f) <- pfs] @@ -64,16 +66,34 @@ mkProbabilities pgf probs = defaultProbabilities :: PGF -> Probabilities defaultProbabilities pgf = mkProbabilities pgf Map.empty +getProbabilities :: PGF -> Probabilities +getProbabilities pgf = Probs { + funProbs = Map.map (\(_,_,_,p) -> p) (funs (abstract pgf)), + catProbs = Map.map (\(_,fns) -> fns) (cats (abstract pgf)) + } + +setProbabilities :: Probabilities -> PGF -> PGF +setProbabilities probs pgf = pgf { + abstract = (abstract pgf) { + funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df,p)) (funs (abstract pgf)) (funProbs probs), + cats = mapUnionWith (\(hypos,_) fns -> (hypos,fns)) (cats (abstract pgf)) (catProbs probs) + }} + where + mapUnionWith f map1 map2 = + Map.mapWithKey (\k v -> f v (fromJust (Map.lookup k map2))) map1 + -- | compute the probability of a given tree -probTree :: Probabilities -> Expr -> Double -probTree probs t = case t of - EApp f e -> probTree probs f * probTree probs e - EFun f -> maybe 1 id $ Map.lookup f (funProbs probs) +probTree :: PGF -> Expr -> Double +probTree pgf t = case t of + EApp f e -> probTree pgf f * probTree pgf e + EFun f -> case Map.lookup f (funs (abstract pgf)) of + Just (_,_,_,p) -> p + Nothing -> 1 _ -> 1 -- | rank from highest to lowest probability -rankTreesByProbs :: Probabilities -> [Expr] -> [(Expr,Double)] -rankTreesByProbs probs ts = sortBy (\ (_,p) (_,q) -> compare q p) - [(t, probTree probs t) | t <- ts] +rankTreesByProbs :: PGF -> [Expr] -> [(Expr,Double)] +rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p) + [(t, probTree pgf t) | t <- ts] diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 359a188a7..d95e50c5e 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -101,8 +101,8 @@ lookupCatHyps cat = TcM (\abstr ms -> case Map.lookup cat (cats abstr) of lookupFunType :: CId -> TcM TType lookupFunType fun = TcM (\abstr ms -> case Map.lookup fun (funs abstr) of - Just (ty,_,_) -> Ok ms (TTyp [] ty) - Nothing -> Fail (UnknownFun fun)) + Just (ty,_,_,_) -> Ok ms (TTyp [] ty) + Nothing -> Fail (UnknownFun fun)) newMeta :: Scope -> TType -> TcM MetaId newMeta scope tty = TcM (\abstr ms -> let metaid = IntMap.size ms + 1 diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index f28bce67b..d8371d1c8 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -469,7 +469,7 @@ linearizeAndBind pgf mto t = [(la, binds s) | (la,s) <- linearize' pgf mto t] random' :: PGF -> Maybe PGF.Type -> IO [PGF.Tree] random' pgf mcat = do g <- newStdGen - return $ PGF.generateRandom (PGF.RandSel g) pgf (fromMaybe (PGF.startCat pgf) mcat) + return $ PGF.generateRandom g pgf (fromMaybe (PGF.startCat pgf) mcat) selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language selectLanguage pgf macc = case acceptable of