XSaiga 1.5.0.0 → 1.6.0.0
raw patch · 10 files changed
+1193/−1053 lines, 10 filesdep +bifunctorsdep +bytestringdep +mtldep −XSaigadep ~cgi
Dependencies added: bifunctors, bytestring, mtl
Dependencies removed: XSaiga
Dependency ranges changed: cgi
Files
- Main.hs +2/−127
- XSaiga.cabal +12/−12
- XSaiga/AGParser2.hs +151/−384
- XSaiga/CGI.hs +154/−0
- XSaiga/Getts.hs +130/−200
- XSaiga/Interactive.hs +87/−61
- XSaiga/LocalData.hs +5/−0
- XSaiga/ShowText.hs +25/−0
- XSaiga/SolarmanTriplestore.hs +414/−206
- XSaiga/TypeAg2.hs +213/−63
Main.hs view
@@ -1,128 +1,3 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DoAndIfThenElse #-}--module Main where-import qualified XSaiga.SolarmanTriplestore as App-import Text.PrettyPrint.HughesPJ-import Network.CGI--cgiMain :: CGI CGIResult-cgiMain = do- (Just input) <- getInput "query"- out <- liftIO $ interpret' input- output out---main :: IO ()-main = runCGI (handleErrors cgiMain)--interpret :: String -> String-interpret "ask them to be quiet" - = "Hello. Quiet please. My "- ++ "masters are going to talk. Quiet please."--interpret "introduce yourself solar man" - = "Hello. Hello. My name is Solar man."- ++ " Thank you for coming to my party."- ++ " I am very pleased to meet you."--interpret "what can i say" - = "You can say. hello there. what is your name."- ++ " you can ask me about the moons and the planets."- ++ " such as, who discovered a moon."- ++ " who discovered two moons."- ++ " which moons were discovered by kuiper."- ++ " who discovered phobos."- ++ " which planet is orbited by miranda."- ++ " how many moons orbit saturn."- ++ " and other similar questions."- ++ " who are you. where do you live."- ++ " tell me a joke. who made you." - ++ " who do you know. what is your favorite band."- ++ " who is the vice president at the university of windsor." - ++ " who is the president at the university of windsor." - ++ " who is the dean of science at the university of windsor."--interpret "hi" = "Hi there. My name is solar man"-interpret "hello" = "hello. My name is solar man."-interpret "hello there" = "Good day to you"-interpret "hello solar man" = "hello. How are you"-interpret "goodbye" = "goodbye. See you in the stars."-interpret "goodbye solar man" = interpret "goodbye"-interpret "fine thanks" = "Good, so am I. Except for a bit of back ache"-interpret "thanks" = "you are welcome"-interpret "thanks solar man" = "you are most welcome"-interpret "yes please" = "yes please? What did you want? My memory is getting bad"-interpret "what is your name" = "My name is solar man."-interpret "who are you" - = "My name is solar man. I know about the planets and the"- ++ " moons, and the people who discovered them"-interpret "where do you live" - = "I live in a dark cold computer. "- ++ "The center of my universe is Lambton Tower, at the University of Windsor."-interpret "what do you know" - = "Not much I am afraid. I am just beginning to learn. I know a bit about "- ++ "the planets, the moons, and the people who discovered them. "- ++ "My master will teach me some more when he gets another grant "-interpret "how old are you"- = "older than you think. And much older than my friends Judy and Monty."-interpret "who made you" - = "I. B. M. and Opera Software made my ears and vocal chords. William Ma connected my "- ++ "ears to my brain, and Doctor Frost, master of the universe, made "- ++ "my brain"--interpret "what is your favorite band"- = "Pink Floyd. I love, dark side of the moon"--interpret "who is the vice president at the university of windsor" - = "Leo Groarke"--interpret "who is the president at the university of windsor" - = "Doctor Alan Wildeman."--interpret "who is the dean of science at the university of windsor"- = "Doctor Marlys Koschinsky"--interpret "tell me a poem" = "do not know any poems. But my friend, Judy, does"---interpret "know any poems" = "no but my friend, Judy does;"---interpret "tell me a joke" - = "did you hear about the Computer Scientist who thought his computer"- ++ "was a car. He had a hard drive home every day"--interpret "know any jokes" - = "just one. My friend Monty knows one too."--interpret "who is judy" = "She is my friend. She knows about poetry"--interpret "who is monty" - = "Monty is my friend. He is a student"- ++ " at the university of Windsor."-interpret "can I talk to judy" - ="yes. here she is"- ++ "<goto>http://cs.uwindsor.ca/~speechweb/p_d_speechweb/judy/judy.xml</goto>"--interpret "can I talk to monty" - ="yes. here he is"- ++ "<goto>http://cs.uwindsor.ca/~speechweb/p_d_speechweb/monty/monty.xml</goto>"--interpret "can I talk to solar man" - ="yes. here he is"- ++ "<goto>http://cs.uwindsor.ca/~speechweb/p_d_speechweb/solarman/solarman.xml</goto>"--interpret "who do you know" = "i only know three people. Judy, Monty, and Solarman."--interpret _ = "BLANKVALNOTUSED"--interpret' input = do- let firstpass = interpret input- if firstpass == "BLANKVALNOTUSED" then do- output <- App.parse input- let formatted = render $ vcat $ output- if null formatted then return "Do not know that one yet, will work on it tonight" else return $ formatted- else return firstpass-+import qualified XSaiga.CGI as C +main = C.main
XSaiga.cabal view
@@ -2,10 +2,10 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: XSaiga -version: 1.5.0.0 +version: 1.6.0.0 synopsis: An implementation of a polynomial-time top-down parser suitable for NLP -- description: -homepage: http://hafiz.myweb.cs.uwindsor.ca/proHome.html +homepage: http://speechweb2.cs.uwindsor.ca/solarman4/demo_sparql.html license: BSD3 license-file: LICENSE author: Dr. Rahmatullah Hafiz, Dr. Richard Frost (rfrost@cogeco.ca), Shane Peelar, Paul Callaghan, and Eric Matthews @@ -26,22 +26,22 @@ to a semantic-web style RDF triplestore with approximately 3,000 facts about the solar system has been built as an executable specification of an attribute grammar. Solarman is included in this archive. Solarman computes answers to queries using an event-based denotational semantics which is based on Montague and Davidsonian semantics. - A web site [4] has been created so that readers can enter queries and find out more about Solarman. + A web site [3] has been created so that readers can enter queries and find out more about Solarman. . \[1] <http://cs.uwindsor.ca/~richard/PUBLICATIONS/PADL_08.pdf> . \[2] <http://cs.uwindsor.ca/~richard/PUBLICATIONS/PADL_10.pdf> . - \[3] <http://cs.uwindsor.ca/~richard/PUBLICATIONS/ESWC_DEMO.pdf> - . - \[4] <http://speechweb2.cs.uwindsor.ca/solarman/demo_sparql.html> + \[3] <http://speechweb2.cs.uwindsor.ca/solarman4/demo_sparql.html> Library - build-depends: base >=4.6 && < 5, pretty, hsparql >=0.2, rdf4h, text, containers, network - exposed-modules: XSaiga.Getts, XSaiga.AGParser2, XSaiga.TypeAg2, XSaiga.SolarmanTriplestore, XSaiga.Interactive, XSaiga.LocalData + build-depends: base >=4.6 && < 5, pretty, hsparql >=0.2, rdf4h, text, containers, network, bifunctors, mtl, bytestring, cgi + exposed-modules: XSaiga.Getts, XSaiga.AGParser2, XSaiga.TypeAg2, XSaiga.SolarmanTriplestore, XSaiga.Interactive, XSaiga.LocalData, XSaiga.CGI + other-modules: XSaiga.ShowText + extensions: OverloadedStrings,FlexibleInstances,NoMonomorphismRestriction Executable Solarman - main-is: Main.hs - --other-modules: SolarmanTriplestore - build-depends: base >=4.6 && < 5, containers >=0.5, pretty >=1.1, cgi >=3001.1, rdf4h >=1.2, hsparql >=0.2, text >=0.11, network, XSaiga >= 1.5.0.0 - extensions: DoAndIfThenElse,FlexibleInstances,NoMonomorphismRestriction + main-is:Main.hs + other-modules:XSaiga.AGParser2 XSaiga.Getts XSaiga.LocalData XSaiga.SolarmanTriplestore XSaiga.TypeAg2 XSaiga.ShowText XSaiga.CGI + build-depends: base >=4.6 && < 5, containers >=0.5, pretty >=1.1, cgi, rdf4h >=1.2, hsparql >=0.2, text >=0.11, network, bytestring, bifunctors, mtl + extensions: DoAndIfThenElse,FlexibleInstances,NoMonomorphismRestriction,OverloadedStrings
XSaiga/AGParser2.hs view
@@ -1,95 +1,66 @@ {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+ module XSaiga.AGParser2 where import Prelude hiding ((*>))-import Text.PrettyPrint.HughesPJ as PPH hiding (empty) -- ((PPH.<+>), vcat, text, render,($$),nest,Doc) import Data.List+import qualified Data.Text as T import XSaiga.TypeAg2 import Control.Monad import Control.Applicative hiding ((<|>), (*>))-+import Control.Monad.State.Lazy ---- ************************************ ----------------------- -type Instance = IRec data SorI = S | I |NILL deriving (Eq,Ord,Show, Enum) -- Synthesized or inherited or NILL --type IRec = (SorI, Id) +type Instance = (SorI, Id) -- uniquely determines synthesized or inherited attribute for an NT data Useless = OF|ISEQUALTO deriving (Show, Eq) -- for decorating the semantic rules-- -data SRule_ = NT {iden :: Id, par :: NTType} | Rule {par' :: SeqType} | DRule {par'' :: SRule_ } +type Atts = [AttValue] -- [(AttType, AttValue)] -type NTType = Id -> InsAttVals -> M Foo-type SeqType = Id -> InsAttVals -> [SemRule] -> Result -> M Foo-type AltType = NTType-type SemRule = (Instance,(InsAttVals, Id) -> InsAttVals)--------------data Tree a = Leaf (a,Instance)- | Branch [Tree a] - | SubNode ((NodeName, Instance), (Start1,End))- deriving (Eq)+type InsAttVals = [(Instance,Atts)] +type Start = ((Int,InsAttVals), [T.Text]) -type NodeName = MemoL+type Context = ([MemoL],[(Int,[(MemoL, Int)])])++--These are the same?? type Start1 = (Int, InsAttVals)-type Start = ((Int,InsAttVals), [String]) type End = (Int, InsAttVals)-type Atts = [AttValue] -- [(AttType, AttValue)]-type InsAttVals = [(Instance, Atts)] +data Tree = Leaf (MemoL,Instance)+ | SubNode ((MemoL, Instance), (Start1,End))+ | Branch [Tree] + deriving (Eq) -type Mtable = [(MemoL- ,[(Start1,(Context,Result))]- )- ] -type Result = [((Start1, End),[Tree MemoL])]+type Result = [((Start1, End),[Tree])] -type State = Mtable-type Context = ([MemoL],[(Int,[(MemoL, Int)])])+--Also called an "MTable" or "State" originally+type MemoTable = [(MemoL ,[(Start1,(Context,Result))])] -type M a = Start -> Context -> StateM a-type Seq a = Id -> InsAttVals -> [SemRule] -> Result -> Start -> Context -> StateM a-type Foo = (Context, Result)+type M = Start -> Context -> State MemoTable (Context, Result) --- ============================-newtype StateM t = State { unState :: State -> (t,State) }+type NTType = Id -> InsAttVals -> M -instance Functor StateM where- fmap = liftM+type SemRule = (Instance, (InsAttVals, Id) -> InsAttVals) -instance Applicative StateM where- pure = return- (<*>) = ap -- defined in Control.Monad+type SeqType = Id -> InsAttVals -> [SemRule] -> Result -> M -instance Monad StateM where- -- defines state propagation- State m >>= k - = State (\s -> let (a,y) = m s in unState (k a) y)- return k = State (\s -> (k,s))+------------ - -- extracts the state from the monad-get :: StateM State-get = State (\s -> (s,s))-put :: State -> StateM ()-put s = State (\_ -> ((),s))-modify :: (State -> State) -> StateM ()-modify sf = State (\s -> ((), sf s))---- =============================- --------------- ******************************************** --------------------------- -(<|>) :: AltType -> AltType -> AltType+(<|>) :: NTType -> NTType -> NTType (p <|> q) idx inhx ((i,a),inp) c = do (l1,m) <- p idx inhx ((i,[]),inp) c (l2,n) <- q idx inhx ((i,[]),inp) c@@ -170,189 +141,140 @@ empty_cuts = ([],[]) -empty :: [(Instance, Atts)] -> M Foo-empty atts (x,inp) l = return (empty_cuts,[((x,(fst x,atts)), [Leaf (Emp, (NILL,O0))])])--term :: String -> Instance -> [(Instance, Atts)] -> [(Instance, Atts)] -> M Foo-term c id atts iatts ((r,a),dInp) l - |r - 1 == length dInp = return (empty_cuts,[])- |dInp!!(r - 1) == c = return (empty_cuts,[(((r,[]),(r+1,atts)),[Leaf (ALeaf c, id)])])- |otherwise = return (empty_cuts,[]) +empty :: InsAttVals -> M+empty atts (x,_) l = return (empty_cuts,[((x,(fst x,atts)), [Leaf (Emp, (NILL,O0))])]) memoize name f id downAtts ((inp,dAtts),dInput) context = do s <- get case (lookupT name inp (snd context) s) of - Just lRes -> do let lookUpRes = addNode name (S, id) (inp,downAtts) (snd1 lRes) - return (fst1 lRes,lookUpRes)+ Just lRes -> do let lookUpRes = addNode name (S, id) (inp,downAtts) (snd lRes) + return (fst lRes,lookUpRes) Nothing | funccount (snd context) inp name > (length dInput) - inp + 1 -> return (([name],[]),[])- | otherwise -> do let iC = ([],(incContext (snd context) name inp))+ | otherwise -> do let iC = ([],(addNT name inp $ snd context)) (l,newRes) <- f id downAtts ((inp,dAtts),dInput) iC - -- let ((l,newRes),s1) = unState (f id downAtts (inp,dAtts) iC) s- let l1 = makeContext (fst l) (findContext (snd context) inp)+ -- let ((l,newRes),s1) = unMemoTable (f id downAtts (inp,dAtts) iC) s+ let l1 = makeContext (fst l) (findContext inp (snd context)) s1 <- get- let udtTab = udt (l1,newRes) s1 name (inp,downAtts) + let udtTab = udt (l1,newRes) name (inp,downAtts) s1 let newFoundRes = addNode name (S, id) (inp,downAtts) newRes put udtTab return ( l1 ,newFoundRes) - ---findContext [] inp = []-findContext ((st,rest):sr) inp| st == inp = [(st,rest)]- | otherwise = findContext sr inp- - - --funccount [] inp name = 0-funccount ((key,funcp):rest) inp name | key == inp = findf funcp - | otherwise = funccount rest inp name+findWithFst key = find ((== key) . fst) - where- findf [] = 0- findf ((tk,fc):rx) | tk == name = fc - | otherwise = findf rx - - -fst1 [(a,b)] = a-snd1 [(a,b)] = b +filterWithFst key = filter ((== key) . fst) -makeContext [] [(st,((n,c):ncs))] = ([],[])-makeContext (r:rs) [] = ((r:rs),[])-makeContext [] [] = ([],[])-makeContext (r:rs) [(st,((n,c):ncs))] = ((r:rs), [(st,makeContext_ (r:rs) ((n,c):ncs))])+replaceSnd key def f list+ = before ++ replaceFirst replacePoint+ where+ (before, replacePoint) = break ((== key) . fst) list+ replaceFirst [] = [(key, def)]+ replaceFirst ((a, b):nc) = (a, f b):nc -makeContext_ [] ((n,c):ncs) = []-makeContext_ (r:rs) ((n,c):ncs) = makeContext__ r ((n,c):ncs) ++ makeContext_ rs ((n,c):ncs)+--TODO: Should this return all matches? why return a list?+findContext inp = maybe [] (:[]) . findWithFst inp -makeContext__ r [] = []-makeContext__ r ((n,c):ncs) | r == n = (n,c): makeContext__ r ncs- | otherwise = makeContext__ r ncs+funccount list inp name = maybe 0 id $ do+ (_, funcp) <- findWithFst inp list+ (_, fc) <- findWithFst name funcp+ return fc +makeContext [] _ = empty_cuts+makeContext rs [] = (rs, [])+makeContext rs [(st,ncs)] = (rs, [(st, concatMap (flip filterWithFst ncs) rs)]) -incContext [] name inp = [(inp,[(name,1)])]-incContext ((st,((n,c):nc)):sn) name inp - | st == inp = ((st, (addNT ((n,c):nc)) name inp ) :sn) - | otherwise = ((st,((n,c):nc)): incContext sn name inp )- +--Merged with incContext+addNT name inp = replaceSnd inp [(name,1)] $ replaceSnd name 1 (+1) -addNT [] name inp = [(name,1)]-addNT ((n,c):nc) name inp | n == name = ((n,(c + 1)):nc)- | otherwise = ((n,c):addNT nc name inp)- +addNode name id (s',dA) [] = [] -addNode name id (s',dA) [] - = [] -addNode name id (s',dA) oldRes -- ((((s,newIh),(e,atts)),t):rs) - = let res = packAmb oldRes+addNode name id (s',dA) oldResult -- ((((s,newIh),(e,atts)),t):rs) + = let res = packAmb oldResult newSh x = [ ((sOri, snd id),attVal)| ((sOri, idOld),attVal)<- x] in [(((s,newIh),(e, newSh atts)),[SubNode ((name, id),((s,nub dA),(e, newSh atts)))]) - | (((s,newIh),(e,atts)),t) <- oldRes]-mapName i [] = []-mapName i ((i',r):rest) = (i,r): mapName i rest---packAmb [] = []-packAmb [((s1,e1),t1)] = [((s1,e1),t1)]-packAmb [((s1,e1),t1),((s2,e2),t2)] | isEq (s1,e1) (s2,e2) = [((s2,(fst e2, groupAtts (snd e1 ++ snd e2))), t1++t2)]- | otherwise = [((s1,e1),t1),((s2,e2),t2)]--packAmb (((s1,e1),t1):((s2,e2),t2):xs) | isEq (s1,e1) (s2,e2) = packAmb (((s2,(fst e2, groupAtts (snd e1 ++ snd e2))), t1++t2):xs)- | otherwise = ((s1,e1),t1):packAmb (((s2,e2),t2):xs)--isEq ((s1,b1),(e1,y1)) ((s2,b2),(e2,y2))- | s1 == s2 && e1 == e2 = True- | otherwise = False- --lookupT name inp context mTable - | lookupT1 name inp context mTable == [] = Nothing- | otherwise = Just (lookupT1 name inp context mTable) ---lookupT1 name inp context mTable | res_in_table == [] = [] - | otherwise = checkUsability inp context (lookupRes (res_in_table !! 0) inp)- - where - res_in_table = [pairs|(n,pairs) <- mTable,n == name]---lookupRes [] inp = []-lookupRes (((i,dA),res):rs) inp | i == inp = [res]- | otherwise = lookupRes rs inp ---checkUsability inp context [] = []-checkUsability inp context [((re,sc),res)] | re == [] = [((re,sc),res)]- | otherwise = checkUsability_ (findInp inp context) (findInp inp sc) [((re,sc),res)]---findInp inp [] = []-findInp inp ((s,c):sc) | s == inp = c- | otherwise = findInp inp sc-- -checkUsability_ [] [] [(sc,res)] = [(sc,res)]-checkUsability_ ((n,cs):ccs) [] [(sc,res)] = [(sc,res)] -- if lc at j is empty then re-use-checkUsability_ [] ((n1,cs1):scs) [(sc,res)] = [] -- if cc at j is empty then don't re-use-checkUsability_ ((n,cs):ccs) ((n1,cs1):scs) [(sc,res)] - | and $ condCheck ((n,cs):ccs) ((n1,cs1):scs) = [(sc,res)]- | otherwise = []- - --condCheck ((n,cs):ccs) [(n1,cs1)] = [condCheck_ ((n,cs):ccs) (n1,cs1)]-condCheck ((n,cs):ccs) ((n1,cs1):scs) = condCheck_ ((n,cs):ccs) (n1,cs1) : condCheck ((n,cs):ccs) scs+ | (((s,newIh),(e,atts)),t) <- oldResult] -condCheck_ [] (n1,cs1) = False-condCheck_ ((n,cs):ccs) (n1,cs1) - | n1 == n && cs >= cs1 = True- | n1 == n && cs < cs1 = False- | otherwise = condCheck_ ccs (n1,cs1)- +packAmb [] = []+packAmb [x] = [x]+packAmb (x:y:ys) = if isEq x y then packAmb $ (packer x y):ys else x:packAmb (y:ys)+ where+ packer ((s1, e1), t1) ((s2, e2), t2) = ((s2, (fst e2, groupAtts (snd e1 ++ snd e2))), t1 ++ t2)+ isEq (((s1,_),(e1,_)),_) (((s2,_),(e2,_)),_) = s1 == s2 && e1 == e2 +lookupT name inp context mTable+ | null res_in_table = Nothing + | otherwise = checkUsability inp context (lookupRes inp (res_in_table !! 0)) + where + res_in_table = map snd $ filterWithFst name mTable -udt :: (Context, Result) -> State -> MemoL -> Start1 -> State-udt res mTable name (inp,dAtts) - = update mTable name (inp,dAtts) res - -update [] name (inp,dAtts) res = [(name,[((inp,dAtts), res)])]-update ((key, pairs):rest) name (inp,dAtts) res - | key == name = (key,my_merge (inp,dAtts) res pairs):rest- | otherwise = ((key, pairs): update rest name (inp,dAtts) res )+lookupRes inp res_in_table = find (\((i,_), _) -> i == inp) res_in_table >>= return . snd +checkUsability inp context res = res >>= (\x@((re,sc),res) -> if null re then Just x else checkUsability_ (findInp inp context) (findInp inp sc) x)+ where+ --Want Nothing to be the case if list is empty or the inp could not be found+ findInp inp sc = findWithFst inp sc >>= (empty . snd)+ empty [] = Nothing+ empty x = Just x+ checkUsability_ _ Nothing scres = Just scres -- if lc at j is empty then re-use+ checkUsability_ Nothing _ _ = Nothing -- if cc at j is empty then don't re-use+ checkUsability_ (Just ccs) (Just scs) scres | and $ condCheck ccs scs = Just scres+ | otherwise = Nothing+ condCheck ccs scs = map (condCheck_ ccs) scs+ condCheck_ ccs (n1, cs1) = maybe False (\(_, cs) -> cs >= cs1) $ findWithFst n1 ccs -my_merge (inp,dAtts) res [] = [((inp,nub dAtts), res)]-my_merge (inp,dAtts) res (((i,dA), es):rest) - |inp == i = ((inp,nub dAtts{-nub (dA ++ dAtts)-}), res):rest - |otherwise = ((i,dA), es): my_merge (inp,dAtts) res rest +{-nub (dA ++ dAtts)-}+--udt == "update table"?+udt :: (Context, Result) -> MemoL -> Start1 -> MemoTable -> MemoTable+udt res name (inp, dAtts) = replaceSnd name [((inp,dAtts),res)] (my_merge (inp,nub dAtts) res) +replaceSndG key def list+ = before ++ replaceFirst replacePoint+ where+ (before, replacePoint) = break ((== key) . fst . fst) list+ replaceFirst [] = [def]+ replaceFirst ((a, b):nc) = def:nc -pickResult ((c,r),t) = r+my_merge (inp,ndAtts) res = replaceSndG inp ((inp,ndAtts),res) +{-+my_merge (inp,ndAtts) res [] = [((inp,ndAtts), res)]+my_merge (inp,ndAtts) res (((i,dA), es):rest) + |inp == i = ((inp,ndAtts), res):rest + |otherwise = ((i,dA), es): my_merge (inp,ndAtts) res rest +-} --------------- ************************* semantics of ATTRIBUTE GRAMMAR ************************* -------------------------- -terminal syn semRules id inhAtts ((i,a),inp) c - = do syn (S,id) [((S,id),semRules)] inhAtts ((i,[]),inp) c+-- atts iatts Context was "l"+terminal :: T.Text -> Atts -> Id -> InsAttVals -> M+terminal str semRules id _ ((i,a),inp) c + = (term str) ((i,[]),inp) c+ where+ inst = (S, id)+ atts = [(inst,semRules)]+ term :: T.Text -> M+ term str ((r,a),dInp) _ + |r - 1 == length dInp = return (empty_cuts,[])+ |dInp!!(r - 1) == str = return (empty_cuts,[(((r,[]),(r+1,atts)),[Leaf (ALeaf str, inst)])])+ |otherwise = return (empty_cuts,[]) + nt :: NTType -> Id -> SeqType nt fx idx id inhAtts semRules altFromSibs - = let groupRule'' id rules = [rule | (ud,rule) <- rules, id == ud]- ownInAtts = mapInherited (groupRule'' (I, idx) semRules) altFromSibs inhAtts id - in fx idx ownInAtts + = let groupRule'' inst = map snd $ filter ((inst ==) . fst) semRules+ ownInheritedAtts = mapInherited (groupRule'' (I, idx)) altFromSibs inhAtts id + in fx idx ownInheritedAtts -parser :: SeqType -> [SemRule] -> Id -> InsAttVals -> M Foo+parser :: SeqType -> [SemRule] -> Id -> InsAttVals -> M parser synRule semRules id inhAtts i c = do s <- get let ((e,altFromSibs),d) = let sRule = groupRule'' (S, LHS) semRules- ((l,newRes),st) = unState ((synRule id inhAtts semRules altFromSibs) i c) s+ ((l,newRes),st) = runState ((synRule id inhAtts semRules altFromSibs) i c) s groupRule'' id rules = [rule | (ud,rule) <- rules, id == ud] in ((l, mapSynthesize sRule newRes inhAtts id),st) put d@@ -371,47 +293,27 @@ |(((st,inAtts), (en,synAtts)),[t]) <- res] --- mapSem' [] _ _ = []-mapInherited sems res [] id - = let appSems [] vals = []- appSems (r:rules) vals = r (vals, id) ++ appSems rules vals - in concat [appSems sems (findAtts t) | (((st,inAtts), (en,synAtts)),[t]) <- res]+applySemantics vals id = concatMap (\rule -> rule (vals, id)) ++mapInherited sems res [] id + = concat [applySemantics (findAtts t) id sems | (((st,inAtts), (en,synAtts)),[t]) <- res] mapInherited sems [] downAtts id - = let appSems [] vals = []- appSems (r:rules) vals = r (vals, id) ++ appSems rules vals - in appSems sems downAtts -- concat ( map (appSems id sems) (group downAtts))+ = applySemantics downAtts id sems -- concat ( map (appSems id sems) (group downAtts)) mapInherited sems res downAtts id - = let appSems [] vals = []- appSems (r:rules) vals = r (vals, id) ++ appSems rules vals - in concat [appSems sems ((groupAtts downAtts) ++ synAtts ++ (findAtts t)) + = concat [applySemantics ((groupAtts downAtts) ++ synAtts ++ (findAtts t)) id sems | (((st,inAtts), (en,synAtts)),[t]) <- res] ----------------------------------------gMax [] = []-gMax [(a,[b])] = [(a,[b])]--gMax [(a,[b]),(a1,[b1])] | getAVAL b >= getAVAL b1 = [(a,[b])]- | otherwise = [(a1,[b1])]--gMax ((a,[b]):(a1,[b1]):rest) | getAVAL b >= getAVAL b1 = gMax ((a,[b]):rest)- | otherwise = gMax ((a1,[b1]):rest)-- groupAtts [] = [] groupAtts [(a,b)] = [(a,b)]-groupAtts [(a,b),(a1,b1)] = [(a,b++b1)]-groupAtts ((a,b):(a1,b1):rest) = (a,b++b1): groupAtts rest +groupAtts [(a,b),(_,b1)] = [(a,b++b1)]+groupAtts ((a,b):(_,b1):rest) = (a,b++b1): groupAtts rest ---------------------------------------findAtts (Branch (t:ts)) - = findAtts t ++ findAtts (Branch ts)-findAtts (SubNode ((n,i),((s,v'),(e,v)))) = v' ++ v-findAtts (Leaf (a,id)) = [] -findAtts (Branch []) = []--addAtts x y = x ++ y+findAtts (Branch ts) = concatMap findAtts ts+findAtts (SubNode (_,((_,v'),(_,v)))) = v' ++ v+findAtts (Leaf _) = [] -------------------------------------------------------- @@ -419,6 +321,7 @@ rule_i = rule I rule_s = rule S +--TODO: more undefined... rule s_or_i typ oF pID isEq userFun listOfExp = let formAtts id spec = (id, (forNode id . spec)) forNode id atts = [(id, atts)]@@ -432,14 +335,14 @@ synthesized = valOf S inherited = valOf I -valOf :: SorI -> (a -> AttValue) -> Useless -> Id -> [(Instance, Atts)] -> Id -> [AttValue]+valOf :: SorI -> (a -> AttValue) -> Useless -> Id -> InsAttVals -> Id -> Atts valOf ud typ o_f x ivs x' | x == LHS = getAttVals (ud , x') ivs typ | otherwise = getAttVals (ud , x ) ivs typ -getAttVals :: Instance -> [(Instance, Atts)] -> (a -> AttValue) -> [AttValue]+--TODO: Whoa!!!! not cool! +getAttVals :: Instance -> InsAttVals -> (a -> AttValue) -> Atts getAttVals x ((i,v):ivs) typ =- let typeCheck typ t = if (typ undefined) == t then True else False- getAttVals_ typ (t:tvs) = if (typ undefined) == t then (t :getAttVals_ typ tvs)+ let getAttVals_ typ (t:tvs) = if (typ undefined) == t then (t :getAttVals_ typ tvs) else getAttVals_ typ tvs getAttVals_ typ [] = [] -- ErrorVal {-- 100 --} "ERROR id found but no value" in @@ -450,11 +353,11 @@ -------- ************************************** ------------ ------------------------- user functions ------------------ -apply :: [(Instance,Atts)] -> Id -> ([(Instance,Atts)] -> Id -> AttValue) -> Int+apply :: InsAttVals -> Id -> (InsAttVals -> Id -> AttValue) -> Int apply y i x = getAVAL (x y i) apply_ y i x = getB_OP (x y i) -apply__ :: [(Instance,Atts)] -> Id -> ([(Instance,Atts)] -> Id -> AttValue) -> DisplayTree+apply__ :: InsAttVals -> Id -> (InsAttVals -> Id -> AttValue) -> DisplayTree apply__ y i x = getRVAL (x y i) applyMax y i x = getAVAL (foldr (getMax) (MaxVal 0) (x y i))@@ -529,11 +432,11 @@ num = memoize Num (- terminal (term "1") [MaxVal 1] <|> - terminal (term "2") [MaxVal 2] <|>- terminal (term "3") [MaxVal 3] <|> - terminal (term "4") [MaxVal 4] <|> - terminal (term "5") [MaxVal 5] + terminal "1" [MaxVal 1] <|> + terminal "2" [MaxVal 2] <|>+ terminal "3" [MaxVal 3] <|> + terminal "4" [MaxVal 4] <|> + terminal "5" [MaxVal 5] ) ------------------------------------------------ Arithmetic Expression ------------------------------------------------ @@ -562,156 +465,20 @@ op = memoize Op (- terminal (term "+") [B_OP (+)] <|> - terminal (term "-") [B_OP (-)] <|> - terminal (term "*") [B_OP (*)] <|> - terminal (term "/") [B_OP (div)] + terminal "+" [B_OP (+)] <|> + terminal "-" [B_OP (-)] <|> + terminal "*" [B_OP (*)] <|> + terminal "/" [B_OP (div)] )-------------------------------------------------- Arithmetic Expression ------------------------------------------------------------- PrettyPrint -------------------------po :: (PP' a) => (String -> IO ()) -> a -> IO ()-po act x = do- stuff <- pp' x- act $ render80 stuff- -render80 = renderStyle (style{lineLength = 80})---class PP' a where- pp' :: a -> IO Doc--instance PP' Doc where- pp' c = return c--instance PP' Char where- pp' c = return $ text $ show c-instance PP' AttValue where- pp' (VAL i) = showio (VAL i) >>= return . text- pp' (B_OP i)= showio (B_OP i) >>= return .text- - -instance PP' Int where- pp' i = return $ text $ show i- -instance PP' Id where- pp' i = return $ text $ show i --instance PP' a => PP' (Maybe a) where- pp' Nothing = return $ text "Nothing"- pp' (Just x) = pp' x >>= (\y -> return $ parens $ text "Just" PPH.<+> y)--instance (PP' a, PP' b) => PP' (a,b) where- -- pp' (a,b) = parens $ pp' a PPH.<+> text "->" PPH.<+> pp' b- pp' (a,b) = pp' a >>= \z -> (pp' b >>= (\y -> return $ z PPH.<+> text "->" PPH.<+> y))-instance PP' a => PP' [a] where- pp' [] = return $ brackets $ text ""- pp' (x:xs) = liftM sep $ (liftM2 (:)) (pp' x) (sequence [ pp' y | y <- xs ])- -instance (Show t) => PP' (Tree t) where- -- pp' Empty = text "{_}"- pp' (Leaf x) = return $ text "Leaf" PPH.<+> text (show x)- pp' (Branch ts) = liftM2 (PPH.<+>) (return $ text "Branch") (liftM brackets $ liftM sep $ liftM (punctuate comma) $ sequence $ map pp' ts)- --pp' (SubNode (x,(s,e))) = return $ text "SubNode" PPH.<+> text (show x) PPH.<+> text (show (s,e)) - -- PPH.<+> pp' ts--{-TODO:-format :: Mtable -> Doc-format t- = vcat- [ text (show s) - $$ - nest 3 (pp' [text "START at:" PPH.<+> pp' i PPH.<+> text "; Inherited atts:" PPH.<+> vcat [vcat [text (showID id0) PPH.<+> vcat [text (show ty0v0) |ty0v0 <-val0]|(id0,val0)<-inAt1]] PPH.<+>- text "" $$ vcat [{- text "Inherited Atts. -" - - $$ - vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-(nub inAtt2)]] - - $$-} nest 3- ( text "END at:" PPH.<+> pp' end - $$ text "Synthesized Atts. -"- - $$ vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]] - - $$ text "Packed Tree -"- - $$ pp' ts)- |(((st,inAtt2),(end,synAtts)), ts)<-rs] - - | ((i,inAt1),((cs,ct),rs)) <- sr ])- - - | (s,sr) <- t ]--}- --showID (x,y) = show y -- only the instance------ ** printing ony own atts ** ----{-TODO:-formatAtts :: MemoL -> Mtable -> Doc-formatAtts key t- = vcat- [ text (show s) - $$ - nest 3 (pp' [text "START at:" PPH.<+> pp' i PPH.<+> text "; Inherited atts:" PPH.<+> vcat [vcat [text (showID id0) PPH.<+> vcat [text (show ty0v0) |ty0v0 <-val0]|(id0,val0)<-inAt1]] PPH.<+>- text "" $$ vcat [nest 3- ( text "END at:" PPH.<+> pp' end - $$ text "Synthesized Atts. -"- - $$ vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]] - - -- $$ text "Packed Tree -"- - {- $$ pp' ts -} )- |(((st,inAtt2),(end,synAtts)), ts)<-rs] - - | ((i,inAt1),((cs,ct),rs)) <- sr ])- - - | (s,sr) <- t, s == key ]--} -formatAttsFinalAlt :: MemoL -> Int -> State -> IO [Doc]-formatAttsFinalAlt key e t = - --return [pp' [vcat [(vcat [vcat [vcat [text (show ty1v1) |ty1v1<-val1]- sequence [(sequence [liftM vcat $ sequence [(liftM vcat $ sequence [liftM vcat $ sequence [liftM vcat $ sequence [liftM text (showio ty1v1) | ty1v1<-val1]- |(id1,val1)<-synAtts]] )- |(((st,inAtt2),(end,synAtts)), ts)<-rs, end == e] - | ((i,inAt1),((cs,ct),rs)) <- sr ]) >>= pp' | (s,sr) <- t, s == key ]--{-formatAttsFinal key t = - [(pp' [vcat [(vcat [vcat [vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]] )|(((st,inAtt2),(end,synAtts)), ts)<-rs] - - | ((i,inAt1),((cs,ct),rs)) <- sr ]) | (s,sr) <- t, s == key ]-}- --- *************** for printing the fist element of the return pair ***************-{-TODO:-formatForFst ::Result -> Doc-formatForFst res = vcat - -- [text (show ty0v0) |ty0v0 <-val0]|(id0,val0)<-inAt1]] PPH.PPH.<+> text "" $$ vcat - - [ text "START at:" PPH.<+> pp' st - - {-- $$ text "Inherited Atts. -" - $$ vcat [vcat [text (showID id1) PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-inAtt2]] - -}- - PPH.<+> text "END at:" PPH.<+> pp' end - $$ nest 3 - (text "Synthesized Atts. of"- - PPH.<+> vcat [vcat [text (showID id1) PPH.<+> text "::" PPH.<+> vcat [text (show ty1v1) |ty1v1<-val1]|(id1,val1)<-synAtts]]- - $$ pp' ts)- |(((st,inAtt2),(end,synAtts)), ts)<-res] ----}--- *************** for printing the fist element of the return pair ***************+--The nastiest list comprehension I have ever seen in my life +--The unformatted parse tree ------------ PrettyPrint --------------------------+attsFinalAlt :: MemoL -> Int -> MemoTable -> [[[[Atts]]]]+attsFinalAlt key e t = [ [ [ map snd synAtts | ((_,(end,synAtts)), _)<-rs, end == e] | (_,(_,rs)) <- sr ] | (s,sr) <- t, s == key ]+ +--The unformatted flattened parse trees+formatAttsFinalAlt :: MemoL -> Int -> MemoTable -> Atts+formatAttsFinalAlt key e t = concat $ concat $ concat $ concat $ attsFinalAlt key e t +
+ XSaiga/CGI.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE OverloadedStrings #-}++module XSaiga.CGI where+import qualified XSaiga.SolarmanTriplestore as App+import Network.CGI+import qualified Data.List as List+import Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy as BL+import Data.Text.Encoding as E+--import qualified XSaiga.LocalData as Local+import qualified XSaiga.Getts as Getts+import qualified XSaiga.TypeAg2 as TypeAg2++--change between remoteData and localData+--dataStore = Local.localData+dataStore = remoteData -- selects database++endpoint_uri = "http://speechweb2.cs.uwindsor.ca/sparql"+namespace_uri = T.pack "http://solarman.richard.myweb.cs.uwindsor.ca#"+remoteData = Getts.SPARQL endpoint_uri namespace_uri++cgiMain :: CGI CGIResult+cgiMain = do+ (Just input) <- getInputFPS "query"+ out <- liftIO $ interpret' $ E.decodeUtf8 $ BL.toStrict input+ setHeader "Content-type" "text/plain; charset=utf-8"+ outputFPS $ BL.fromStrict $ E.encodeUtf8 $ out+++main :: IO ()+main = runCGI (handleErrors cgiMain)++interpret "ask them to be quiet" + = "Hello. Quiet please. My "+ `T.append` "masters are going to talk. Quiet please."++interpret "introduce yourself solar man" + = "Hello. Hello. My name is Solar man."+ `T.append` " Thank you for coming to my party."+ `T.append` " I am very pleased to meet you."++interpret "what can i say" + = "You can say. hello there. what is your name."+ `T.append` " you can ask me about the moons and the planets."+ `T.append` " such as, who discovered a moon."+ `T.append` " who discovered two moons."+ `T.append` " which moons were discovered by kuiper."+ `T.append` " who discovered phobos."+ `T.append` " which planet is orbited by miranda."+ `T.append` " how many moons orbit saturn."+ `T.append` " and other similar questions."+ `T.append` " who are you. where do you live."+ `T.append` " tell me a joke. who made you." + `T.append` " who do you know. what is your favorite band."+ `T.append` " who is the vice president at the university of windsor." + `T.append` " who is the president at the university of windsor." + `T.append` " who is the dean of science at the university of windsor."++interpret "hi" = "Hi there. My name is solar man"+interpret "hello" = "hello. My name is solar man."+interpret "hello there" = "Good day to you"+interpret "hello solar man" = "hello. How are you"+interpret "goodbye" = "goodbye. See you in the stars."+interpret "goodbye solar man" = interpret "goodbye"+interpret "fine thanks" = "Good, so am I. Except for a bit of back ache"+interpret "thanks" = "you are welcome"+interpret "thanks solar man" = "you are most welcome"+interpret "yes please" = "yes please? What did you want? My memory is getting bad"+interpret "what is your name" = "My name is solar man."+interpret "who are you" + = "My name is solar man. I know about the planets and the"+ `T.append` " moons, and the people who discovered them"+interpret "where do you live" + = "I live in a dark cold computer. "+ `T.append` "The center of my universe is Lambton Tower, at the University of Windsor."+interpret "what do you know" + = "Not much I am afraid. I am just beginning to learn. I know a bit about "+ `T.append` "the planets, the moons, and the people who discovered them. "+ `T.append` "My master will teach me some more when he gets another grant "+interpret "how old are you"+ = "older than you think. And much older than my friends Judy and Monty."+interpret "who made you" + = "I. B. M. and Opera Software made my ears and vocal chords. William Ma connected my "+ `T.append` "ears to my brain, and Doctor Frost, master of the universe, made "+ `T.append` "my brain"++interpret "what is your favorite band"+ = "Pink Floyd. I love, dark side of the moon"++interpret "who is the vice president at the university of windsor" + = "Leo Groarke"++interpret "who is the president at the university of windsor" + = "Doctor Alan Wildeman."++interpret "who is the dean of science at the university of windsor"+ = "Doctor Marlys Koschinsky"++interpret "tell me a poem" = "do not know any poems. But my friend, Judy, does"+++interpret "know any poems" = "no but my friend, Judy does;"+++interpret "tell me a joke" + = "did you hear about the Computer Scientist who thought his computer"+ `T.append` "was a car. He had a hard drive home every day"++interpret "know any jokes" + = "just one. My friend Monty knows one too."++interpret "who is judy" = "She is my friend. She knows about poetry"++interpret "who is monty" + = "Monty is my friend. He is a student"+ `T.append` " at the university of Windsor."++{-+interpret "can I talk to judy" + ="yes. here she is"+ `T.append` "<goto>http://cs.uwindsor.ca/~speechweb/p_d_speechweb/judy/judy.xml</goto>"++interpret "can I talk to monty" + ="yes. here he is"+ `T.append` "<goto>http://cs.uwindsor.ca/~speechweb/p_d_speechweb/monty/monty.xml</goto>"++interpret "can I talk to solar man" + ="yes. here he is"+ `T.append` "<goto>http://cs.uwindsor.ca/~speechweb/p_d_speechweb/solarman/solarman.xml</goto>"++-}++interpret "who do you know" = "i only know three people. Judy, Monty, and Solarman."++interpret _ = "BLANKVALNOTUSED"++interpret'' = TypeAg2.getQUVAL . List.head . App.parse++--TODO: multiple interpretations! need to optimize these!+interpret' input = do+ let firstpass = interpret input+ if firstpass == "BLANKVALNOTUSED" then do+ let interpretations = List.map TypeAg2.getQUVAL $ App.parse input+ outs <- mapM evaluate interpretations --TODO: this is a code smell -- needs to be abstracted -- looks like SemFunc+ let formatted = T.concat $ List.intersperse " ; " outs+ if T.null formatted then return "Do not know that one yet, will work on it tonight" else return $ formatted+ else return firstpass++evaluate (sem, getts) = do+ rtriples <- TypeAg2.getReducedTriplestore remoteData (TypeAg2.flatOptimize $ TypeAg2.flattenGetts getts)+ return $ sem rtriples
XSaiga/Getts.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-} module XSaiga.Getts where import Data.List as List+import Data.Text as T hiding (concat, map, zip, head) import Control.Monad import Debug.Trace @@ -14,7 +16,6 @@ import Data.RDF hiding (triple, Triple) import Database.HSparql.Connection import Database.HSparql.QueryGenerator-import Data.Text hiding (head, concat, map, zip, drop, length) --For caching name lookup import qualified Network.Socket as Net@@ -23,51 +24,70 @@ import Data.IORef import System.IO.Unsafe -addUri namespace_uri = (namespace_uri ++)+addUri namespace_uri = (T.append namespace_uri) +type Event = Text+type Triple = (Event, Text, Text)+type FDBR = [(Text,[Event])]+ --getts returns all triples in the triple store that match the given parameters class TripleStore m where- getts_1 :: m -> (Event, String, String) -> IO [String]- getts_2 :: m -> (Event, String, String) -> IO [String]- getts_3 :: m -> (Event, String, String) -> IO [String]- --getts_fdbr_entevprop_type computes the function defined by the entity-event relation r- --where r is the relation between entities of type entity_type- --and events of type event_type- getts_fdbr_entevprop_type :: m -> String -> String -> IO FDBR- getts_fdbr_entevprop_type ev_data ev_type entity_type = do- evs <- getts_1 ev_data ("?", "type", ev_type)- getts_fdbr_entevprop ev_data entity_type evs- - --getts_fdbr_entevprop returns the entities of entity_type of the events in the list evs- getts_fdbr_entevprop :: m -> String -> [Event] -> IO FDBR- getts_fdbr_entevprop ev_data entity_type evs = do- pairs <- liftM concat $ mapM (\ev -> do- ents <- getts_3 ev_data (ev, entity_type,"?")- return $ zip ents (repeat ev)) evs- return $ collect pairs+ getts_triples_entevprop_type :: m -> [Text] -> Text -> IO [Triple] - --getts_members returns- getts_members :: m -> String -> IO FDBR- getts_members ev_data set = do- evs_with_set_as_object <- getts_1 ev_data ("?", "object", set)- evs_with_type_membership <- getts_1 ev_data ("?", "type", "membership")- getts_fdbr_entevprop ev_data "subject" $ intersect evs_with_set_as_object evs_with_type_membership- + getts_triples_entevprop :: m -> [Text] -> [Event] -> IO [Triple]+ + getts_triples_members :: m -> Text -> IO [Triple] sortFirst = sortBy (\x y -> compare (fst x) (fst y)) -type Event = String-type Triple = (Event, String, String)-type FDBR = [(String,[Event])]+--TODO: This is DANGEROUS. Needs refactoring.+make_fdbr_with_prop :: [Triple] -> Text -> FDBR+make_fdbr_with_prop ev_data entity_type + = collect $ map (\(x, _, z) -> (z, x)) $ List.filter (\(x, y, z) -> y == entity_type) ev_data ---For the "In Program" triple store+getts_1 ev_data ("?", b, c) = [x | (x,y,z) <- ev_data, b == y, c == z]+getts_2 ev_data (a, "?", c) = [y | (x,y,z) <- ev_data, a == x, c == z]+getts_3 ev_data (a, b, "?") = [z | (x,y,z) <- ev_data, a == x, b == y]++--TODO: needs serious refactoring... divergence big time++--For the "In Program" triple store -- whole typeclass needs refactoring! instance TripleStore [Triple] where- getts_1 ev_data ("?", b, c) = return [x | (x,y,z) <- ev_data, b == y, c == z]- getts_2 ev_data (a, "?", c) = return [y | (x,y,z) <- ev_data, a == x, c == z]- getts_3 ev_data (a, b, "?") = return [z | (x,y,z) <- ev_data, a == x, b == y]+ getts_triples_entevprop_type ev_data propNames ev_type = do+ let evs_with_type_ev_type = getts_1 ev_data ("?", "type", ev_type)+ getts_triples_entevprop ev_data propNames evs_with_type_ev_type -data SPARQLBackend = SPARQL String String deriving (Ord, Eq)+ getts_triples_entevprop ev_data propNames evs = do+ return $ List.filter (\(ev, prop, _) -> ev `elem` evs && prop `elem` ("type":propNames)) ev_data+ + getts_triples_members ev_data set = do+ let evs_with_set_as_object = getts_1 ev_data ("?", "object", set)+ let evs_with_type_membership = getts_1 ev_data ("?", "type", "membership")+ let evs = intersect evs_with_set_as_object evs_with_type_membership+ --TODO: abstract triple filtering mechanism for events and ev_types+ let triples = [(x, y, z) | (x, y, z) <- ev_data, x `elem` evs]+ return $ triples +--TODO: note, the pure versions do NOT need to include type information++pure_getts_triples_entevprop_type ev_data propNames ev_type =+ pure_getts_triples_entevprop ev_data propNames evs_with_type_ev_type+ where+ evs_with_type_ev_type = getts_1 ev_data ("?", "type", ev_type)++pure_getts_triples_entevprop ev_data propNames evs+ = List.filter (\(ev, prop, _) -> ev `elem` evs && prop `elem` propNames) ev_data++pure_getts_members ev_data set = collect $ setRel+ where+ evs_with_set_as_object = getts_1 ev_data ("?", "object", set)+ evs_with_type_membership = getts_1 ev_data ("?", "type", "membership")+ evs = intersect evs_with_set_as_object evs_with_type_membership+ setRel = [(z, x) | (x, y, z) <- ev_data, x `elem` evs, "subject" == y]+++data SPARQLBackend = SPARQL String Text deriving (Ord, Eq)+ endpointTable :: IORef (M.Map String String) {-# NOINLINE endpointTable #-} endpointTable = unsafeDupablePerformIO $ newIORef M.empty@@ -80,107 +100,72 @@ \x -> (writeIORef endpointTable (M.insert url (newURL (showAddress x) (getURLPath url)) m) >> return (newURL (showAddress x) (getURLPath url))) Just res -> return res where- getServer = List.takeWhile (\x -> '/' /= x) . drop 7+ getServer = List.takeWhile (\x -> '/' /= x) . List.drop 7 showAddress = show . Net.addrAddress . head- getURLPath xs = drop (7 + (length $ getServer xs)) xs+ getURLPath xs = List.drop (7 + (List.length $ getServer xs)) xs newURL server path = "http://" ++ server ++ path --the String in this instance is to be the endpoint that you wish to query instance TripleStore SPARQLBackend where- --getts_1 = getts_1''- getts_1 = memoIO getts_1''- where- getts_1'' (SPARQL endpoint namespace_uri) ("?", b, c) = preprocess namespace_uri $ getts_1'(pack "?", pack (addUri namespace_uri b), pack (addUri namespace_uri c))- where- getts_1' :: (t, Text, Text) -> IO [[BindingValue]]- getts_1' (a, b, c) = do- resolvedEndpoint <- lookupEndpoint endpoint- (Just s) <- selectQuery resolvedEndpoint getts_1_query- return s- where- getts_1_query = do - x <- var- triple x (iriRef b) (iriRef c)- distinct- return SelectQuery { queryVars = [x] }- --getts_2 = getts_2''- getts_2 = memoIO getts_2''- where- getts_2'' (SPARQL endpoint namespace_uri) (a, "?", c) = preprocess namespace_uri $ getts_2'(pack (addUri namespace_uri a), pack "?", pack (addUri namespace_uri c))- where- getts_2' :: (Text, Text, Text) -> IO [[BindingValue]]- getts_2' (a, b, c) = do- resolvedEndpoint <- lookupEndpoint endpoint- (Just s) <- selectQuery resolvedEndpoint getts_2_query - return s- where- getts_2_query = do - x <- var- triple (iriRef a) x (iriRef c)- distinct- return SelectQuery { queryVars = [x] }- --getts_3 = getts_3''- getts_3 = memoIO getts_3''- where- getts_3'' (SPARQL endpoint namespace_uri) (a, b, "?") = preprocess namespace_uri $ getts_3'(pack (addUri namespace_uri a), pack (addUri namespace_uri b), pack "?")- where- getts_3' :: (Text, Text, Text) -> IO [[BindingValue]]- getts_3' (a, b, c) = do- resolvedEndpoint <- lookupEndpoint endpoint- (Just s) <- selectQuery resolvedEndpoint getts_3_query - return s- where- getts_3_query = do - x <- var- triple (iriRef a) (iriRef b) x- distinct- return SelectQuery { queryVars = [x] }- --Efficient implementation of getts_fdbr_entevprop_type for SPARQL backend- getts_fdbr_entevprop_type = memoIO''' getts_fdbr_entevprop_type'''- where- getts_fdbr_entevprop_type''' (SPARQL endpoint namespace_uri) ev_type en_type = do- resolvedEndpoint <- lookupEndpoint endpoint- m <- selectQuery resolvedEndpoint query- case m of- (Just res) -> return $ condense $ map (\[x, y] -> (removeUri namespace_uri $ deconstruct x, removeUri namespace_uri $ deconstruct y)) res- Nothing -> return []- where- query :: Query SelectQuery- query = do- sol <- prefix (pack "sol") (iriRef (pack namespace_uri))- ev <- var- subj <- var- triple ev (sol .:. (pack "type")) (sol .:. (pack ev_type))- triple ev (sol .:. (pack en_type)) subj- orderNext subj- distinct- return SelectQuery { queryVars = [subj,ev] }- - --Efficient implementation of getts_fdbr_entevprop for SPARQL backend- getts_fdbr_entevprop = memoIO'' getts_fdbr_entevprop''- where- getts_fdbr_entevprop'' (SPARQL endpoint namespace_uri) en_type evs = do- resolvedEndpoint <- lookupEndpoint endpoint- m <- selectQuery resolvedEndpoint query- case m of- (Just res) -> return $ condense $ map (\[x, y] -> (removeUri namespace_uri $ deconstruct x, removeUri namespace_uri $ deconstruct y)) res- Nothing -> return []- where- query = do- sol <- prefix (pack "sol") (iriRef (pack namespace_uri))- subj <- var- ev <- var- triple ev (sol .:. (pack en_type)) subj- filterExpr $ regex ev $ (pack $ List.intercalate "|" (map (++ "$") evs))- --Data.List.foldr1 Database.HSparql.QueryGenerator.union $ map (\ev -> triple (sol .:. pack(ev)) (sol .:. pack("subject")) subj) evs -- UNION nesting problem- orderNext subj- distinct- return SelectQuery { queryVars = [subj,ev] } - + getts_triples_entevprop_type (SPARQL endpoint namespace_uri) propNames ev_type = do+ resolvedEndpoint <- lookupEndpoint endpoint+ m <- selectQuery resolvedEndpoint query+ case m of+ (Just res) -> return $ List.concatMap (\[x, y, z] -> [(removeUri namespace_uri $ deconstruct x, "type", ev_type), (removeUri namespace_uri $ deconstruct x, removeUri namespace_uri $ deconstruct y, removeUri namespace_uri $ deconstruct z)]) res+ Nothing -> return []+ where+ query :: Query SelectQuery+ query = do+ sol <- prefix "sol" (iriRef namespace_uri)+ ev <- var+ prop <- var+ ent <- var+ triple ev prop ent+ triple ev (sol .:. "type") (sol .:. ev_type)+ filterExpr $ List.foldr1 (.||.) $ map ((prop .==.) . (sol .:. )) (propNames) --type required here as this is not an FDBR+ selectVars [ev, prop, ent]++ getts_triples_entevprop (SPARQL endpoint namespace_uri) propNames evs = do+ resolvedEndpoint <- lookupEndpoint endpoint+ m <- selectQuery resolvedEndpoint query+ case m of+ (Just res) -> return $ map (\[x, y, z] -> (removeUri namespace_uri $ deconstruct x, removeUri namespace_uri $ deconstruct y, removeUri namespace_uri $ deconstruct z)) res+ Nothing -> return []+ where+ query :: Query SelectQuery+ query = do+ sol <- prefix "sol" (iriRef namespace_uri)+ ev <- var+ prop <- var+ ent <- var+ triple ev prop ent+ filterExpr $ List.foldr1 (.||.) $ map ((ev .==.) . (sol .:. )) evs+ filterExpr $ List.foldr1 (.||.) $ map ((prop .==.) . (sol .:. )) propNames+ selectVars [ev, prop, ent]++ getts_triples_members (SPARQL endpoint namespace_uri) set = do+ resolvedEndpoint <- lookupEndpoint endpoint+ m <- selectQuery resolvedEndpoint query+ case m of+ (Just res) -> return $ Prelude.concatMap (\[ev, ent] ->+ [(removeUri namespace_uri $ deconstruct ev, "type", "membership"),+ (removeUri namespace_uri $ deconstruct ev, "subject", removeUri namespace_uri $ deconstruct ent),+ (removeUri namespace_uri $ deconstruct ev, "object", set)]) res+ Nothing -> return []+ where+ query :: Query SelectQuery+ query = do+ sol <- prefix "sol" (iriRef namespace_uri)+ ev <- var+ ent <- var+ triple ev (sol .:. "type") (sol .:. "membership")+ triple ev (sol .:. "subject") ent+ triple ev (sol .:. "object") (sol .:. set)+ selectVars [ev, ent]++ --Used to return FDBR directly --Efficient implementation of getts_members for SPARQL backend- - getts_members = memoIO' getts_members'- --getts_members = getts_members'+ {-getts_members = getts_members' where getts_members' (SPARQL endpoint namespace_uri) set = do resolvedEndpoint <- lookupEndpoint endpoint@@ -191,85 +176,30 @@ where query :: Query SelectQuery query = do- sol <- prefix (pack "sol") (iriRef (pack namespace_uri))+ sol <- prefix "sol" (iriRef namespace_uri) ev <- var subj <- var- triple ev (sol .:. (pack "type")) (sol .:. (pack "membership"))- triple ev (sol .:. (pack "subject")) subj- triple ev (sol .:. (pack "object")) (sol .:. (pack set))+ triple ev (sol .:. "type") (sol .:. "membership")+ triple ev (sol .:. "subject") subj+ triple ev (sol .:. "object") (sol .:. set) orderNext subj distinct- return SelectQuery { queryVars = [subj,ev] }- - -removeUri :: String -> String -> String -removeUri namespace_uri = drop $ length namespace_uri+ selectVars [subj, ev]+ -}++removeUri :: Text -> Text -> Text +removeUri namespace_uri = T.drop $ T.length namespace_uri -preprocess :: String -> IO [[BindingValue]] -> IO [String]+preprocess :: Text -> IO [[BindingValue]] -> IO [Text] preprocess namespace_uri bvals = bvals >>= \x -> return $ map (removeUri namespace_uri . deconstruct) $ concat x -deconstruct :: BindingValue -> String+deconstruct :: BindingValue -> Text deconstruct value = do let (Bound node) = value case node of- UNode strURI -> unpack strURI- LNode (PlainL strLit) -> unpack strLit----memotable :: IORef (M.Map (SPARQLBackend,(String,String,String)) [String])-{-# NOINLINE memotable #-}-memotable = unsafeDupablePerformIO $ newIORef M.empty--memoIO ::(SPARQLBackend -> (String, String, String) -> IO [String]) -> SPARQLBackend -> (String, String, String) -> IO [String]-memoIO f a x = do- m <- readIORef memotable- case M.lookup (a,x) m of- Nothing -> f a x >>= \q -> (writeIORef memotable (M.insert (a,x) q m) >> return q)- Just r -> return r- -memotable' :: IORef (M.Map (SPARQLBackend,String) FDBR)-{-# NOINLINE memotable' #-}-memotable' = unsafeDupablePerformIO $ newIORef M.empty--memoIO' ::(SPARQLBackend -> (String) -> IO FDBR) -> SPARQLBackend -> (String) -> IO FDBR-memoIO' f a x = do- m <- readIORef memotable'- case M.lookup (a,x) m of- Nothing -> f a x >>= \q -> (writeIORef memotable' (M.insert (a,x) q m) >> return q)- Just r -> return r- -memotable'' :: IORef (M.Map (SPARQLBackend,String,[String]) FDBR)-{-# NOINLINE memotable'' #-}-memotable'' = unsafeDupablePerformIO $ newIORef M.empty--memoIO'' ::(SPARQLBackend -> String -> [String] -> IO FDBR) -> SPARQLBackend -> String -> [String] -> IO FDBR-memoIO'' f a x y = do- m <- readIORef memotable''- case M.lookup (a,x,y) m of- Nothing -> f a x y >>= \q -> (writeIORef memotable'' (M.insert (a,x,y) q m) >> return q)- Just r -> return r- -memotable''' :: IORef (M.Map (SPARQLBackend,String,String) FDBR)-{-# NOINLINE memotable''' #-}-memotable''' = unsafeDupablePerformIO $ newIORef M.empty--memoIO''' ::(SPARQLBackend -> String -> String -> IO FDBR) -> SPARQLBackend -> String -> String -> IO FDBR-memoIO''' f a x y = do- m <- readIORef memotable'''- case M.lookup (a,x,y) m of- Nothing -> f a x y >>= \q -> (writeIORef memotable''' (M.insert (a,x,y) q m) >> return q)- Just r -> return r-- ---Get members of named set-get_members :: (TripleStore m) => m -> String -> IO FDBR-get_members = getts_members- ---Get all subjects of a given event type-get_subjs_of_event_type :: (TripleStore m) => m -> String -> IO FDBR-get_subjs_of_event_type ev_data ev_type = make_fdbr ev_data ev_type "subject"+ UNode strURI -> strURI+ LNode (PlainL strLit) -> strLit {-collect accepts a binary relation as input and computes the image img of each@@ -308,7 +238,7 @@ cmp x y = (fst x) == (fst y) --alias for getts_fdbr_entevprop_type-make_fdbr :: (TripleStore m) => m -> String -> String -> IO FDBR-make_fdbr = getts_fdbr_entevprop_type +--make_fdbr :: (TripleStore m) => m -> Text -> Text -> IO FDBR+--make_fdbr = getts_fdbr_entevprop_type
XSaiga/Interactive.hs view
@@ -1,9 +1,14 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} module XSaiga.Interactive where import XSaiga.SolarmanTriplestore import XSaiga.Getts+import XSaiga.TypeAg2+import XSaiga.CGI+import Data.Functor+import Data.Biapplicative import Control.Monad a $ b = a b@@ -11,66 +16,87 @@ a . b = \x -> a (b (x)) infixr 9 . -discover tmph = make_trans_active' dataStore "discover_ev" [(["object"],tmph)]-discover' tmph preps = make_trans_active' dataStore "discover_ev" $ (["object"], tmph):preps-discover_ = make_trans_passive' dataStore "discover_ev"+discover = make_trans_active discover_rel+discover' = make_trans_active' discover_rel+discover'' = make_trans_active'' discover_rel+discover_ = make_trans_passive discover_rel -discovers tmph = make_trans_active' dataStore "discover_ev" [(["object"],tmph)]-discovers' tmph preps = make_trans_active' dataStore "discover_ev" $ (["object"], tmph):preps-discovers_ = make_trans_passive' dataStore "discover_ev"+discovers = make_trans_active discover_rel+discovers' = make_trans_active' discover_rel+discovers'' = make_trans_active'' discover_rel+discovers_ = make_trans_passive discover_rel -discovered tmph = make_trans_active' dataStore "discover_ev" [(["object"],tmph)]-discovered' tmph preps = make_trans_active' dataStore "discover_ev" $ (["object"], tmph):preps-discovered_ = make_trans_passive' dataStore "discover_ev"+discovered = make_trans_active discover_rel+discovered' = make_trans_active' discover_rel+discovered'' = make_trans_active'' discover_rel+discovered_ = make_trans_passive discover_rel -orbit tmph = make_trans_active' dataStore "orbit_ev" [(["object"],tmph)]-orbit' tmph preps = make_trans_active' dataStore "orbit_ev" $ (["object"], tmph):preps-orbit_ = make_trans_passive' dataStore "orbit_ev"+orbit = make_trans_active orbit_rel+orbit' = make_trans_active' orbit_rel+orbit'' = make_trans_active'' orbit_rel+orbit_ = make_trans_passive orbit_rel -orbits tmph = make_trans_active' dataStore "orbit_ev" [(["object"],tmph)]-orbits' tmph preps = make_trans_active' dataStore "orbit_ev" $ (["object"], tmph):preps-orbits_ = make_trans_passive' dataStore "orbit_ev"+orbits = make_trans_active orbit_rel+orbits' = make_trans_active' orbit_rel+orbits'' = make_trans_active'' orbit_rel+orbits_ = make_trans_passive orbit_rel -orbited tmph = make_trans_active' dataStore "orbit_ev" [(["object"],tmph)]-orbited' tmph preps = make_trans_active' dataStore "orbit_ev" $ (["object"], tmph):preps-orbited_ = make_trans_passive' dataStore "orbit_ev"+orbited = make_trans_active orbit_rel+orbited' = make_trans_active' orbit_rel+orbited'' = make_trans_active'' orbit_rel+orbited_ = make_trans_passive orbit_rel -discoverer = get_subjs_of_event_type dataStore "discover_ev"-discoverers = get_subjs_of_event_type dataStore "discover_ev"-anyone = a person-anything = a thing-anybody = a person-someone = a person-something = a thing-somebody = a person-everyone = every person-everything = every thing-everybody = every person+use = make_trans_active use_rel+use' = make_trans_active' use_rel+use'' = make_trans_active'' use_rel+use_ = make_trans_passive use_rel++uses = make_trans_active use_rel+uses' = make_trans_active' use_rel+uses'' = make_trans_active'' use_rel+uses_ = make_trans_passive use_rel++used = make_trans_active use_rel+used' = make_trans_active' use_rel+used'' = make_trans_active'' use_rel+used_ = make_trans_passive use_rel++discoverer = get_subjs_of_event_type "discover_ev"+discoverers = get_subjs_of_event_type "discover_ev"+anyone = a <<*>> person+anything = a <<*>> thing+anybody = a <<*>> person+someone = a <<*>> person+something = a <<*>> thing+somebody = a <<*>> person+everyone = every <<*>> person+everything = every <<*>> thing+everybody = every <<*>> person telescopes = telescope places = place-thing = get_members dataStore "thing"-things = get_members dataStore "thing"-planets = get_members dataStore "planet"-planet = get_members dataStore "planet"-person = get_members dataStore "person"-sun = get_members dataStore "sun"-moon = get_members dataStore "moon"-moons = get_members dataStore "moon"-satellite = get_members dataStore "moon"-satellites = get_members dataStore "moon"-atmospheric = get_members dataStore "atmospheric"-blue = get_members dataStore "blue"-solid = get_members dataStore "solid"-brown = get_members dataStore "brown"-gaseous = get_members dataStore "gaseous"-green = get_members dataStore "green"-red = get_members dataStore "red"-ringed = get_members dataStore "ringed"-vacuumous = get_members dataStore "vacuumous"-exist = get_members dataStore "thing"-exists = get_members dataStore "thing"-spin = get_members dataStore "spin"-spins = get_members dataStore "spin"+thing = get_members "thing"+things = get_members "thing"+planets = get_members "planet"+planet = get_members "planet"+person = get_members "person"+sun = get_members "sun"+moon = get_members "moon"+moons = get_members "moon"+satellite = get_members "moon"+satellites = get_members "moon"+atmospheric = get_members "atmospheric"+blue = get_members "blue"+solid = get_members "solid"+brown = get_members "brown"+gaseous = get_members "gaseous"+green = get_members "green"+red = get_members "red"+ringed = get_members "ringed"+vacuumous = get_members "vacuumous"+exist = get_members "thing"+exists = get_members "thing"+spin = get_members "spin"+spins = get_members "spin" bernard = make_pnoun "bernard" bond = make_pnoun "bond" venus = make_pnoun "venus"@@ -133,10 +159,10 @@ triton = make_pnoun "triton" umbriel = make_pnoun "umbriel" uranus = make_pnoun "uranus"-human = get_members dataStore "person"-humans = get_members dataStore "person"-people = get_members dataStore "person"-telescope = get_members dataStore "telescope"+human = get_members "person"+humans = get_members "person"+people = get_members "person"+telescope = get_members "telescope" cassegrain_telescope = make_pnoun "cassegrain_telescope" hooker_telescope = make_pnoun "hooker_telescope" schmidt_telescope = make_pnoun "schmidt_telescope"@@ -161,8 +187,8 @@ ground_based_telescope_2 = make_pnoun "ground_based_telescope_2" ground_based_telescope_3 = make_pnoun "ground_based_telescope_3" galilean_telescope_1 = make_pnoun "galilean_telescope_1"-team = get_members dataStore "science_team"-teams = get_members dataStore "science_team"+team = get_members "science_team"+teams = get_members "science_team" voyager_science_team = make_pnoun "voyager_science_team" cassini_imaging_science_team = make_pnoun "cassini_imaging_science_team" science_team_1 = make_pnoun "science_team_1"@@ -235,11 +261,11 @@ hamilton = make_pnoun "hamilton" soummer = make_pnoun "soummer" throop = make_pnoun "throop"-spacecraft = get_members dataStore "spacecraft"-spacecrafts = get_members dataStore "spacecrafts"+spacecraft = get_members "spacecraft"+spacecrafts = get_members "spacecrafts" voyager_1 = make_pnoun "voyager_1" voyager_2 = make_pnoun "voyager_2"-place = get_members dataStore "place"+place = get_members "place" mt_hopkins = make_pnoun "mt_hopkins" fort_davis = make_pnoun "fort_davis" cerro_tololo = make_pnoun "cerro_tololo"
XSaiga/LocalData.hs view
@@ -1,7 +1,12 @@ {-# LANGUAGE Safe #-}+{-# LANGUAGE OverloadedStrings #-} module XSaiga.LocalData where +import Data.Text++--Perhaps should use map...+localData :: [(Text, Text, Text)] localData = [("event1000", "object", "sol"), ("event1000", "subject", "mercury"), ("event1000", "type", "orbit_ev"),
+ XSaiga/ShowText.hs view
@@ -0,0 +1,25 @@+module XSaiga.ShowText where++import Data.Text+{-import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Text.Lazy.Builder.RealFloat (realFloat)++class ShowText a where+ tshow :: a -> Text++instance ShowText Int where+ tshow = toStrict . toLazyText . decimal++instance ShowText Float where+ tshow = toStrict . toLazyText . realFloat++instance ShowText Text where+ tshow = id+++-} --TODO: when TH works on ARM, use text-show++tshow :: (Show a) => a -> Text+tshow = pack . show
XSaiga/SolarmanTriplestore.hs view
@@ -1,65 +1,96 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-}+ module XSaiga.SolarmanTriplestore where -import Prelude hiding ((*>))+import Prelude hiding ((*>), words, unwords, concat, concatMap, null) import XSaiga.Getts-import Data.List as List+import Data.List as List hiding (words, unwords)+import qualified Data.Text as T import qualified Data.Set as Set import XSaiga.AGParser2 import XSaiga.TypeAg2 import Control.Monad import Debug.Trace-import qualified XSaiga.LocalData as Local----change between remoteData and localData---dataStore = Local.localData-dataStore = remoteData -- selects database--endpoint_uri = "http://speechweb2.cs.uwindsor.ca/sparql"-namespace_uri = "http://solarman.richard.myweb.cs.uwindsor.ca#"-remoteData = SPARQL endpoint_uri namespace_uri+import XSaiga.ShowText+import Control.Monad.State.Lazy+import Control.Applicative hiding ((*>), (<|>))+import Data.Biapplicative+import Data.Bifunctor+import qualified Data.Map as Map --copied from gangster_v4: utility functions for making lists unique subset s t = (s \\ t) == [] -makeset x = Set.toList $ Set.fromList x+--TODO: MERGE IMAGES PROPER+termor' :: (TF FDBR -> TF FDBR) -> (TF FDBR -> TF FDBR) -> TF FDBR -> TF FDBR+termor' tmph1 tmph2 ents = union_fdbr' (tmph1 ents) (tmph2 ents) --copied from gangster_v4: combinators-termor tmph1 tmph2 ents =- liftM List.nub $ liftM2 (++) (tmph1 ents) (tmph2 ents) --TODO: MERGE IMAGES PROPER+termor :: SemFunc ((TF FDBR -> TF FDBR) -> (TF FDBR -> TF FDBR) -> TF FDBR -> TF FDBR)+termor = bipure termor' (\g1 -> \g2 -> \g3 -> gettsUnion (gettsApply g1) (gettsApply g2)) -termand tmph1 tmph2 ents = do- t1 <- tmph1 ents- t2 <- tmph2 ents- if t1 /= [] && t2 /= [] then return $ List.nub $ t1 ++ t2 else return []- --May need to be changed to intersection? Don't think so: can't remove anything from nub (t1++t2) because all things are relevant to either t1 or t2- --TODO: MERGE IMAGES PROPER (or do termphrases always preserve ents)+termand' :: (TF FDBR -> TF FDBR) -> (TF FDBR -> TF FDBR) -> TF FDBR -> TF FDBR+termand' tmph1 tmph2 ents r = if not (List.null $ tmph1 ents r) && not (List.null $ tmph2 ents r) then termor' tmph1 tmph2 ents r else [] +--May need to be changed to intersection? Don't think so: can't remove anything from nub (t1++t2) because all things are relevant to either t1 or t2+--TODO: MERGE IMAGES PROPER (or do termphrases always preserve ents)+termand = bipure termand' (\g1 -> \g2 -> \g3 -> gettsUnion (gettsApply g1) (gettsApply g2))+ --TODO: FDBRs are sorted. Use that to improve this.-intersect_fdbr eei1 eei2- = [(subj2, evs2) | (subj1, evs1) <- eei1, (subj2, evs2) <- eei2, subj1 == subj2]+intersect_fdbr'' _ [] = []+intersect_fdbr'' [] _ = []+intersect_fdbr'' fdbr1@((e1, evs1):eei1) fdbr2@((e2, evs2):eei2)+ = case compare e1 e2 of+ LT -> intersect_fdbr'' eei1 fdbr2+ EQ -> (e2, evs2):(intersect_fdbr'' eei1 eei2) + GT -> intersect_fdbr'' fdbr1 eei2 +{-intersect_fdbr'' eei1 eei2+ = [(subj2, evs2) | (subj1, evs1) <- eei1, (subj2, evs2) <- eei2, subj1 == subj2]-}++intersect_fdbr' :: TF FDBR -> TF FDBR -> TF FDBR+intersect_fdbr' = liftA2 intersect_fdbr'' --intersect_fdbr'' <$> tf1 <*> tf2++intersect_fdbr :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)+intersect_fdbr = bipure intersect_fdbr' gettsIntersect++union_fdbr'' :: FDBR -> FDBR -> FDBR+union_fdbr'' fdbr1 fdbr2 = Map.toList $ Map.fromListWith (++) (fdbr1 ++ fdbr2)++union_fdbr' :: TF FDBR -> TF FDBR -> TF FDBR+union_fdbr' = liftA2 union_fdbr''++union_fdbr :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)+union_fdbr = bipure union_fdbr' gettsUnion++nounand = intersect_fdbr+ that = nounand -nounand = liftM2 intersect_fdbr+--TODO: MERGE IMAGES PROPER (verify) -nounor' s t = List.nub(s ++ t)-nounor = liftM2 nounor'+nounor = union_fdbr {-a' nph vbph = length (intersect nph vbph) /= 0-}-a = liftM2 intersect_fdbr+a = intersect_fdbr any' = a the = a some = a an = a -every' nph vbph | subset (map fst nph) (map fst vbph) = intersect_fdbr nph vbph+every'' :: FDBR -> FDBR -> FDBR+every'' nph vbph | subset (map fst nph) (map fst vbph) = intersect_fdbr'' nph vbph | otherwise = [] -every = liftM2 every'+every' :: TF FDBR -> TF FDBR -> TF FDBR+every' = liftA2 every'' +every :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)+every = bipure every' gettsIntersect+ {- TODO: no' nph vbph = length (intersect nph vbph) == 0@@ -72,66 +103,112 @@ none = liftM2 none' -} -one' nph vbph | length (res) == 1 = res+one'' :: FDBR -> FDBR -> FDBR+one'' nph vbph | length (res) == 1 = res | otherwise = [] where- res = intersect_fdbr nph vbph+ res = intersect_fdbr'' nph vbph -one = liftM2 one'+one' :: TF FDBR -> TF FDBR -> TF FDBR+one' = liftA2 one'' -two' nph vbph | length (res) == 2 = res+one = bipure one' gettsIntersect++two'' nph vbph | length (res) == 2 = res | otherwise = [] where- res = intersect_fdbr nph vbph+ res = intersect_fdbr'' nph vbph -two = liftM2 two'+two' = liftA2 two'' +two = bipure two' gettsIntersect+ --which nph vbph = if result /= [] then result else "none." -- where result = unwords $ intersect nph vbph -which nph vbph = do- nph_ <- nph- vbph_ <- vbph- let result = unwords $ map fst $ intersect_fdbr nph_ vbph_- return $ if result /= [] then result else "none."+which'' :: FDBR -> FDBR -> T.Text+which'' nph vbph = if not $ T.null result then result else "none."+ where+ result = T.unwords $ map fst $ intersect_fdbr'' nph vbph -how_many' nph vbph =- show $ length (intersect_fdbr nph vbph)-how_many = liftM2 how_many'+which :: SemFunc (TF FDBR -> TF FDBR -> TF T.Text)+which = bipure (liftA2 which'') gettsIntersect -who = which ((get_members dataStore "person") `nounor` (get_members dataStore "science_team"))+how_many'' nph vbph = tshow $ List.length (intersect_fdbr'' nph vbph)+how_many = bipure (liftA2 how_many'') gettsIntersect +who = which <<*>> (nounor <<*>> (get_members "person") <<*>> (get_members "science_team"))+ --New-what' nph = if result /= [] then result else "nothing."- where result = unwords $ map fst nph-what = liftM what'+what'' nph = if not $ T.null result then result else "nothing."+ where result = T.unwords $ map fst nph -with :: (IO FDBR -> IO FDBR) -> ([String], IO FDBR -> IO FDBR)-with tmph = (["with_implement"], tmph)+what = bipure (liftA what'') id -by tmph = (["subject"], tmph)+--TODO: prepositions+make_prep props = bipure (\tmph -> (props, tmph)) (gettsApply) -at tmph = (["location"], tmph)+make_prep_nph props = bipure (\nph -> (props, intersect_fdbr' nph)) (id) -in' tmph = (["location", "year"], make_pnoun $ show tmph)+--with :: (TF FDBR -> TF FDBR) -> ([T.Text], TF FDBR -> TF FDBR)+with = make_prep ["with_implement"] -make_pnoun noun = liftM $ make_pnoun' noun-make_pnoun' noun image = [(subj, evs) | (subj, evs) <- image, subj == noun]+by = make_prep ["subject"] +at = make_prep ["location"]++make_pnoun'' noun image = [(subj, evs) | (subj, evs) <- image, subj == noun]++make_pnoun :: T.Text -> SemFunc (TF FDBR -> TF FDBR)+make_pnoun noun = bipure (liftA $ make_pnoun'' noun) id++--TODO: ugly hack to work around parser problem+make_year = make_pnoun . tshow++in' = make_prep ["location", "year"]++--TODO: verify "subject" and identity here. should not be introducing more info...+--to = bipure (\nph -> (["subject"], intersect_fdbr' nph)) (id)+to = make_prep_nph ["subject"]+ --New for new new semantics ---TODO: Handle case where nothing is in props (return none)-make_prop_termphrase prop nph = do- list <- nph- props <- mapM (\(_,y) -> getts_fdbr_entevprop dataStore prop y >>= \loc -> return (map fst loc)) list- let finalList = unwords $ List.nub $ concat props- return $ if finalList /= [] then finalList else "nothing."+--Strategy: collect all events, get all triples of those evs with prop+--use getts_fdbr_entevprop or similar to... +{-make_prop_termphrase :: (TripleStore m) => m -> T.Text -> TF FDBR -> TF T.Text+make_prop_termphrase ev_data prop nph = do+ list <- nph+ let evs = List.nub $ List.concatMap snd list+ rtriples <- getts_triples_entevprop ev_data [prop] evs+ let finalList = T.unwords $ List.nub $ map (\(x,y,z) -> z) rtriples+ return $ if not $ T.null finalList then finalList else "nothing."+-}++make_prop_termphrase' :: T.Text -> TF FDBR -> TF T.Text+make_prop_termphrase' prop nph triples = if not $ T.null finalList then finalList else "nothing."+ where+ evs = List.nub $ List.concatMap snd (nph triples)+ rtriples = pure_getts_triples_entevprop triples [prop] evs+ finalList = T.unwords $ List.nub $ map (\(x,y,z) -> z) rtriples++--TODO: attach info!+make_prop_termphrase :: T.Text -> SemFunc (TF FDBR -> TF T.Text)+make_prop_termphrase prop = make_prop_termphrase' prop >|< gettsAttachP prop+ where' = make_prop_termphrase "location" when' = make_prop_termphrase "year" how' = make_prop_termphrase "with_implement"-whatobj = make_prop_termphrase "object" +--needs special handling due to semantics requiring info from getts+whatobj :: SemFunc (TF FDBR) -> SemFunc (TF T.Text)+whatobj (fdbr, getts) = make_prop_termphrase' (findFirstObj getts) fdbr >|< gettsAttachPO getts+ where+ findFirstObj (GettsIntersect _ y) = findFirstObj y+ findFirstObj (GettsTP _ (_,_,object) _) = object+ gettsAttachPO (GettsIntersect x y) = GettsIntersect x (gettsAttachPO y)+ gettsAttachPO (GettsTP props (rel, subject, object) sub) = GettsTP (object:props) (rel, subject, object) sub+ --end of copied from gangster_v4 {-@@ -183,7 +260,6 @@ refractor_telescope_1 = make_pnoun "refractor_telescope_1" -} -make_trans_active ev_type tmph = make_trans_active' dataStore ev_type [(["object"],tmph)] {-make_inverted_relation :: (TripleStore m) => m -> String -> (IO [String] -> IO Bool) -> IO [String] make_inverted_relation ev_data rel tmph = do@@ -208,7 +284,7 @@ --applies the preposition predicate to that, so that all data is available to the predicate rather than just the subset --given by a specific event --TODO: new filter_Ev-{-filter_ev :: (TripleStore m) => m -> [([String], IO FDBR -> IO FDBR)] -> [Event] -> IO Bool+{-filter_ev :: (TripleStore m) => m -> [([String], TF FDBR -> TF FDBR)] -> [Event] -> IO Bool filter_ev _ [] _ = return True filter_ev ev_data ((names,pred):list) evs = do relevant_list <- mapM (\name -> getts_fdbr_entevprop ev_data name evs) names@@ -216,14 +292,16 @@ if res /= [] then filter_ev ev_data list evs else return False-} --new filter_ev: Handles prepositional phrases (IN TESTING)-filter_ev :: (TripleStore m) => m -> [([String], IO FDBR -> IO FDBR)] -> [Event] -> IO Bool-filter_ev _ [] _ = return True-filter_ev ev_data ((names,pred):list) evs = do- relevant_list <- mapM (\name -> getts_fdbr_entevprop ev_data name evs) names- res <- pred $ return $ concat $ relevant_list- --NEW: Merge all events in predicate result for new query. Result will be a subset of evs.- let relevant_evs = List.nub $ concatMap snd res- if res /= [] then filter_ev ev_data list relevant_evs else return False+filter_ev :: [([T.Text], TF FDBR -> TF FDBR)] -> [Event] -> TF [Event]+filter_ev [] evs ev_data = evs+filter_ev ((names,pred):list) evs triples+ = if not $ List.null res then filter_ev list relevant_evs triples else []+ where + relevant_triples = List.filter (\(x, _, _) -> x `elem` evs) triples -- only get triples with our events+ relevant_list = concatMap (\name -> make_fdbr_with_prop relevant_triples name) names + res = pred (pure relevant_list) triples --TODO: prove correct+ --NEW: Merge all events in predicate result for new query. Result will be a subset of evs.+ relevant_evs = List.nub $ concatMap snd res {-make_trans_active' :: (TripleStore m) => m -> String -> (IO [String] -> IO Bool) -> [([String], IO [String] -> IO Bool)] -> IO [String] make_trans_active' ev_data rel tmph preps = do@@ -233,12 +311,76 @@ tmph $ liftM concat $ mapM (\ev -> getts_3 ev_data (ev, "object", "?")) filtEvents) images return $ map fst subPairs-} +{-prepProps :: [([T.Text], a)] -> [T.Text]+prepProps = nub . concatMap fst-}++{-gatherPreps :: [([T.Text], SemFunc (TF FDBR -> TF FDBR))] -> SemFunc [([T.Text], TF FDBR -> TF FDBR)]+gatherPreps preps = peelGetts preps >|< attachProps preps+ where+ peelGetts = map (\(propNames, sf) -> (propNames, getSem sf)) + extractGetts = foldr iunion GettsNone . map (\(propNames, sf) -> getGetts sf)+ attachProps preps = GettsPreps (nub $ concatMap fst preps) `iunion` (extractGetts preps) --Will contain AttachP info [propNames] and whatever else was in SemFunc(->)+-} + --Modified version of make_trans_active' to accomodate new filter_ev-make_trans_active' :: (TripleStore m) => m -> String -> [([String], IO FDBR -> IO FDBR)] -> IO FDBR+{-make_trans_active' :: (TripleStore m) => m -> T.Text -> [([T.Text], SemFunc (TF FDBR -> TF FDBR))] -> TF FDBR make_trans_active' ev_data rel preps = do- images <- make_fdbr ev_data rel "subject"- filterM (\(_, evs) -> filter_ev ev_data preps evs) images+ triples <- getts_triples_entevprop_type ev_data ("subject":(prepProps preps)) rel+ let images = make_fdbr_with_prop triples "subject"+ fdbrRelevantEvs <- mapM (\(subj, evs) -> filter_ev triples preps evs >>= (\x -> return (subj, x))) images+ filterM (return . not . List.null . snd) fdbrRelevantEvs+-} +data Voice = ActiveVoice | PassiveVoice+getVoiceProps ActiveVoice (_, prop1, prop2) = (prop1, prop2)+getVoiceProps PassiveVoice (_, prop1, prop2) = (prop2, prop1)++gettsTP :: Voice -> Relation -> GettsTree -> GettsTree+gettsTP voice rel (GettsPreps props' sub) = GettsTP (subject:props') rel sub+ where+ (subject,_) = getVoiceProps voice rel++relname (a, _, _) = a++make_trans'' :: Voice -> Relation -> [([T.Text], (TF FDBR -> TF FDBR))] -> TF FDBR+make_trans'' voice rel preps rtriples = filter (not . List.null . snd) fdbrRelevantEvs+ where+ (subjectProp,_) = getVoiceProps voice rel+ filtRTriples = pure_getts_triples_entevprop_type rtriples (subjectProp:(nub $ concatMap fst $ preps)) (relname rel)+ images = make_fdbr_with_prop filtRTriples subjectProp+ fdbrRelevantEvs = map (\(subj, evs) -> (subj, filter_ev preps evs rtriples)) images++--make_trans_active' "discover_ev" <<*>> (gatherPreps [at us_naval_observatory, in' 1877])+--TODO: rtriples is used directly?? is this correct?+--TODO: refactor to take into account active tmph+--TODO: refactor both passive and active into same function (active version may involve more)++--SCHEME+--empty denotes tmph+--' denotes preps+--'' denotes tmph followed by preps++make_trans_active' :: Relation -> SemFunc ([([T.Text], (TF FDBR -> TF FDBR))] -> TF FDBR)+make_trans_active' rel = make_trans'' ActiveVoice rel >|< gettsTP ActiveVoice rel++--TODO: Bug in solarman3 semantics here with only "subject" in GettsTP+--make_trans_active :: T.Text -> SemFunc ((TF FDBR -> TF FDBR) -> TF FDBR)+--make_trans_active ev_type = (\tmph_sem -> make_trans_active'' ev_type [(["object"], tmph_sem)]) >|< (\g -> GettsTP ["subject", "object"] ev_type [gettsApply g])++make_trans_active :: Relation -> SemFunc ((TF FDBR -> TF FDBR) -> TF FDBR)+make_trans_active rel = (\tmph_sem -> f [([object], tmph_sem)]) >|< (\getts -> g $ GettsPreps [object] [gettsApply getts])+ where+ (_, object) = getVoiceProps ActiveVoice rel+ (f, g) = make_trans_active' rel++make_trans_active'' :: Relation -> SemFunc ((TF FDBR -> TF FDBR) -> [([T.Text], (TF FDBR -> TF FDBR))] -> TF FDBR)+make_trans_active'' rel = (\tmph_sem -> \preps -> f (([object], tmph_sem):preps)) >|< (\getts -> \preps -> g (addPrep object getts preps))+ where+ (subject, object) = getVoiceProps ActiveVoice rel+ (f, g) = make_trans_active' rel+ addPrep :: T.Text -> (GettsTree -> GettsTree) -> GettsTree -> GettsTree+ addPrep prop getts (GettsPreps props subs) = GettsPreps (prop:props) ((gettsApply getts):subs)+ {-make_trans_passive' :: (TripleStore m) => m -> String -> [([String], IO [String] -> IO Bool)] -> IO [String] make_trans_passive' ev_data rel preps = do images <- make_fdbr ev_data rel "object"@@ -249,14 +391,19 @@ anyM pred lst = foldM (\x y -> pred y >>= \res -> return $ x || res) False lst -} --Modified version of make_trans_passive' to accomodate new filter_ev-make_trans_passive' :: (TripleStore m) => m -> String -> [([String], IO FDBR -> IO FDBR)] -> IO FDBR+{-make_trans_passive' :: (TripleStore m) => m -> T.Text -> [([T.Text], SemFunc (TF FDBR -> TF FDBR))] -> TF FDBR make_trans_passive' ev_data rel preps = do- images <- make_fdbr ev_data rel "object"- filterM (\(_, evs) -> filter_ev ev_data preps evs) images+ triples <- getts_triples_entevprop_type ev_data ("object":(prepProps preps)) rel+ let images = make_fdbr_with_prop triples "object"+ fdbrRelevantEvs <- mapM (\(subj, evs) -> filter_ev triples preps evs >>= (\x -> return (subj, x))) images+ filterM (return . not . List.null . snd) fdbrRelevantEvs-} +make_trans_passive :: Relation -> SemFunc ([([T.Text], (TF FDBR -> TF FDBR))] -> TF FDBR)+make_trans_passive rel = make_trans'' PassiveVoice rel >|< gettsTP PassiveVoice rel+ --Copied from old solarman: yesno' x = if x /= [] then "yes." else "no"-yesno = liftM yesno'+yesno = bipure (liftA yesno') id does = yesno did = yesno@@ -267,29 +414,52 @@ are = yesno --TODO: is this proper?-sand s1 s2 = do+{-sand s1 s2 = do r1 <- s1 r2 <- s2- return $ if r1 /= [] && r2 /= [] then List.nub $ r1 ++ r2 else []+ return $ if r1 /= [] && r2 /= [] then List.nub $ r1 ++ r2 else []-} +--TODO: MERGE IMAGES PROPER (verify new impl)+sand'' = union_fdbr''++sand = bipure (liftA2 sand'') gettsUnion++--TODO: testing {-+moon = get_members "moon"+phobos = make_pnoun "phobos"+hall = make_pnoun "hall"+discover = make_trans_active "discover_ev"+discover' = make_trans_active' "discover_ev"+discover'' = make_trans_active'' "discover_ev"+discover_ = make_trans_passive "discover_ev"+telescope = get_members "telescope"+person = get_members "person"+planet = get_members "planet"+discoverer = get_subjs_of_event_type "discover_ev"+orbits = make_trans_active "orbit_ev"+orbits' = make_trans_active' "orbit_ev"+spins = get_members "spin"+-}++{- ||----------------------------------------------------------------------------- || BASIC INTERPRETERS ||----------------------------------------------------------------------------- -} -pnoun = pre_processed Pnoun-cnoun = pre_processed Cnoun-adj = pre_processed Adj-det = pre_processed Det-intransvb = pre_processed Intransvb-transvb = pre_processed Transvb-linkingvb = pre_processed Linkingvb-relpron = pre_processed Relpron-termphjoin = pre_processed Termphjoin-verbphjoin = pre_processed Verbphjoin-nounjoin = pre_processed Nounjoin-indefpron = pre_processed Indefpron+pnoun = memoize_terminals_from_dictionary Pnoun+cnoun = memoize_terminals_from_dictionary Cnoun+adj = memoize_terminals_from_dictionary Adj+det = memoize_terminals_from_dictionary Det+intransvb = memoize_terminals_from_dictionary Intransvb+transvb = memoize_terminals_from_dictionary Transvb+linkingvb = memoize_terminals_from_dictionary Linkingvb+relpron = memoize_terminals_from_dictionary Relpron+termphjoin = memoize_terminals_from_dictionary Termphjoin+verbphjoin = memoize_terminals_from_dictionary Verbphjoin+nounjoin = memoize_terminals_from_dictionary Nounjoin+indefpron = memoize_terminals_from_dictionary Indefpron {- terminator = uninterpreted (SPECIAL_SYMBOL_TERM ".") $orelse@@ -297,54 +467,52 @@ $orelse uninterpreted (SPECIAL_SYMBOL_TERM "\n") -}-sentjoin = pre_processed Sentjoin-quest1 = pre_processed Quest1-quest2 = pre_processed Quest2-quest3 = pre_processed Quest3-quest4a = pre_processed Quest4a-quest4b = pre_processed Quest4b-quest5 = pre_processed Quest5-quest6 = pre_processed Quest6+sentjoin = memoize_terminals_from_dictionary Sentjoin+quest1 = memoize_terminals_from_dictionary Quest1+quest2 = memoize_terminals_from_dictionary Quest2+quest3 = memoize_terminals_from_dictionary Quest3+quest4a = memoize_terminals_from_dictionary Quest4a+quest4b = memoize_terminals_from_dictionary Quest4b+quest5 = memoize_terminals_from_dictionary Quest5+quest6 = memoize_terminals_from_dictionary Quest6 --NEW FOR PREPOSITIONAL PHRASES-prep = pre_processed Prepn-year = pre_processed Year+prep = memoize_terminals_from_dictionary Prepn+prepnph = memoize_terminals_from_dictionary Prepnph+year = memoize_terminals_from_dictionary Year -pre_processed key- = let formAlts altTerminals = memoize key (altTerminals)- formTerminal [x] = x- formTerminal (x:xs) = x <|> formTerminal xs- list_of_ters = [ terminal (term a) z- | (a,b,z) <- dictionary- , b == key]- in formAlts (formTerminal list_of_ters)+memoize_terminals_from_dictionary key+ = let key_words = filter (\(_,type',_) -> type' == key) dictionary+ list_of_terms = map (\(a, _, z) -> terminal a z) key_words+ altTerminals = foldr1 (<|>) list_of_terms+ in memoize key altTerminals meaning_of p dInp key- = let dInput = words dInp- appParser = unState (p T0 [] ((1,[]), dInput) ([],[])) []- upperBound = (length dInput) + 1+ = let dInput = T.words dInp+ appParser = runState (p T0 [] ((1,[]), dInput) ([],[])) []+ upperBound = (List.length dInput) + 1 in formFinal key upperBound (snd $ appParser) meaning_of_ p dInp key- = let dInput = words dInp- appParser = unState (p T0 [] ((1,[]), dInput) ([],[])) []- upperBound = (length dInput) + 1+ = let dInput = T.words dInp+ appParser = runState (p T0 [] ((1,[]), dInput) ([],[])) []+ upperBound = (List.length dInput) + 1 in (snd $ appParser) formAtts key ePoint t- = concat $ concat $ concat $ concat+ = List.concat $ List.concat $ List.concat $ List.concat [[[[ val1 |(id1,val1)<-synAtts] |(((st,inAtt2),(end,synAtts)), ts)<-rs, st == 1 && end == ePoint] |((i,inAt1),((cs,ct),rs)) <- sr ] |(s,sr) <- t, s == key ] formFinal key ePoint t- = concat $ concat $ concat $ concat+ = List.concat $ List.concat $ List.concat $ List.concat [[[[ val1 |(id1,val1)<-synAtts] |(((st,inAtt2),(end,synAtts)), ts)<-rs, st == 1 && end == ePoint] |((i,inAt1),((cs,ct),rs)) <- sr ] |(s,sr) <- t, s == key ] {--test p = unState (p ((1,[]),input) ([],[])) []+test p = runState (p ((1,[]),input) ([],[])) [] main = do putStr $ render80 $ formatAtts Question $ snd $ test (question T0 []) @@ -436,7 +604,7 @@ ---------------------------------------------------------------------------------- {-- public <transvbph> = <transvb>+ public <transvbph> = <transvb> | <transvb> <preps> | <transvb> <jointermph> | <transvb> <jointermph> <preps>@@ -503,6 +671,10 @@ (parser (nt prep S1 *> nt jointermph S2) [rule_s PREPPH_VAL OF LHS ISEQUALTO applyprepph [synthesized PREPN_VAL OF S1, synthesized TERMPH_VAL OF S2]]+ <|>+ parser (nt prepnph S1 *> nt verbph S2)+ [rule_s PREPPH_VAL OF LHS ISEQUALTO applyprepph_nph [synthesized PREPNPH_VAL OF S1,+ synthesized VERBPH_VAL OF S2]] ) ----------------------------------------------------------------------------------@@ -588,7 +760,7 @@ ) ------------------------------------------------------------------------------------ {-- public <question> = <quest1> <sent>+ public <question> = <quest1> <sent> | <quest6> <quest1> <sent> | <quest5> <quest1> <sent> | <quest2> <joinvbph>@@ -607,20 +779,31 @@ [rule_s QUEST_VAL OF LHS ISEQUALTO ans1 [synthesized QUEST1_VAL OF S1, synthesized SENT_VAL OF S2]] <|>- parser (nt quest6 S1 *> nt quest1 S2 *> nt sent S3 )+ --(how|when|where|who) DID jointermph discover+ parser (nt quest5 S1 *> nt quest1 S2 *> nt sent S3 ) [rule_s QUEST_VAL OF LHS ISEQUALTO ans5 [synthesized QUEST2_VAL OF S1, synthesized QUEST1_VAL OF S2, synthesized SENT_VAL OF S3]]+ <|> --whatobj case -- special because needs lookup in AST+ parser (nt quest6 S1 *> nt quest1 S2 *> nt sent S3 )+ [rule_s QUEST_VAL OF LHS ISEQUALTO ans6 [synthesized QUEST6_VAL OF S1,+ synthesized QUEST1_VAL OF S2,+ synthesized SENT_VAL OF S3]] <|>- parser (nt quest5 S1 *> nt quest1 S2 *> nt sent S3 )+ {-parser (nt quest7 S1 *> nt quest1 S2 *> nt sent S3 ) [rule_s QUEST_VAL OF LHS ISEQUALTO ans5 [synthesized QUEST2_VAL OF S1, synthesized QUEST1_VAL OF S2, synthesized SENT_VAL OF S3]]- <|>+ <|>-}+ --(whatsubj|who|how|when|where) [WAS] [tmph] discovered ... parser (nt quest2 S1 *> nt joinvbph S2) [rule_s QUEST_VAL OF LHS ISEQUALTO ans2 [synthesized QUEST2_VAL OF S1, synthesized VERBPH_VAL OF S2]] <|>+ {-parser (nt quest7 S1 *> nt joinvbph S2)+ [rule_s QUEST_VAL OF LHS ISEQUALTO ans2 [synthesized QUEST2_VAL OF S1,+ synthesized VERBPH_VAL OF S2]] + <|> -} parser (nt quest5 S1 *> nt joinvbph S2) [rule_s QUEST_VAL OF LHS ISEQUALTO ans2 [synthesized QUEST2_VAL OF S1, synthesized VERBPH_VAL OF S2]]@@ -669,13 +852,13 @@ -- copy [b] = \(atts,i) -> head (b atts i) intrsct1 [x, y]- = \atts -> NOUNCLA_VAL (liftM2 intersect_fdbr (getAtts getAVALS atts x) (getAtts getAVALS atts y))+ = \atts -> NOUNCLA_VAL (intersect_fdbr <<*>> (getAtts getAVALS atts x) <<*>> (getAtts getAVALS atts y)) intrsct2 [x, y]- = \atts -> ADJ_VAL (liftM2 intersect_fdbr (getAtts getAVALS atts x) (getAtts getAVALS atts y))+ = \atts -> ADJ_VAL (intersect_fdbr <<*>> (getAtts getAVALS atts x) <<*>> (getAtts getAVALS atts y)) applydet [x, y]- = \atts -> TERMPH_VAL $ (getAtts getDVAL atts x) (getAtts getAVALS atts y)+ = \atts -> TERMPH_VAL $ (getAtts getDVAL atts x) <<*>> (getAtts getAVALS atts y) --make_trans_vb is very similar to make_trans_active. getBR must mean "get binary relation" --getTVAL must mean "get predicate" i.e. what would be "phobos" in "discover phobos"@@ -685,28 +868,30 @@ --nearly identical --NEW FOR PREPOSITIONAL PHRASES-applytransvbprep [x,y,z] atts = VERBPH_VAL $ make_trans_active' dataStore reln ((["object"],predicate):preps)+applytransvbprep [x,y,z] atts = VERBPH_VAL $ make_trans_active' reln <<*>> gatherPreps ((make_prep [object] <<*>> predicate) : preps) where reln = getAtts getBR atts x predicate = getAtts getTVAL atts y preps = getAtts getPREPVAL atts z+ (_, object) = getVoiceProps ActiveVoice reln -applytransvbprep [x,y] atts = VERBPH_VAL $ make_trans_active' dataStore reln [(["object"],predicate)]+applytransvbprep [x,y] atts = VERBPH_VAL $ make_trans_active' reln <<*>> gatherPreps [make_prep [object] <<*>> predicate] where reln = getAtts getBR atts x predicate = getAtts getTVAL atts y+ (_, object) = getVoiceProps ActiveVoice reln -applytransvb_no_tmph [x,y] atts = VERBPH_VAL $ make_trans_active' dataStore reln preps+applytransvb_no_tmph [x,y] atts = VERBPH_VAL $ make_trans_active' reln <<*>> gatherPreps preps where reln = getAtts getBR atts x preps = getAtts getPREPVAL atts y -applytransvb_no_tmph [x] atts = VERBPH_VAL $ make_trans_active' dataStore reln []+applytransvb_no_tmph [x] atts = VERBPH_VAL $ make_trans_active' reln <<*>> gatherPreps [] where reln = getAtts getBR atts x --TODO: modify grammar so you can't ask "what was phobos discover", or if you can, make the answer sensible (e.g. hall, not phobos)-apply_quest_transvb_passive (x2:x3:x4:xs) atts = VERBPH_VAL $ termph $ make_trans_passive' dataStore reln preps+apply_quest_transvb_passive (x2:x3:x4:xs) atts = VERBPH_VAL $ termph <<*>> (make_trans_passive reln <<*>> gatherPreps preps) where linkingvb = getAtts getLINKVAL atts x2 termph = getAtts getTVAL atts x3@@ -719,16 +904,22 @@ = \atts -> PREPPH_VAL $ let prep_names = getAtts getPREPNVAL atts x termph = getAtts getTVAL atts y in- (prep_names, termph)+ make_prep prep_names <<*>> termph +applyprepph_nph [x, y]+ = \atts -> PREPPH_VAL $+ let prep_names = getAtts getPREPNPHVAL atts x+ nph = getAtts getAVALS atts y in+ make_prep_nph prep_names <<*>> nph+ applyprep [x]- = \atts -> PREP_VAL $ [(getAtts getPREPPHVAL atts x)] --[(["with_implement"], a telescope)]+ = \atts -> PREP_VAL $ [(getAtts getPREPPHVAL atts x)] --[(["with_implement"], a telescope)] applypreps [x, y]- = \atts -> PREP_VAL $ (getAtts getPREPPHVAL atts x):(getAtts getPREPVAL atts y)+ = \atts -> PREP_VAL $ (getAtts getPREPPHVAL atts x) : (getAtts getPREPVAL atts y) applyyear [x]- = \atts -> TERMPH_VAL $ make_pnoun $ show $ getAtts getYEARVAL atts x+ = \atts -> TERMPH_VAL $ make_pnoun $ tshow $ getAtts getYEARVAL atts x --END PREPOSITIONAL PHRASES @@ -736,19 +927,19 @@ = \atts -> VERBPH_VAL (getAtts getAVALS atts z) appjoin1 [x, y, z]- = \atts -> TERMPH_VAL $ (getAtts getTJVAL atts y) (getAtts getTVAL atts x) (getAtts getTVAL atts z)+ = \atts -> TERMPH_VAL $ (getAtts getTJVAL atts y) <<*>> (getAtts getTVAL atts x) <<*>> (getAtts getTVAL atts z) appjoin2 [x, y, z]- = \atts -> VERBPH_VAL ((getAtts getVJVAL atts y) (getAtts getAVALS atts x) (getAtts getAVALS atts z))+ = \atts -> VERBPH_VAL ((getAtts getVJVAL atts y) <<*>> (getAtts getAVALS atts x) <<*>> (getAtts getAVALS atts z)) apply_middle1 [x, y, z]- = \atts -> NOUNCLA_VAL ((getAtts getRELVAL atts y) (getAtts getAVALS atts x) (getAtts getAVALS atts z))+ = \atts -> NOUNCLA_VAL ((getAtts getRELVAL atts y) <<*>> (getAtts getAVALS atts x) <<*>> (getAtts getAVALS atts z)) apply_middle2 [x, y, z]- = \atts -> NOUNCLA_VAL ((getAtts getNJVAL atts y) (getAtts getAVALS atts x) (getAtts getAVALS atts z))+ = \atts -> NOUNCLA_VAL ((getAtts getNJVAL atts y) <<*>> (getAtts getAVALS atts x) <<*>> (getAtts getAVALS atts z)) apply_middle3 [x, y, z]- = \atts -> NOUNCLA_VAL ((getAtts getRELVAL atts y) (getAtts getAVALS atts x) (getAtts getAVALS atts z))+ = \atts -> NOUNCLA_VAL ((getAtts getRELVAL atts y) <<*>> (getAtts getAVALS atts x) <<*>> (getAtts getAVALS atts z)) -- Think "a orbited by b" vs "b orbits a" {-drop3rd [w, x, y, z]@@ -758,36 +949,39 @@ make_inverted_relation dataStore reln predicate-} --NEW FOR PREPOSITIONAL PHRASES-drop3rdprep (w:x:xs) atts = VERBPH_VAL $ make_trans_passive' dataStore reln preps+drop3rdprep (w:x:xs) atts = VERBPH_VAL $ make_trans_passive reln <<*>> gatherPreps preps where reln = getAtts getBR atts x preps = case xs of- [] -> []- (p:ps) -> getAtts getPREPVAL atts p+ [] -> []+ (p:_) -> getAtts getPREPVAL atts p --END PREPOSITIONAL PHRASES apply_termphrase [x, y]- = \atts -> SENT_VAL ((getAtts getTVAL atts x) (getAtts getAVALS atts y))+ = \atts -> SENT_VAL ((getAtts getTVAL atts x) <<*>> (getAtts getAVALS atts y)) sent_val_comp [s1, f, s2]- = \atts -> SENT_VAL ((getAtts getSJVAL atts f) (getAtts getSV atts s1) (getAtts getSV atts s2))+ = \atts -> SENT_VAL ((getAtts getSJVAL atts f) <<*>> (getAtts getSV atts s1) <<*>> (getAtts getSV atts s2)) ans1 [x, y]- = \atts -> QUEST_VAL ((getAtts getQU1VAL atts x) (getAtts getSV atts y) )+ = \atts -> QUEST_VAL ((getAtts getQU1VAL atts x) <<*>> (getAtts getSV atts y) ) ans2 [x, y]- = \atts -> QUEST_VAL ((getAtts getQU2VAL atts x) (getAtts getAVALS atts y))+ = \atts -> QUEST_VAL ((getAtts getQU2VAL atts x) <<*>> (getAtts getAVALS atts y)) ans3 [x, y, z]- = \atts -> QUEST_VAL ((getAtts getQU3VAL atts x) (getAtts getAVALS atts y) (getAtts getAVALS atts z))+ = \atts -> QUEST_VAL ((getAtts getQU3VAL atts x) <<*>> (getAtts getAVALS atts y) <<*>> (getAtts getAVALS atts z)) ans5 [x, y, z]- = \atts -> QUEST_VAL ((getAtts getQU2VAL atts x) (getAtts getSV atts z))+ = \atts -> QUEST_VAL ((getAtts getQU2VAL atts x) <<*>> (getAtts getSV atts z)) +ans6 [x, y, z]+ = \atts -> QUEST_VAL ((getAtts getQU6VAL atts x) (getAtts getSV atts z))+++ truefalse [x]- = \atts -> QUEST_VAL $ do- bool <- (getAtts getSV atts x)- return $ if bool /= [] then "true." else "false."+ = \atts -> QUEST_VAL $ fmap (\fdbr -> if not (List.null fdbr) then "true." else "false.") `first` (getAtts getSV atts x) {- ||-----------------------------------------------------------------------------@@ -828,36 +1022,41 @@ <Termphjoin> = and | or; -<Quest6> = what;+<Quest6> = whatobj; <Intransvb> = exist | exists | spin | spins; -} +discover_rel = ("discover_ev","subject","object")+orbit_rel = ("orbit_ev", "subject", "object")+use_rel = ("discover_ev", "subject", "with_implement")++dictionary :: [(T.Text, MemoL, [AttValue])] dictionary = [- ("thing", Cnoun, [NOUNCLA_VAL $ get_members dataStore "thing"]),- ("things", Cnoun, [NOUNCLA_VAL $ get_members dataStore "thing"]),- ("planets", Cnoun, [NOUNCLA_VAL $ get_members dataStore "planet"]),- ("planet", Cnoun, [NOUNCLA_VAL $ get_members dataStore "planet"]),- ("person", Cnoun, [NOUNCLA_VAL $ get_members dataStore "person"]),- ("sun", Cnoun, [NOUNCLA_VAL $ get_members dataStore "sun"]),- ("moon", Cnoun, [NOUNCLA_VAL $ get_members dataStore "moon"]),- ("moons", Cnoun, [NOUNCLA_VAL $ get_members dataStore "moon"]),- ("satellite", Cnoun, [NOUNCLA_VAL $ get_members dataStore "moon"]),- ("satellites", Cnoun, [NOUNCLA_VAL $ get_members dataStore "moon"]),- ("atmospheric", Adj, [ADJ_VAL $ get_members dataStore "atmospheric"]),- ("blue", Adj, [ADJ_VAL $ get_members dataStore "blue"]),- ("solid", Adj, [ADJ_VAL $ get_members dataStore "solid"]),- ("brown", Adj, [ADJ_VAL $ get_members dataStore "brown"]),- ("gaseous", Adj, [ADJ_VAL $ get_members dataStore "gaseous"]),- ("green", Adj, [ADJ_VAL $ get_members dataStore "green"]),- ("red", Adj, [ADJ_VAL $ get_members dataStore "red"]),- ("ringed", Adj, [ADJ_VAL $ get_members dataStore "ringed"]),- ("vacuumous", Adj, [ADJ_VAL $ get_members dataStore "vacuumous"]),- ("exist", Intransvb, [VERBPH_VAL $ get_members dataStore "thing"]),- ("exists", Intransvb, [VERBPH_VAL $ get_members dataStore "thing"]),- ("spin", Intransvb, [VERBPH_VAL $ get_members dataStore "spin"]),- ("spins", Intransvb, [VERBPH_VAL $ get_members dataStore "spin"]),+ ("thing", Cnoun, [NOUNCLA_VAL $ get_members "thing"]),+ ("things", Cnoun, [NOUNCLA_VAL $ get_members "thing"]),+ ("planets", Cnoun, [NOUNCLA_VAL $ get_members "planet"]),+ ("planet", Cnoun, [NOUNCLA_VAL $ get_members "planet"]),+ ("person", Cnoun, [NOUNCLA_VAL $ get_members "person"]),+ ("sun", Cnoun, [NOUNCLA_VAL $ get_members "sun"]),+ ("moon", Cnoun, [NOUNCLA_VAL $ get_members "moon"]),+ ("moons", Cnoun, [NOUNCLA_VAL $ get_members "moon"]),+ ("satellite", Cnoun, [NOUNCLA_VAL $ get_members "moon"]),+ ("satellites", Cnoun, [NOUNCLA_VAL $ get_members "moon"]),+ ("atmospheric", Adj, [ADJ_VAL $ get_members "atmospheric"]),+ ("blue", Adj, [ADJ_VAL $ get_members "blue"]),+ ("solid", Adj, [ADJ_VAL $ get_members "solid"]),+ ("brown", Adj, [ADJ_VAL $ get_members "brown"]),+ ("gaseous", Adj, [ADJ_VAL $ get_members "gaseous"]),+ ("green", Adj, [ADJ_VAL $ get_members "green"]),+ ("red", Adj, [ADJ_VAL $ get_members "red"]),+ ("ringed", Adj, [ADJ_VAL $ get_members "ringed"]),+ ("vacuumous", Adj, [ADJ_VAL $ get_members "vacuumous"]),+ ("exist", Intransvb, [VERBPH_VAL $ get_members "thing"]),+ ("exists", Intransvb, [VERBPH_VAL $ get_members "thing"]),+ ("spin", Intransvb, [VERBPH_VAL $ get_members "spin"]),+ ("spins", Intransvb, [VERBPH_VAL $ get_members "spin"]), ("the", Det, [DET_VAL $ the]), ("a", Det, [DET_VAL $ a]), ("one", Det, [DET_VAL $ one]),@@ -932,16 +1131,19 @@ ("umbriel", Pnoun, [TERMPH_VAL $ make_pnoun "umbriel"]), ("uranus", Pnoun, [TERMPH_VAL $ make_pnoun "uranus"]), ("venus", Pnoun, [TERMPH_VAL $ make_pnoun "venus"]),- ("discover", Transvb, [VERB_VAL ("discover_ev")]),- ("discovers", Transvb, [VERB_VAL ("discover_ev")]),- ("discovered", Transvb, [VERB_VAL ("discover_ev")]),- ("orbit", Transvb, [VERB_VAL ("orbit_ev")]),- ("orbited", Transvb, [VERB_VAL ("orbit_ev")]),- ("orbits", Transvb, [VERB_VAL ("orbit_ev")]),- ("is", Linkingvb, [LINKINGVB_VAL id]),- ("was", Linkingvb, [LINKINGVB_VAL id]),- ("are", Linkingvb, [LINKINGVB_VAL id]),- ("were", Linkingvb, [LINKINGVB_VAL id]),+ ("discover", Transvb, [VERB_VAL discover_rel]),+ ("discovers", Transvb, [VERB_VAL discover_rel]),+ ("discovered", Transvb, [VERB_VAL discover_rel]),+ ("orbit", Transvb, [VERB_VAL orbit_rel]),+ ("orbited", Transvb, [VERB_VAL orbit_rel]),+ ("orbits", Transvb, [VERB_VAL orbit_rel]),+ ("use", Transvb, [VERB_VAL use_rel]),+ ("used", Transvb, [VERB_VAL use_rel]),+ ("uses", Transvb, [VERB_VAL use_rel]),+ ("is", Linkingvb, [LINKINGVB_VAL $ bipure (liftA id) id]),+ ("was", Linkingvb, [LINKINGVB_VAL $ bipure (liftA id) id]),+ ("are", Linkingvb, [LINKINGVB_VAL $ bipure (liftA id) id]),+ ("were", Linkingvb, [LINKINGVB_VAL $ bipure (liftA id) id]), ("that", Relpron, [RELPRON_VAL $ that]), ("who", Relpron, [RELPRON_VAL $ that]), ("which", Relpron, [RELPRON_VAL $ that]),@@ -959,9 +1161,9 @@ --("was", Quest1, [QUEST1_VAL $ yesno]), --("are", Quest1, [QUEST1_VAL $ yesno]), --("were", Quest1, [QUEST1_VAL $ yesno]),- ("what", Quest2, [QUEST2_VAL $ what]),- ("who", Quest2, [QUEST2_VAL $ who]),- ("what", Quest6, [QUEST2_VAL $ whatobj]),+ ("what", Quest2, [QUEST2_VAL $ what]), + ("what", Quest6, [QUEST6_VAL $ whatobj]),+ ("who", Quest5, [QUEST2_VAL $ who]), ("where", Quest5, [QUEST2_VAL $ where']), ("when", Quest5, [QUEST2_VAL $ when']), ("how", Quest5, [QUEST2_VAL $ how']),@@ -970,12 +1172,12 @@ ("how", Quest4a, [QUEST3_VAL $ how_many]), ("many", Quest4b, [QUEST3_VAL $ how_many]), ("human", Cnoun, meaning_of nouncla "person" Nouncla),- ("discoverer", Cnoun, [NOUNCLA_VAL $ get_subjs_of_event_type dataStore "discover_ev"]),- ("discoverers", Cnoun, [NOUNCLA_VAL $ get_subjs_of_event_type dataStore "discover_ev"]),+ ("discoverer", Cnoun, [NOUNCLA_VAL $ get_subjs_of_event_type "discover_ev"]),+ ("discoverers", Cnoun, [NOUNCLA_VAL $ get_subjs_of_event_type "discover_ev"]), ("humans", Cnoun, meaning_of nouncla "person" Nouncla), ("people", Cnoun, meaning_of nouncla "person" Nouncla),- --("orbit", Intransvb, [VERBPH_VAL $ get_subjs_of_event_type dataStore "orbit_ev"]),- --("orbits", Intransvb, [VERBPH_VAL $ get_subjs_of_event_type dataStore "orbit_ev"]),+ --("orbit", Intransvb, [VERBPH_VAL $ get_subjs_of_event_type "orbit_ev"]),+ --("orbits", Intransvb, [VERBPH_VAL $ get_subjs_of_event_type "orbit_ev"]), ("anyone", Indefpron,meaning_of detph "a person" Detph), ("anything", Indefpron,meaning_of detph "a thing" Detph), ("anybody", Indefpron,meaning_of detph "a person" Detph),@@ -989,12 +1191,14 @@ --("noone", Indefpron,meaning_of detph "no person" Detph), --Begin prepositional stuff-- ("with", Prepn, [PREPN_VAL ["with_implement"]]),+ ("using", Prepn, [PREPN_VAL ["with_implement"]]), ("in", Prepn, [PREPN_VAL ["location","year"]]), ("at", Prepn, [PREPN_VAL ["location"]]), ("by", Prepn, [PREPN_VAL ["subject"]]),+ ("to", Prepnph, [PREPNPH_VAL ["subject"]]), --Begin telescope stuff--- ("telescope", Cnoun, [NOUNCLA_VAL $ get_members dataStore "telescope"]),- ("telescopes", Cnoun, [NOUNCLA_VAL $ get_members dataStore "telescope"]),+ ("telescope", Cnoun, [NOUNCLA_VAL $ get_members "telescope"]),+ ("telescopes", Cnoun, [NOUNCLA_VAL $ get_members "telescope"]), ("cassegrain_telescope", Pnoun,[TERMPH_VAL $ make_pnoun "cassegrain_telescope"]), ("hooker_telescope", Pnoun,[TERMPH_VAL $ make_pnoun "hooker_telescope"]), ("schmidt_telescope", Pnoun,[TERMPH_VAL $ make_pnoun "schmidt_telescope"]),@@ -1020,8 +1224,8 @@ ("ground_based_telescope_3", Pnoun,[TERMPH_VAL $ make_pnoun "ground_based_telescope_3"]), ("galilean_telescope_1", Pnoun,[TERMPH_VAL $ make_pnoun "galilean_telescope_1"]), --Begin science team stuff- ("team", Cnoun, [NOUNCLA_VAL $ get_members dataStore "science_team"]),- ("teams", Cnoun, [NOUNCLA_VAL $ get_members dataStore "science_team"]),+ ("team", Cnoun, [NOUNCLA_VAL $ get_members "science_team"]),+ ("teams", Cnoun, [NOUNCLA_VAL $ get_members "science_team"]), ("voyager_science_team", Pnoun,[TERMPH_VAL $ make_pnoun "voyager_science_team"]), ("cassini_imaging_science_team", Pnoun,[TERMPH_VAL $ make_pnoun "cassini_imaging_science_team"]), ("science_team_1", Pnoun,[TERMPH_VAL $ make_pnoun "science_team_1"]),@@ -1096,14 +1300,14 @@ ("soummer", Pnoun, [TERMPH_VAL $ make_pnoun "soummer"]), ("throop", Pnoun, [TERMPH_VAL $ make_pnoun "throop"]), --Begin new spacecraft stuff--- ("spacecraft", Cnoun, [NOUNCLA_VAL $ get_members dataStore "spacecraft"]),- ("spacecrafts", Cnoun, [NOUNCLA_VAL $ get_members dataStore "spacecraft"]),+ ("spacecraft", Cnoun, [NOUNCLA_VAL $ get_members "spacecraft"]),+ ("spacecrafts", Cnoun, [NOUNCLA_VAL $ get_members "spacecraft"]), ("voyager_1", Pnoun, [TERMPH_VAL $ make_pnoun "voyager_1"]), ("voyager_2", Pnoun, [TERMPH_VAL $ make_pnoun "voyager_2"]), ("cassini", Pnoun, [TERMPH_VAL $ make_pnoun "voyager_2"]), --Begin new places stuff--- ("place", Cnoun, [NOUNCLA_VAL $ get_members dataStore "place"]),- ("places", Cnoun, [NOUNCLA_VAL $ get_members dataStore "place"]),+ ("place", Cnoun, [NOUNCLA_VAL $ get_members "place"]),+ ("places", Cnoun, [NOUNCLA_VAL $ get_members "place"]), ("mt_hopkins", Pnoun, [TERMPH_VAL $ make_pnoun "mt_hopkins"]), ("fort_davis", Pnoun, [TERMPH_VAL $ make_pnoun "fort_davis"]), ("cerro_tololo", Pnoun, [TERMPH_VAL $ make_pnoun "cerro_tololo"]),@@ -1261,18 +1465,22 @@ **this might need to be altered** -} -list_of_years = map (\n -> (show n, Year, [YEAR_VAL n])) $ concat [[1000 + x, 2000 + x] | x <- [0..999]]+list_of_years = map (\n -> (tshow n, Year, [YEAR_VAL n])) $ List.concat [[1000 + x, 2000 + x] | x <- [0..999]] ---test1 p p_ inp = do putStr $ render80 $ format{-Atts p_-} $ snd $ unState (p T0 [] ((1,[]),words inp) ([],[])) []-test p input = unState (p ((1,[]),input) ([],[])) []+--test1 p p_ inp = do putStr $ render80 $ format{-Atts p_-} $ snd $ runState (p T0 [] ((1,[]),words inp) ([],[])) []+test p input = runState (p ((1,[]),input) ([],[])) [] -parse i = formatAttsFinalAlt Question ((length (words i))+1) $ snd $ test (question T0 []) (words i)+parse i = formatAttsFinalAlt Question ((List.length $ T.words i)+1) $ snd $ test (question T0 []) (T.words i) +headParse = getQUVAL . head . parse++--formatParseIO = mapM id . map showio . parse+ findStart st ((s,ss):rest) | s == st = [(s,ss)] | otherwise = findStart st rest findStart st [] = [] -input = words i1+input = T.words i1 i1 = "which moons that were discovered by hall orbit mars" -- OK i2 = "who discovered a moon that orbits mars" -- OK
XSaiga/TypeAg2.hs view
@@ -1,8 +1,157 @@ {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+ module XSaiga.TypeAg2 where import XSaiga.Getts+import Data.Text as T hiding (map)+import XSaiga.ShowText+import Control.Arrow+import Data.Bifunctor+import Data.Biapplicative+import Data.List (nub)+--import Control.Applicative +type TF a = [Triple] -> a+data GettsTree =+ GettsNone+ | GettsMembers Text+ | GettsTP [Text] Relation [GettsTree]+ | GettsPreps [Text] [GettsTree]+ | GettsIntersect GettsTree GettsTree --representing result of intersect_fdbr (only evs from 2nd tree are kept)+ | GettsUnion GettsTree GettsTree --representing result of "union" of fdbrs. Keeps everything.+ deriving (Eq, Show)++data GettsFlatTypes =+ FGettsMembers Text+ | FGettsT [Text] Text++type FGettsMembers = Text+type FGettsT = ([Text], Text)++type GettsFlat = ([FGettsMembers], [FGettsT])++--Convert a function signature to a Getts style function+--Keeps same kind, same arity+type family Treeify x where+ --Treeify ((TF a -> b) -> c) = Treeify (TF a -> b) -> Treeify c+ --Treeify (TF a -> b) = GettsTree -> Treeify b+ Treeify (TF a) = GettsTree+ Treeify (a -> b) = Treeify a -> Treeify b+ Treeify a = GettsTree+ --Treeify _ = GettsTree<Paste>++--TODO: Abstract tree into separate datastructure as Foldable and Traversable+--It seems to me there are five layers:+{-++User layer: GettsT, GettsPrep, GettsAttachP ... these are like semantic "words"+Unparsed Tree layer: GettsSubQuery, GettsList, GettsNode ... this is like the parse tree of those "words"+Semantic (condensed) layer: Group SubQuery, List, Node, etc... into GettsTP, keeping tree+Flattened layer: Only a list of GettsMembers and a list of GettsTP (flattened tree)+Optimization layer: Knowledge to reduce queries (subsets, GettsTP of same type)++Semantic tree layer+Flattened layer++-}++--A SemFunc is really just a tuple of two functions+type SemFunc a = (a, Treeify a)+getGetts = snd+getSem = fst++--TODO: restrict arity of b (same kind as a)+semFunc :: a -> Treeify a -> SemFunc a+semFunc = bipure++--Just for presentation purposes+instance Show (TF FDBR) where+ show x = "TF FDBR"++instance Show (TF Text) where+ show x = "TF Text"++++--Unclean -- Foldable would help+--TODO: filter duplicates+--TODO: make [SemFunc a] not used with gatherPreps, apply directly to verb?+--Would avoid GettsPreps situation++flattenGetts :: GettsTree -> GettsFlat+flattenGetts GettsNone = ([],[])+flattenGetts (GettsMembers set) = ([set], [])+flattenGetts (GettsTP props (rel,_,_) sub) = merge ([], [(props, rel)]) (Prelude.concat *** Prelude.concat $ unzip $ map flattenGetts sub)+flattenGetts (GettsPreps props sub) = error "Cannot flatten preps"+flattenGetts (GettsIntersect i1 i2) = merge (flattenGetts i1) (flattenGetts i2)+flattenGetts (GettsUnion i1 i2) = merge (flattenGetts i1) (flattenGetts i2)++merge :: GettsFlat -> GettsFlat -> GettsFlat+merge (x1, y1) (x2, y2) = (x1 ++ x2, y1 ++ y2)++(>|<) :: a -> Treeify a -> SemFunc a+f >|< g = bipure f g++--Reduce GettsTree down to minimum number of queries that spans original+--it is okay if they end up pulling in more data than needed+gettsOptimize :: GettsTree -> GettsTree+gettsOptimize u = u++flatOptimize :: GettsFlat -> GettsFlat+flatOptimize (members, gettsTPs) = (nub members, dedupTP)+ where+ dedupTP = Prelude.foldr (\(props, rel) -> \optlist -> if Prelude.any (\(_, r) -> r == rel) optlist+ then map (\(p, r) -> if r == rel then (nub $ props ++ p, rel) else (p, r)) optlist+ else (props,rel):optlist) [] gettsTPs++getReducedTriplestore :: (TripleStore m) => m -> GettsFlat -> IO [Triple]+getReducedTriplestore ev_data (sets, trans) = do+ t1 <- mapM (\set -> getts_triples_members ev_data set) sets+ t2 <- mapM (\(props, rel) -> getts_triples_entevprop_type ev_data props rel) trans+ return $ Prelude.concat $ t1 ++ t2++unionerr x y = error $ "attempt to union: " ++ show x ++ " with " ++ show y --TODO: debugging++gettsIdentity f GettsNone y = y+gettsIdentity f x GettsNone = x+gettsIdentity f x y = f x y++gettsIntersect = gettsIdentity GettsIntersect++gettsApply g = g GettsNone++--TODO: make this a proper union+gettsUnion = gettsIdentity GettsUnion++--apply over the intersect_entevimages, remember evs of im2 are preserved and im1 are discarded+gettsAttachP :: T.Text -> GettsTree -> GettsTree+gettsAttachP prop (GettsIntersect x y) = GettsIntersect x (gettsAttachP prop y)+gettsAttachP prop (GettsTP props rel sub) = GettsTP (prop:props) rel sub++--cannot use sequenceA because it would look like+--with (a (telescope (by (a (person))))) instead of (with ( a telescope )), (by (a person))+gatherPreps :: [SemFunc ([T.Text], t)] -> SemFunc [([T.Text], t)]+gatherPreps preps = bipure preps_tf (GettsPreps prepNames (map snd preps))+ where+ prepNames = nub $ Prelude.concatMap fst preps_tf+ preps_tf = map fst preps++--a <<*>> moon <<*>> spins... +--PUBLIC INTERFACE (TODO)+--TODO: make_fdbr_with_prop is DANGEROUS+--Get members of named set+--get_members :: (TripleStore m) => m -> Text -> IO FDBR+--get_members = getts_members+get_members :: Text -> SemFunc (TF FDBR)+get_members set = (\r -> pure_getts_members r set) >|< GettsMembers set++--TODO: revise this for new transitive verb definition. should not assume these fields in general.+get_subjs_of_event_type :: Text -> SemFunc (TF FDBR)+get_subjs_of_event_type ev_type = (\r -> make_fdbr_with_prop (pure_getts_triples_entevprop_type r ["subject"] ev_type) "subject") >|< GettsTP ["subject"] (ev_type, "subject", "object") []+ data AttValue = VAL {getAVAL :: Int} | MaxVal {getAVAL :: Int} | SubVal {getAVAL :: Int}@@ -10,34 +159,37 @@ | Res {getRVAL :: DisplayTree} | B_OP {getB_OP :: (Int -> Int -> Int)} | U_OP {getU_OP :: (Int -> Int)} - | SENT_VAL {getSV :: IO ES}- | ErrorVal {getEVAL :: String} - | NOUNCLA_VAL {getAVALS :: IO ES} - | VERBPH_VAL {getAVALS :: IO ES} - | ADJ_VAL {getAVALS :: IO ES} - | TERMPH_VAL {getTVAL :: (IO ES -> IO ES)} - | DET_VAL {getDVAL :: (IO ES -> IO ES -> IO ES)} - | VERB_VAL {getBR :: Relation} - | RELPRON_VAL {getRELVAL :: (IO ES -> IO ES -> IO ES)} - | NOUNJOIN_VAL {getNJVAL :: (IO ES -> IO ES -> IO ES)}- | VBPHJOIN_VAL {getVJVAL :: (IO ES -> IO ES -> IO ES)} - | TERMPHJOIN_VAL {getTJVAL :: ((IO ES -> IO ES) -> (IO ES -> IO ES) -> (IO ES -> IO ES)) }- | PREP_VAL {getPREPVAL :: ([([String], IO ES -> IO ES)])} -- used in "hall discovered phobos with a telescope" as "with". - | PREPN_VAL {getPREPNVAL :: [String]} --used for mapping between prepositions and their corresponding identifiers in the database. I.e., "in" -> ["location", "year"]- | PREPPH_VAL {getPREPPHVAL :: ([String], IO ES -> IO ES)}- | LINKINGVB_VAL {getLINKVAL :: (IO ES -> IO ES)}- | SENTJOIN_VAL {getSJVAL :: (IO ES -> IO ES -> IO ES)}- | DOT_VAL {getDOTVAL :: IO String}- | QM_VAL {getQMVAL :: IO String}- | QUEST_VAL {getQUVAL :: IO String}- | QUEST1_VAL {getQU1VAL :: (IO ES -> IO String)}- | QUEST2_VAL {getQU2VAL :: (IO ES -> IO String)}- | QUEST3_VAL {getQU3VAL :: (IO ES -> IO ES -> IO String)}+ | SENT_VAL {getSV :: SemFunc (TF FDBR) }+ | ErrorVal {getEVAL :: Text} + | NOUNCLA_VAL {getAVALS :: SemFunc (TF FDBR) } + | VERBPH_VAL {getAVALS :: SemFunc (TF FDBR) } + | ADJ_VAL {getAVALS :: SemFunc (TF FDBR) } + | TERMPH_VAL {getTVAL :: SemFunc (TF FDBR -> TF FDBR)} + | DET_VAL {getDVAL :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)} + | VERB_VAL {getBR :: Relation } --stores relation, "subject" and "object". TODO: need to expand on later for "used" + | RELPRON_VAL {getRELVAL :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)} + | NOUNJOIN_VAL {getNJVAL :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)}+ | VBPHJOIN_VAL {getVJVAL :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)} + | TERMPHJOIN_VAL {getTJVAL :: SemFunc ((TF FDBR -> TF FDBR) -> (TF FDBR -> TF FDBR) -> TF FDBR -> TF FDBR) }+ | PREP_VAL {getPREPVAL :: [SemFunc ([Text], (TF FDBR -> TF FDBR))]} -- used in "hall discovered phobos with a telescope" as "with". + | PREPN_VAL {getPREPNVAL :: [Text]} --used for mapping between prepositions and their corresponding identifiers in the database. I.e., "in" -> ["location", "year"]+ | PREPNPH_VAL {getPREPNPHVAL :: [Text]}+ | PREPPH_VAL {getPREPPHVAL :: SemFunc ([Text], (TF FDBR -> TF FDBR))}+ | LINKINGVB_VAL {getLINKVAL :: SemFunc (TF FDBR -> TF FDBR)}+ | SENTJOIN_VAL {getSJVAL :: SemFunc (TF FDBR -> TF FDBR -> TF FDBR)}+ | DOT_VAL {getDOTVAL :: SemFunc (TF Text)}+ | QM_VAL {getQMVAL :: SemFunc (TF Text)}+ | QUEST_VAL {getQUVAL :: SemFunc (TF Text)}+ | QUEST1_VAL {getQU1VAL :: SemFunc (TF FDBR -> TF Text)}+ | QUEST2_VAL {getQU2VAL :: SemFunc (TF FDBR -> TF Text)}+ | QUEST6_VAL {getQU6VAL :: SemFunc (TF FDBR) -> SemFunc(TF Text)}+ | QUEST3_VAL {getQU3VAL :: SemFunc (TF FDBR -> TF FDBR -> TF Text)} | YEAR_VAL {getYEARVAL :: Int} -- | RESULT [sys_message]-data MemoL = Start | Tree | Num | Emp | ALeaf String | Expr | Op | ET- | Pnoun|Cnoun|Adj|Det|Intransvb|Transvb|Linkingvb|Relpron|Termphjoin|Verbphjoin|Nounjoin|Preps|Prepph|Prepn|Indefpron|Sentjoin|Quest1|Quest2|Quest3|Quest4a|Quest4b+--Also called a "NodeName"+data MemoL = Start | Tree | Num | Emp | ALeaf Text | Expr | Op | ET+ | Pnoun|Cnoun|Adj|Det|Intransvb|Transvb|Linkingvb|Relpron|Termphjoin|Verbphjoin|Nounjoin|Preps|Prepph|Prepn|Prepnph|Indefpron|Sentjoin|Quest1|Quest2|Quest3|Quest4a|Quest4b | Snouncla|Relnouncla|Nouncla|Adjs|Detph|Transvbph|Verbph|Termph|Jointermph|Joinvbph|Sent|Two_sent|Question|Quest4|Query|Year|Quest5|Quest6 deriving (Eq,Ord,Show) @@ -54,48 +206,44 @@ (QUEST2_VAL,getQU2VAL),(QUEST3_VAL,getQU3VAL) ] -}-type Entity = String -type ES = FDBR -- [Int]+type Entity = Text --type Bin_Rel = [(Entity,Entity)] -- [(Int, Int)]---type Relation = (ES -> Bool) -> ES-type Relation = String+--type Relation = (ES -> Bool) -> FDBR+type Relation = (Text, Text, Text) data DisplayTree = B [DisplayTree] | N Int deriving (Show, Eq) ----instance Show AttValue where--showio :: AttValue -> IO String-showio (VAL j) = return $ "VAL " ++ show j-showio (MaxVal j) = return $ "MaxVal " ++ show j-showio (SubVal j) = return $ "SubVal " ++ show j-showio (RepVal j) = return $ "RepVal " ++ show j-showio (Res j) = return $ "Tree: " ++ show j-showio (B_OP j) = return $ "B_OP"-showio (U_OP j) = return $ "U_OP"-showio (SENT_VAL j) = j >>= return . show -showio (ErrorVal j) = return j-showio (NOUNCLA_VAL j) = j >>= return . (++) "NOUNCLA_VAL " . unwords . map fst-showio (VERBPH_VAL j) = j >>= return . (++) "VERBPH_VAL " . unwords . map fst-showio (ADJ_VAL j) = j >>= return . (++) "ADJ_VAL " . unwords . map fst-showio (TERMPH_VAL j) = return "TERMPH_VAL " -showio (DET_VAL j) = return "DET_VAL " -showio (VERB_VAL j) = return $ "VERB_VAL " ++ j-showio (RELPRON_VAL j) = return "RELPRON_VAL "-showio (NOUNJOIN_VAL j) = return "NOUNJOIN_VAL "-showio (VBPHJOIN_VAL j) = return "VBPHJOIN_VAL "-showio (TERMPHJOIN_VAL j) = return "TERMPHJOIN_VAL "-showio (PREP_VAL j) = return "PREP_VAL "-showio (LINKINGVB_VAL j) = return "LINKINGVB_VAL "-showio (SENTJOIN_VAL j) = return "SENTJOIN_VAL "-showio (DOT_VAL j) = j -showio (QM_VAL j) = j -showio (QUEST_VAL j) = j -showio (QUEST1_VAL j) = return "QUEST1_VAL"-showio (QUEST2_VAL j) = return "QUEST2_VAL"-showio (QUEST3_VAL j) = return "SENTJOIN_VAL"+{-instance Show AttValue where+ show (VAL j) = "VAL " ++ show j+ show (MaxVal j) = "MaxVal " ++ show j+ show (SubVal j) = "SubVal " ++ show j+ show (RepVal j) = "RepVal " ++ show j+ show (Res j) = "Tree: " ++ show j+ show (B_OP j) = "B_OP"+ show (U_OP j) = "U_OP"+ show (SENT_VAL j) = show j+ show (ErrorVal j) = j+ show (NOUNCLA_VAL j) = "NOUNCLA_VAL " ++ unwords $ map fst j+ show (VERBPH_VAL j) = "VERBPH_VAL " ++ unwords $ map fst j+ show (ADJ_VAL j) = "ADJ_VLA " ++ unwords $ map fst j+ show (TERMPH_VAL j) = "TERMPH_VAL " + show (DET_VAL j) = "DET_VAL " + show (VERB_VAL j) = "VERB_VAL " ++ j+ show (RELPRON_VAL j) = "RELPRON_VAL "+ show (NOUNJOIN_VAL j) = "NOUNJOIN_VAL "+ show (VBPHJOIN_VAL j) = "VBPHJOIN_VAL "+ show (TERMPHJOIN_VAL j) = "TERMPHJOIN_VAL "+ show (PREP_VAL j) = "PREP_VAL "+ show (LINKINGVB_VAL j) = "LINKINGVB_VAL "+ show (SENTJOIN_VAL j) = "SENTJOIN_VAL "+ show (DOT_VAL j) = j + show (QM_VAL j) = j + show (QUEST_VAL j) = j + show (QUEST1_VAL j) = "QUEST1_VAL"+ show (QUEST2_VAL j) = "QUEST2_VAL"+ show (QUEST3_VAL j) = "SENTJOIN_VAL"-} instance Eq AttValue where (VAL j) == (VAL j') = True@@ -124,8 +272,10 @@ (QUEST1_VAL j) == (QUEST1_VAL j') = True (QUEST2_VAL j) == (QUEST2_VAL j') = True (QUEST3_VAL j) == (QUEST3_VAL j') = True+ (QUEST6_VAL j) == (QUEST6_VAL j') = True (PREP_VAL s1) == (PREP_VAL s) = True (PREPN_VAL s1) == (PREPN_VAL s) = True+ (PREPNPH_VAL s1) == (PREPNPH_VAL s) = True (PREPPH_VAL s1) == (PREPPH_VAL s) = True (YEAR_VAL s1) == (YEAR_VAL s) = True _ == _ = False@@ -175,13 +325,13 @@ setAtt (QUEST1_VAL s1) (QUEST1_VAL s) = [QUEST1_VAL s] setAtt (QUEST2_VAL s1) (QUEST2_VAL s) = [QUEST2_VAL s] setAtt (QUEST3_VAL s1) (QUEST3_VAL s) = [QUEST3_VAL s]+setAtt (QUEST6_VAL s1) (QUEST6_VAL s) = [QUEST6_VAL s] setAtt (PREP_VAL s1) (PREP_VAL s) = [PREP_VAL s] setAtt (PREPN_VAL s1) (PREPN_VAL s) = [PREPN_VAL s]+setAtt (PREPNPH_VAL s1) (PREPNPH_VAL s) = [PREPNPH_VAL s] setAtt (PREPPH_VAL s1) (PREPPH_VAL s) = [PREPPH_VAL s] setAtt (YEAR_VAL s1) (YEAR_VAL s) = [YEAR_VAL s]-- --------- *********************** --------------