From 3307118eb02c7bb08784974f2f3cf1b9f6a1e79a Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 31 Oct 2005 07:12:18 +0000 Subject: [PATCH] more probs --- src/GF/Probabilistic/Probabilistic.hs | 32 ++++++++++++++++++++------- src/GF/Shell.hs | 14 +++++++++--- src/GF/Shell/ShellCommands.hs | 9 ++++---- 3 files changed, 40 insertions(+), 15 deletions(-) diff --git a/src/GF/Probabilistic/Probabilistic.hs b/src/GF/Probabilistic/Probabilistic.hs index bc69a1cf3..81f9a60d0 100644 --- a/src/GF/Probabilistic/Probabilistic.hs +++ b/src/GF/Probabilistic/Probabilistic.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/30 23:44:00 $ +-- > CVS $Date: 2005/10/31 08:12:18 $ -- > CVS $Author: aarne $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Probabilistic abstract syntax. AR 30\/10\/2005 -- @@ -33,7 +33,7 @@ import GF.Grammar.LookAbs import GF.Grammar.PrGrammar import GF.Grammar.Macros import GF.Grammar.Values -import GF.Grammar.Grammar (Cat) +import GF.Grammar.Grammar -- (Cat,EInt,K) import GF.Infra.Ident import GF.Data.Zipper @@ -74,9 +74,13 @@ rankByScore = sortBy (\ (_,p) (_,q) -> compare q p) getProbsFromFile :: Options -> IO Probs getProbsFromFile opts = do s <- maybe (return "") readFile $ getOptVal opts probFile - return $ buildTree $ pProbs $ lines s + return $ buildTree $ concatMap pProb $ lines s where - pProbs ss = [(zIdent f, read p) | s <- ss, [f,p] <- [words s]] + pProb s = case words s of + "--":f:p:_ | isDouble p -> [(zIdent f, read p)] + f:p:_ | isDouble p -> [(zIdent f, read p)] + _ -> [] + isDouble = all (flip elem ('.':['0'..'9'])) type Probs = BinTree Ident Double @@ -87,7 +91,7 @@ emptyProbs = emptyBinTree -- translate grammar to simpler form and generated trees back gr2sgr :: GFCGrammar -> Probs -> SGrammar -gr2sgr gr probs = buildTree [(c,{- fillProb -} rs) | rs@((_,(_,c)):_) <- rules] where +gr2sgr gr probs = buildTree [(c,fillProb rs) | rs@((_,(_,c)):_) <- rules] where rules = groupBy (\x y -> scat x == scat y) $ sortBy (\x y -> compare (scat x) (scat y)) @@ -105,7 +109,8 @@ str2tr :: STree -> Exp str2tr t = case t of SApp ((_,f),ts) -> mkApp (trId f) (map str2tr ts) SMeta _ -> mkMeta 0 ----- SString s -> K s + SString s -> K s + SInt i -> EInt i where trId = cn . zIdent @@ -144,12 +149,23 @@ genTrees ds gr cat = genTree :: [Double] -> SGrammar -> SCat -> (STree,Int) genTree rs gr = gett rs where + gett ds "String" = (SString "foo",1) + gett ds "Int" = (SInt 1978,1) gett ds cat = let d:ds2 = ds (pf,args) = getf d cat (ts,k) = getts ds2 args in (SApp (pf,ts), k+1) - getf d cat = hitRegion d [(p,(pf,args)) | (pf@(p,_),(args,_)) <- look cat] + getf d cat = + let + regs0 = [(p,(pf,args)) | (pf@(p,_),(args,_)) <- look cat] +{- not needed + pstd = 1.0 / genericLength regs + regs = if any (>1.0) (map fst regs0) + then [(pstd,pa) | (_,pa) <- regs0] + else regs0 +-} + in hitRegion d regs0 getts ds cats = case cats of c:cs -> let (t, k) = gett ds c diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index 4a214bd4c..03a47a05c 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/30 23:44:00 $ +-- > CVS $Date: 2005/10/31 08:12:18 $ -- > CVS $Author: aarne $ --- > CVS $Revision: 1.47 $ +-- > CVS $Revision: 1.48 $ -- -- GF shell command interpreter. ----------------------------------------------------------------------------- @@ -226,7 +226,7 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com probs <- getProbsFromFile opts let tps = rankByScore [(t,computeProbTree probs t) | t <- ts] putStrLnFlush msg - mapM_ putStrLnFlush [show p +++ prt_ t | (t,p) <- tps] + mapM_ putStrLnFlush [show p | (t,p) <- tps] changeArg (const $ ATrms (map fst tps)) sa | otherwise -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa Bad msg -> changeArg (const $ AError (msg +++ "input" +++ x)) sa @@ -244,6 +244,14 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com let ts = take n $ generateRandomTreesProb opts gen cgr probs cat returnArg (ATrms (map (term2tree gro) ts)) sa + CGenerateRandom | oElem showCF opts -> do + let probs = emptyProbs --- + let cat = firstAbsCat opts gro + let n = optIntOrN opts flagNumber 1 + gen <- newStdGen + let ts = take n $ generateRandomTreesProb opts gen cgr probs cat + returnArg (ATrms (map (term2tree gro) ts)) sa + CGenerateRandom -> do let a' = case a of diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs index fefc9a821..eac97b22c 100644 --- a/src/GF/Shell/ShellCommands.hs +++ b/src/GF/Shell/ShellCommands.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/13 13:43:47 $ +-- > CVS $Date: 2005/10/31 08:12:18 $ -- > CVS $Author: aarne $ --- > CVS $Revision: 1.43 $ +-- > CVS $Revision: 1.44 $ -- -- The datatype of shell commands and the list of their options. ----------------------------------------------------------------------------- @@ -173,9 +173,10 @@ optionsOfCommand co = case co of CTransformGrammar _ -> flags "printer" CConvertLatex _ -> none CLinearize _ -> both "utf8 table struct record all multi" "lang number unlexer" - CParse -> both "new newer cfg mcfg n ign raw v lines all" "cat lang lexer parser number rawtrees" + CParse -> both "new newer cfg mcfg n ign raw v lines all" + "cat lang lexer parser number rawtrees probs" CTranslate _ _ -> opts "cat lexer parser" - CGenerateRandom -> flags "cat lang number depth" + CGenerateRandom -> flags "cat lang number depth probs" CGenerateTrees -> both "metas" "atoms depth alts cat lang number" CPutTerm -> flags "transform number" CWrapTerm _ -> opts "c"