gf-3.3.3: src/example-based/ExampleDemo.hs
module ExampleDemo (Environ,initial,getNext, provideExample, testThis,mkFuncWithArg,searchGoodTree,isMeta)
where
import PGF
import System.IO
import Data.List
import Control.Monad
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import Data.Maybe
import System.Environment (getArgs)
import System.Random (RandomGen) --newStdGen
type MyType = CId -- name of the categories from the program
type ConcType = CId -- categories from the resource grammar, that we parse on
type MyFunc = CId -- functions that we need to implement
--type FuncWithArg = ((MyFunc, MyType), Expr) -- function with arguments
type InterInstr = [String] -- lincats that were generated but not written to the file
data FuncWithArg = FuncWithArg
{getName :: MyFunc, -- name of the function to generate
getType :: MyType, -- return type of the function
getTypeArgs :: [MyType] -- types of arguments
}
deriving (Show,Eq,Ord)
-- we assume that it's for English for the moment
type TypeMap = Map.Map MyType ConcType -- mapping found from a file
type ConcMap = Map.Map MyFunc Expr -- concrete expression after parsing
data Environ = Env {getTypeMap :: TypeMap, -- mapping between a category in the grammar and a concrete type from RGL
getConcMap :: ConcMap, -- concrete expression after parsing
getSigs :: Map.Map MyType [FuncWithArg], -- functions for which we have the concrete syntax already with args
getAll :: [FuncWithArg] -- all the functions with arguments
}
getNext :: Environ -> Environ -> ([MyFunc],[MyFunc])
getNext env example_env =
let sgs = getSigs env
allfuncs = getAll env
names = Set.fromList $ map getName $ concat $ Map.elems sgs
exampleable = filter (\x -> (isJust $ getNameExpr x env)
&&
(not $ Set.member x names) -- maybe drop this if you want to also rewrite from examples...
) $ map getName allfuncs
testeable = filter (\x -> (isJust $ getNameExpr x env )
&&
(Set.member x names)
) $ map getName allfuncs
in (exampleable,testeable)
provideExample :: RandomGen gen => gen -> Environ -> MyFunc -> PGF -> PGF -> Language -> Maybe (Expr,String)
provideExample gen env myfunc parsePGF pgfFile lang =
fmap giveExample $ getNameExpr myfunc env
where
giveExample e_ =
let newexpr = head $ generateRandomFromDepth gen pgfFile e_ (Just 5) -- change here with the new random generator
ty = getType $ head $ filter (\x -> getName x == myfunc) $ getAll env
embeddedExpr = maybe "" (\x -> ", as in: " ++ q (linearize pgfFile lang x)) (embedInStart (getAll env) (Map.fromList [(ty,e_)]))
lexpr = linearize pgfFile lang newexpr
q s = sq++s++sq
sq = "\""
in (newexpr,q lexpr ++ embeddedExpr)
-- question, you need the IO monad for the random generator, how to do otherwise ??
-- question can you make the expression bold/italic - somehow distinguishable from the rest ?
testThis :: Environ -> MyFunc -> PGF -> Language -> Maybe String
testThis env myfunc parsePGF lang =
fmap (linearize parsePGF lang . mapToResource env . llin env) $
getNameExpr myfunc env
-- we assume that even the functions linearized by the user will still be in getSigs along with their linearization
-- fill in the blancs of an expression that we want to linearize for testing purposes
---------------------------------------------------------------------------
llin :: Environ -> Expr -> Expr
llin env expr =
let
(id,args) = fromJust $ unApp expr
cexpr = fromJust $ Map.lookup id (getConcMap env)
in
if any isMeta args
then let
sigs = concat $ Map.elems $ getSigs env
tys = findExprWhich sigs id
in replaceConcArg 1 tys expr env
else mkApp id $ map (llin env) args
-- argument of the meta variable to replace, list of arguments left, expression to replace, environment, current replace expression
replaceConcArg :: Int -> [MyType] -> Expr -> Environ -> Expr
replaceConcArg i [] expr env = expr
replaceConcArg i (t:ts) expr env = -- TO DO : insert randomness here !!
let ss = fromJust $ Map.lookup t $ getSigs env
args = filter (null . getTypeArgs) ss
finArg = if null args then let l = last ss in llin env (mkApp (getName l) [mkMeta j | j <- [1..(length $ getTypeArgs l)]])
else mkApp (getName $ last args) []
in
let newe = replaceOne i finArg expr
in replaceConcArg (i+1) ts newe env
-- replace a certain metavariable with a certain expression in another expression - return updated expression
replaceOne :: Int -> Expr -> Expr -> Expr
replaceOne i erep expr =
if isMeta expr && ((fromJust $ unMeta expr) == i)
then erep
else if isMeta expr then expr
else let (id,args) = fromJust $ unApp expr
in
mkApp id $ map (replaceOne i erep) args
findExprWhich :: [FuncWithArg] -> MyFunc -> [MyType]
findExprWhich lst f = getTypeArgs $ head $ filter (\x -> getName x == f) lst
mapToResource :: Environ -> Expr -> Expr
mapToResource env expr =
let (id,args) = maybe (error $ "tried to unwrap " ++ showExpr [] expr) (\x -> x) (unApp expr)
cmap = getConcMap env
cexp = maybe (error $ "didn't find " ++ showCId id ++ " in "++ show cmap) (\x -> x) (Map.lookup id cmap)
in
if null args then cexp
else let newargs = map (mapToResource env) args
in replaceAllArgs cexp 1 newargs
where
replaceAllArgs expr i [] = expr
replaceAllArgs expr i (x:xs) = replaceAllArgs (replaceOne i x expr) (i+1) xs
-----------------------------------------------
-- embed expression in another one from the start category
embedInStart :: [FuncWithArg] -> Map.Map MyType Expr -> Maybe Expr
embedInStart fss cs =
let currset = Map.toList cs
nextset = Map.fromList $ concat [ if elem myt (getTypeArgs farg)
then connectWithArg (myt,exp) farg else []
| (myt,exp) <- currset, farg <- fss]
nextmap = Map.union cs nextset
maybeExpr = Map.lookup startCateg nextset
in if isNothing maybeExpr then
if Map.size nextmap == Map.size cs then Nothing --error $ "could't build " ++ show startCateg ++ "with " ++ show fss
else embedInStart fss nextmap
else return $ fromJust maybeExpr
where
connectWithArg (myt,exp) farg =
let ind = head $ elemIndices myt (getTypeArgs farg)
in [(getType farg, mkApp (getName farg) $ [mkMeta i | i <- [1..ind]] ++ [exp] ++ [mkMeta i | i <- [(ind + 1)..((length $ getTypeArgs farg) - 1)]])]
-----------------------------------------------
updateConcMap :: Environ -> MyFunc -> Expr -> Environ
updateConcMap env myf expr =
Env (getTypeMap env) (Map.insert myf expr (getConcMap env)) (getSigs env) (getAll env)
updateInterInstr :: Environ -> MyType -> FuncWithArg -> Environ
updateInterInstr env myt myf =
let ii = getSigs env
newInterInstr =
maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
in Env (getTypeMap env) (getConcMap env) newInterInstr (getAll env)
putSignatures :: Environ -> [FuncWithArg] -> Environ
putSignatures env fss =
Env (getTypeMap env) (getConcMap env) (mkSigs fss) (getAll env)
updateEnv :: Environ -> FuncWithArg -> MyType -> Expr -> Environ
updateEnv env myf myt expr =
let ii = getSigs env
nn = getName myf
newInterInstr =
maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
in Env (getTypeMap env) (Map.insert nn expr (getConcMap env)) newInterInstr (getAll env)
mkSigs :: [FuncWithArg] -> Map.Map MyType [FuncWithArg]
mkSigs fss = Map.fromListWith (++) $ zip (map getType fss) (map (\x -> [x]) fss)
------------------------------------
lang :: String
lang = "Eng"
parseLang :: Language
parseLang = fromJust $ readLanguage "ParseEng"
parsePGFfile :: String
parsePGFfile = "ParseEngAbs.pgf"
------------------------------------
searchGoodTree :: Environ -> Expr -> [Expr] -> IO (Maybe (Expr,Expr))
searchGoodTree env expr [] = return Nothing
searchGoodTree env expr (e:es) =
do val <- debugReplaceArgs expr e env
maybe (searchGoodTree env expr es) (\x -> return $ Just (x,e)) val
getNameExpr :: MyFunc -> Environ -> Maybe Expr
getNameExpr myfunc env =
let allfunc = filter (\x -> getName x == myfunc) $ getAll env
in
if null allfunc then Nothing
else getExpr (head allfunc) env
-- find an expression to generate where we have all the other elements available
getExpr :: FuncWithArg -> Environ -> Maybe Expr
getExpr farg env =
let tys = getTypeArgs farg
ctx = getSigs env
lst = getConcTypes ctx tys 1
in if (all isJust lst) then Just $ mkApp (getName farg) (map fromJust lst)
else Nothing
where getConcTypes context [] i = []
getConcTypes context (ty:types) i =
let pos = Map.lookup ty context
in
if isNothing pos || (null $ fromJust pos) then [Nothing]
else
let mm = last $ fromJust pos
mmargs = getTypeArgs mm
newi = i + length mmargs - 1
lst = getConcTypes (Map.insert ty (init $ (fromJust pos)) context) types (newi+1)
in
if (all isJust lst) then -- i..newi
(Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst
else [Nothing]
-- only covers simple expressions with meta variables, not the rest...
isGeneralizationOf :: Expr -> Expr -> Bool
isGeneralizationOf genExpr testExpr =
if isMeta genExpr then True
else if isMeta testExpr then False
else let genUnwrap = unApp genExpr
testUnwrap = unApp testExpr
in if isNothing genUnwrap || isNothing testUnwrap then False -- see if you can generalize here
else let (gencid, genargs) = fromJust genUnwrap
(testcid, testargs) = fromJust testUnwrap
in
(gencid == testcid) && (length genargs == length testargs)
&& (and [isGeneralizationOf g t | (g,t) <- (zip genargs testargs)])
{-do lst <- getConcTypes context types (i+1)
return $ mkMeta i : lst -}
debugReplaceArgs :: Expr -> Expr -> Environ -> IO (Maybe Expr)
debugReplaceArgs aexpr cexpr env =
if isNothing $ unApp aexpr then return Nothing
else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then return Nothing
else
let args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr
concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args
in startReplace 1 cexpr concExprs
where
startReplace i cex [] = return $ Just cex
startReplace i cex (a:as) = do val <- debugReplaceConc cex i a
maybe ( --do putStrLn $ "didn't find "++ showExpr [] a ++ " in " ++showExpr [] cexpr
return Nothing)
(\x -> --do putStrLn $ "found it, the current expression is "++ showExpr [] x
startReplace (i+1) x as)
val
debugReplaceConc :: Expr -> Int -> Expr -> IO (Maybe Expr)
debugReplaceConc expr i e =
let (newe,isThere) = searchArg expr
in if isThere then return $ Just newe else return $ Nothing
where
searchArg e_ =
if isGeneralizationOf e e_ then (mkMeta i, True)
else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args
in (mkApp cid (map fst repargs), or $ map snd repargs)) $ unApp e_
-- replaceArgs : Original expression to parse (from abstract syntax) -> Concrete expression (parsed)
replaceArgs :: Expr -> Expr -> Environ -> Maybe Expr
replaceArgs aexpr cexpr env =
if isNothing $ unApp aexpr then error $ "could't unwrap this "++ show aexpr
else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then error $ "couldn't unwrap more this : "++ show aexpr
else
let args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr
concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args
in startReplace 1 cexpr concExprs
where
startReplace i cex [] = return cex
startReplace i cex (a:as) = maybe Nothing (\x -> startReplace (i+1) x as) $ replaceConc cex i a
replaceConc :: Expr -> Int -> Expr -> Maybe Expr
replaceConc expr i e =
let (newe,isThere) = searchArg expr
in if isThere then return newe else Nothing
where
searchArg e_ =
if isGeneralizationOf e e_ then (mkMeta i, True)
else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args
in (mkApp cid (map fst repargs), or $ map snd repargs)) $ unApp e_
writeResults :: Environ -> String -> IO ()
writeResults env fileName =
let cmap = getConcMap env
lincats = unlines $ map (\(x,y) -> "lincat " ++ showCId x ++ " = " ++ showCId y ++ " ; " ) $ Map.toList $ getTypeMap env
sigs = unlines $ map
(\x -> let n = getName x
no = length $ getTypeArgs x
oargs = unwords $ ("lin " ++ showCId n) : ["o"++show i | i <- [1..no]]
in (oargs ++ " = " ++ (simpleReplace $ showExpr [] $ fromJust $ Map.lookup n cmap) ++ " ; ")) $ concat $ Map.elems $ getSigs env
in
writeFile fileName ("\n" ++ lincats ++ "\n\n" ++ sigs)
simpleReplace :: String -> String
simpleReplace [] = []
simpleReplace ('?':xs) = 'o' : simpleReplace xs
simpleReplace (x:xs) = x : simpleReplace xs
isMeta :: Expr -> Bool
isMeta = isJust.unMeta
-- works with utf-8 characters also, as it seems
mkFuncWithArg :: ((CId,CId),[CId]) -> FuncWithArg
mkFuncWithArg ((c1,c2),cids) = FuncWithArg c1 c2 cids
---------------------------------------------------------------------------------
initial :: TypeMap -> ConcMap -> [FuncWithArg] -> [FuncWithArg] -> Environ
initial tm cm fss allfs = Env tm cm (mkSigs fss) allfs
testInit :: [FuncWithArg] -> Environ
testInit allfs = initial lTypes Map.empty [] allfs
lTypes = Map.fromList [(mkCId "Comment", mkCId "S"),(mkCId "Item", mkCId "NP"), (mkCId "Kind", mkCId "CN"), (mkCId "Quality", mkCId "AP")]
startCateg = mkCId "Comment"
-- question about either to give the startcat or not ...
----------------------------------------------------------------------------------------------------------
{-
main =
do args <- getArgs
case args of
[pgfFile] ->
do pgf <- readPGF pgfFile
parsePGF <- readPGF parsePGFfile
fsWithArg <- forExample pgf
let funcsWithArg = map (map mkFuncWithArg) fsWithArg
let morpho = buildMorpho parsePGF parseLang
let fss = concat funcsWithArg
let fileName = takeWhile (/='.') pgfFile ++ lang ++ ".gf"
env <- start parsePGF pgf morpho (testInit fss) fss
putStrLn $ "Should I write the results to a file ? yes/no"
ans <-getLine
if ans == "yes" then do writeResults env fileName
putStrLn $ "Wrote file " ++ fileName
else return ()
_ -> fail "usage : Testing <path-to-pgf> "
start :: PGF -> PGF -> Morpho -> Environ -> [FuncWithArg] -> IO Environ
start parsePGF pgfFile morpho env lst =
do putStrLn "Do you want examples from another language ? (no/concrete syntax name otherwise)"
ans1 <- getLine
putStrLn "Do you want testing mode ? (yes/no)"
ans2 <- getLine
case (ans1,ans2) of
("no","no") -> do putStrLn "no extra language, just the abstract syntax tree"
interact env lst False Nothing
(_,"no") -> interact env lst False (readLanguage ans1)
("no","yes") -> do putStrLn "no extra language, just the abstract syntax tree"
interact env lst True Nothing
(_,"yes") -> interact env lst True (readLanguage ans1)
("no",_) -> do putStrLn "no extra language, just the abstract syntax tree"
putStrLn $ "I assume you don't want the testing mode ... "
interact env lst False Nothing
(_,_) -> do putStrLn $ "I assume you don't want the testing mode ... "
interact env lst False (readLanguage ans1)
where
interact environ [] func _ = return environ
interact environ (farg:fargs) boo otherLang =
do
maybeEnv <- basicInter farg otherLang environ boo
if isNothing maybeEnv then return environ
else interact (fromJust maybeEnv) fargs boo otherLang
basicInter farg js environ False =
let e_ = getExpr farg environ in
if isNothing e_ then return $ Just environ
else parseAndBuild farg js environ (getType farg) e_ Nothing
basicInter farg js environ True =
let (e_,e_test) = get2Expr farg environ in
if isNothing e_ then return $ Just environ
else if isNothing e_test then do putStrLn $ "not enough arguments "++ (showCId $ getName farg)
parseAndBuild farg js environ (getType farg) e_ Nothing
else parseAndBuild farg js environ (getType farg) e_ e_test
-- . head . generateRandomFrom gen2 pgfFile
parseAndBuild farg js environ ty e_ e_test =
do let expr = fromJust e_
gen1 <- newStdGen
gen2 <- newStdGen
let newexpr = head $ generateRandomFrom gen1 pgfFile expr
let embeddedExpr = maybe "***" (showExpr [] ) (embedInStart (getAll environ) (Map.fromList [(ty,expr)]))
let lexpr = if isNothing js then "" else "\n-- " ++ linearize pgfFile (fromJust js) newexpr ++ " --"
putStrLn $ "Give an example for " ++ (showExpr [] expr)
++ lexpr ++ "and now"
++ "\n\nas in " ++ embeddedExpr ++ "\n\n"
--
ex <- getLine
if (ex == ":q") then return Nothing
else
let ctype = fromJust $ Map.lookup (getType farg) (getTypeMap environ) in
do env' <- decypher farg ex expr environ (fromJust $ readType $ showCId ctype) e_test
return (Just env')
decypher farg ex expr environ ty e_test =
--do putStrLn $ "We need to parse " ++ ex ++ " as " ++ show ctype
let pTrees = parse parsePGF (fromJust $ readLanguage "ParseEng") ty ex in
pickTree farg expr environ ex e_test pTrees
-- putStrLn $ "And now for testing, \n is this also correct yes/no \n ## " ++ (linearize parsePGF parseLang $ mapToResource newenv $ llin newenv e_test) ++ " ##"
-- select the right tree among the options given by the parser
pickTree farg expr environ ex e_test [] =
let miswords = morphoMissing morpho (words ex)
in
if null miswords then do putStrLn $ "all words known, but some syntactic construction is not covered by the grammar..."
return environ
else do putStrLn $ "the following words are unknown, please add them to the lexicon: " ++ show miswords
return environ
pickTree farg expr environ ex e_test [tree] =
do val <- searchGoodTree environ expr [tree] -- maybe order here after the probabilities for better precision
maybe (do putStrLn $ "none of the trees is consistent with the rest of the grammar, please check arguments "
return environ)
(\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
do putStrLn $ "the result is "++showExpr [] x
newtestenv <- testTest newenv e_test -- question ? should it belong there - there is just one possibility of a tree...
return newenv) val
pickTree farg expr environ ex e_test parseTrees =
do putStrLn $ "There is more than one possibility, do you want to choose the right tree yourself ? yes/no "
putStr " >"
ans <- getLine
if ans == "yes" then do pTree <- chooseRightTree parseTrees
processTree farg environ expr pTree e_test
else processTree farg environ expr parseTrees e_test
-- introduce testing function, if it doesn't work, then reparse, take that tree
testTree envv e_test = return envv -- TO DO - add testing here
testTest envv Nothing = return envv
testTest envv (Just exxpr) = testTree envv exxpr
-- allows the user to pick his own tree
chooseRightTree trees = return trees -- TO DO - add something clever here
-- selects the tree from where one can abstract over the original arguments
processTree farg environ expr lsTrees e_test =
let trmes = if length lsTrees == 1 then "the tree is not consistent " else "none of the trees is consistent " in
do val <- searchGoodTree environ expr lsTrees
maybe (do putStrLn $ trmes ++ "with the rest of the grammar, please check arguments! "
return environ)
(\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
do putStrLn $ "the result is "++showExpr [] x
newtestenv <- testTest newenv e_test
return newenv) val
-------------------------------
get2Expr :: FuncWithArg -> Environ -> (Maybe Expr, Maybe Expr)
get2Expr farg env =
let tys = getTypeArgs farg
ctx = getSigs env
(lst1,lst2) = getConcTypes2 ctx tys 1
arg1 = if (all isJust lst1) then Just $ mkApp (getName farg) (map fromJust lst1) else Nothing
arg2 = if (all isJust lst2) then Just $ mkApp (getName farg) (map fromJust lst2) else Nothing
in if arg1 == arg2 then (arg1, Nothing)
else (arg1,arg2)
where
getConcTypes2 context [] i = ([],[])
getConcTypes2 context (ty:types) i =
let pos = Map.lookup ty context
in
if isNothing pos || (null $ fromJust pos) then ([Nothing],[Nothing])
else
let (mm,tt) = (last $ fromJust pos, head $ fromJust pos)
mmargs = getTypeArgs mm
newi = i + length mmargs - 1
(lst1,lst2) = getConcTypes2 (Map.insert ty (init (fromJust pos)) context) types (newi+1)
ttargs = getTypeArgs tt
newtti = i + length ttargs - 1
fstArg = if (all isJust lst1) then -- i..newi
(Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst1
else [Nothing]
sndArg = if (all isJust lst2) then
(Just $ mkApp (getName tt) [mkMeta j | j <- [1..(length ttargs)]]) : lst2
else [Nothing]
in
(fstArg,sndArg)
-}