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 " 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) -}