commonnoun = [ ("human",meaning_of nouncla "man or woman."), ("thing",commonnoun_thing), ("man",commonnoun_man), ("woman",commonnoun_woman), ("person",meaning_of nouncla "man or woman."), ("discoverer",meaning_of nouncla "person that discovered something."), ("sun",commonnoun_sun), ("moon",commonnoun_moon), ("lune",commonnoun_moon), ("planet",commonnoun_planet), ("humans",meaning_of nouncla "man or woman."), ("things",commonnoun_thing), ("men",commonnoun_man), ("women",commonnoun_woman), ("people",meaning_of nouncla "man or woman."), ("planets",commonnoun_planet), ("moons",commonnoun_moon), ("discoverers",meaning_of nouncla "person that discovered something.")] adjective = [ ("atmospheric",adjective_atmospheric), ("blue",adjective_blue), ("brown", adjective_brown), ("gaseous",adjective_gaseous), ("green",adjective_green), ("red",adjective_red), ("ringed",adjective_ringed), ("solid",adjective_solid), ("vacuumous",adjective_vacuumous) ] intransverb = [ ("exist",intransverb_exist), ("exists",intransverb_exist), ("orbit",meaning_of verbphrase "orbit something."), ("spin",intransverb_spin), ("spins",intransverb_spin) ] determiner = [ ("the",determiner_a), ("a",determiner_a), ("an",determiner_a), ("some",determiner_a), ("any",determiner_a), ("no",determiner_none), ("every",determiner_every), ("all",determiner_every), ("one",determiner_one), ("two",determiner_two) ] indefinitepronoun = [ ("anyone",meaning_of detphrase "a person."), ("anything",meaning_of detphrase "a thing."), ("anybody",meaning_of detphrase "a person."), ("someone",meaning_of detphrase "a person."), ("something",meaning_of detphrase "a thing."), ("somebody",meaning_of detphrase "a person."), ("everyone",meaning_of detphrase "every person."), ("everything",meaning_of detphrase "every thing."), ("everybody",meaning_of detphrase "every person.") ] propernoun = [ ("Barnard", test_property_wrt 55), ("Bond", test_property_wrt 67), ("Cassini", test_property_wrt 65), ("Dollfus", test_property_wrt 63), ("Fountain", test_property_wrt 62), ("Galileo", test_property_wrt 56), ("Hall", test_property_wrt 54), ("Herschel", test_property_wrt 64), ("Huygens", test_property_wrt 66), ("Kowal", test_property_wrt 57), ("Kuiper", test_property_wrt 69), ("Larsen", test_property_wrt 61), ("Lassell", test_property_wrt 70), ("Melotte", test_property_wrt 60), ("Nicholson", test_property_wrt 59), ("Perrine", test_property_wrt 58), ("Pickering", test_property_wrt 68), ("almathea", test_property_wrt 21), ("ariel", test_property_wrt 47), ("callisto", test_property_wrt 25), ("charon", test_property_wrt 53), ("deimos", test_property_wrt 20), ("dione", test_property_wrt 40), ("earth", test_property_wrt 11), ("enceladus", test_property_wrt 38), ("europa", test_property_wrt 23), ("ganymede", test_property_wrt 24), ("hyperion", test_property_wrt 43), ("iapetus", test_property_wrt 44), ("io", test_property_wrt 22), ("janus", test_property_wrt 36), ("jupiter", test_property_wrt 13), ("jupitereighth", test_property_wrt 32), ("jupitereleventh", test_property_wrt 31), ("jupiterfourteenth", test_property_wrt 34), ("jupiterninth", test_property_wrt 33), ("jupiterseventh", test_property_wrt 29), ("jupitersixth", test_property_wrt 27), ("jupitertenth", test_property_wrt 28), ("jupiterthirteenth", test_property_wrt 26), ("jupitertwelfth", test_property_wrt 30), ("luna", test_property_wrt 18), ("mars", test_property_wrt 12), ("mercury", test_property_wrt 9), ("mimas", test_property_wrt 37), ("miranda", test_property_wrt 46), ("neptune", test_property_wrt 16), ("nereid", test_property_wrt 52), ("oberon", test_property_wrt 50), ("phobos", test_property_wrt 19), ("phoebe", test_property_wrt 45), ("pluto", test_property_wrt 17), ("rhea", test_property_wrt 41), ("saturn", test_property_wrt 14), ("saturnfirst", test_property_wrt 35), ("sol", test_property_wrt 8), ("tethys", test_property_wrt 39), ("titan", test_property_wrt 42), ("titania", test_property_wrt 49), ("triton", test_property_wrt 51), ("umbriel", test_property_wrt 48), ("uranus", test_property_wrt 15), ("venus", test_property_wrt 10) ] transverb = [ ("discover",transverb_discover), ("discovered",transverb_discover), ("orbit",transverb_orbit), ("orbited",transverb_orbit), ("orbits",transverb_orbit) ] passtrvb = [ ("discovered",passtrvb_discovered), ("orbited",passtrvb_orbited) ] linkingverb = [ ("is",id), ("was", id), ("are", id), ("were", id) ] relpronoun = [ ("that", relpronoun_that), ("who", relpronoun_that), ("which", relpronoun_that) ] termphrasejoin = [ ("and", termphrase_and), ("or", termphrase_or) ] verbphrasejoin = [ ("and", verbphrase_and), ("or", verbphrase_or) ] nounjoin = [ ("and", noun_and), ("or", noun_or) ] preposition = [ ("by", id) ] || Entityset entityset = [8..70] || Common Noun ( Categories ) commonnoun_sun = [8] commonnoun_planet = [9..17] commonnoun_moon = [18..53] commonnoun_man = [54..70] commonnoun_woman = [] commonnoun_thing = [8..70] || Adjectives adjective_red = [12, 13, 14, 22] adjective_blue = [11, 14, 15, 16] adjective_green = [11, 15, 16] adjective_brown = [9, 10, 17] adjective_ringed = [13, 14, 15, 16] adjective_gaseous = [13, 14, 15, 16] adjective_solid = (mergeunion commonnoun_planet commonnoun_moon) -- adjective_gaseous adjective_atmospheric = [ 10, 11, 12, 22, 42 ] adjective_vacuumous = (mergeunion commonnoun_planet commonnoun_moon) -- adjective_atmospheric || Intransitive Verbs intransverb_exist = entityset intransverb_spin = [8..53] || Determiners determiner_every p q = includes q p determiner_a p q = non_empty_intersect p q determiner_none x y = #( intersect x y ) = 0 determiner_one x y = #( intersect x y ) = 1 determiner_two x y = #( intersect x y ) = 2 || Propernouns test_property_wrt e s = member s e || Transitive Verbs transverb_orbit m = [ x | (x,y) <- relation_orbit; m y ] transverb_discover m = [ x | (x,y) <- rel_discover ; m y ] passtrvb_discovered m = [ x | (x,y) <- (invert_discover); m y] passtrvb_orbited m = [ x | (x,y) <- (invert_orbit); m y] || Binary relations relation_orbit = [( 9, [8]),(10, [8]),(11, [8]),(12, [8]), (13, [8]),(14, [8]),(15, [8]),(16, [8]), (17, [8]),(18,[11]),(19,[12]),(20,[12]), (21,[13]),(22,[13]),(23,[13]),(24,[13]), (25,[13]),(26,[13]),(27,[13]),(28,[13]), (29,[13]),(30,[13]),(31,[13]),(32,[13]), (33,[13]),(34,[13]),(35,[14]),(36,[14]), (37,[14]),(38,[14]),(39,[14]),(40,[14]), (41,[14]),(42,[14]),(43,[14]),(44,[14]), (45,[14]),(46,[15]),(47,[15]),(48,[15]), (49,[15]),(50,[15]),(51,[16]),(52,[16]), (53,[17])] rel_discover = [(7,[18]),(54,[19,20]),(55,[21]),(56,[22,23,24,25]), (57,[26]),(57,[34]),(58,[27,29]),(59,[28,30,31]), (59,[33]),(60,[32]),(61,[35]),(62,[35]),(63,[36]), (64,[37,38,49,50]),(65,[39,40,41,44]),(66,[42]), (67,[43]),(68,[45]),(69,[46,52]),(70,[47,48,51]), (71,[22,23,24,25]),(72,[42]),(73,[44]),(74,[41]), (75,[39,40]),(76,[49,50]),(77,[37,38]),(78,[51]), (79,[43]),(80,[47,48]),(81,[19,20]),(82,[21]), (83,[45]),(84,[27]),(85,[29]),(86,[32]),(87,[33]), (88,[28,31]),(89,[46]),(90,[52]),(91,[30]),(92,[36]), (93,[26]),(94,[34]),(95,[35])] ||invert_orbit = invert_set relation_orbit invert_orbit = [(8,[9,10,11,12,13,14,15,16,17]),(11,[18]), (12,[19,20]), (13,[21,22,23,24,25,26,27,28,29,30,31,32,33,34]), (14,[35,36,37,38,39,40,41,42,43,44,45]), (15,[46,47,48,49,50]), (16,[51,52]),(17,[53])] ||invert_discover = invert_set rel_discover invert_discover = [(18,[7]),(19,[54,81]),(20,[54,81]), (21,[55,82]),(22,[56,71]),(23,[56,71]), (26,[57,93]),(27,[58,84]),(28,[59,88]), (29,[58,85]),(30,[59,91]), (31,[59,88]),(32,[60,86]),(33,[59,87]), (34,[57,94]),(35,[61,62,95]), (36,[63,92]),(37,[64,77]),(38,[64,77]), (39,[65,75]),(40,[65,75]), (41,[65,74]),(42,[66,72]),(43,[67,79]), (44,[65,73]),(45,[68,83]),(46,[69,89]), (47,[70,80]),(48,[70,80]),(49,[64,76]), (50,[64,76]),(51,[70,78]),(52,[69,90])] || Relative pronouns and conjunctions relpronoun_that p q = intersect p q termphrase_and p q = g where g x = (p x) & (q x) termphrase_or p q = g where g x = (p x) \/ (q x) verbphrase_and p q = intersect p q verbphrase_or p q = mergeunion p q noun_and p q = intersect p q noun_or p q = mergeunion p q || SET AND LIST OPERATORS intersect [] [] = [] intersect as [] = [] intersect [] bs = [] intersect (ha:ta) (hb:tb) = ha : intersect ta tb, ha = hb = intersect ta (hb :tb), ha < hb = intersect (ha:ta) tb, otherwise mergeunion [] [] = [] mergeunion as [] = as mergeunion [] bs = bs mergeunion (a : as) (b :bs) = a:mergeunion as bs , a = b = a:mergeunion as (b:bs), a < b = b:mergeunion (a:as) bs, otherwise invert_set list = makesets (mysort ( makepairs list )) includes [] [] = True includes [] ss = False includes ts [] = True includes (ht:tt) (hs:ts) = False, ht > hs = includes tt ts, ht = hs = includes tt (hs:ts), otherwise makepairs list = [ (y, x) | (x, zs) <- list ; y <- zs] makesets [] = [] makesets ((x, y) : t) = (x, y:[ e2 | (e1, e2) <- t; e1 = x] ) : makesets [ (e1, e2) | (e1, e2) <- t; e1 ~= x ] mysort [] = [] mysort (a:x) = insert a (sort x) where insert a [] = [a] insert a (b:x) = a:b:x, (ffst a) <= (ffst b) = b:insert a x, otherwise non_empty_intersect s t = intersect s t ~= [] || INTERPRETERS (p1 $orelse p2) inp = p1 inp ++ p2 inp (p1 $then p2) inp = [((v1,v2),inp2) | (v1,inp1) <- p1 inp; (v2,inp2) <- p2 inp1] (p $applyrule f) inp = [ (f v, r) | (v, r) <- p inp ] fail inp = [] succeed v inp = [(v,inp)] ||word (wd,val) [] = fail [] ||word (wd,val) (u:us) = succeed val us , u = wd || = fail [] ,otherwise word (wd, val) (u:us) = [(val,us)], u = wd = [], otherwise word x [] = [] mkint (p:ps) = (word p) $orelse (mkint ps) mkint [] = fail ques = word ("?",0) dot = word (".",0) meaning_of interp = hd . map ffst . ((interp $then dot) $applyrule ffst) . words || Interpreters simplenouncla = (mkint commonnoun) $orelse ((adjectivess $then (mkint commonnoun)) $applyrule intersct) relnouncla =((simplenouncla $then (mkint relpronoun) $then joinvbphrase) $applyrule reorder) $orelse simplenouncla adjectivess =(((mkint adjective) $then adjectivess) $applyrule intersct) $orelse (mkint adjective) nouncla =((relnouncla $then (mkint nounjoin) $then nouncla ) $applyrule reorder) $orelse relnouncla transvbphrase =(((mkint transverb) $then jointermphrase) $applyrule apply2) $orelse (((mkint linkingverb) $then (mkint passtrvb) $then (mkint preposition) $then jointermphrase) $applyrule drop3rd) detphrase = (mkint indefinitepronoun) $orelse (((mkint determiner) $then nouncla) $applyrule apply2) termphrase = (mkint propernoun) $orelse detphrase verbphrase = transvbphrase $orelse (mkint intransverb) $orelse (((mkint linkingverb) $then(mkint determiner) $then nouncla) $applyrule drop2nd) jointermphrase = termphrase $orelse ((termphrase $then (mkint termphrasejoin) $then jointermphrase ) $applyrule reorder) joinvbphrase = ((verbphrase $then (mkint verbphrasejoin) $then joinvbphrase) $applyrule reorder) $orelse verbphrase sentence = (jointermphrase $then joinvbphrase) $applyrule apply2 || Interpretation Rules apply2 (x,y) = x y apply3 (x,(y,z)) = x y z reorder (x,(y,z)) = y x z ffst (x,y) = x drop2nd (x,(y,z)) = x z drop3rd (w,(x,(y,z))) = w x z intersct (x,y) = intersect x y || Interactive section question = (sentence $applyrule truefalse) $orelse (((mkint doesq) $then sentence) $applyrule apply2) $orelse (((mkint quest1) $then joinvbphrase ) $applyrule apply2) $orelse (((mkint quest2) $then (nouncla $then joinvbphrase)) $applyrule apply3) truefalse x = "true", x = "false", otherwise || Question_functions doesq = [ ("does", yesno), ("do", yesno)] quest1 = [ ("who", function_whoq), ("what", function_whatq)] quest2 = [ ("which", function_whichq), ("howmany", function_howmanyq)] function_whoq xs = check "nobody" (map name_of (intersect xs (mergeunion commonnoun_man commonnoun_woman))) function_whatq xs = check "nothing" (map name_of xs) function_whichq xs ys = check "none" (map name_of (intersect xs ys)) function_howmanyq xs ys = number (# intersect xs ys) yesno b = "yes" , b = "no", otherwise || number n = ["none", "one", "two", "three", "four","five","six", || "seven", "eight", "nine", "ten", "eleven"] ! n number :: num -> [char] number n = show n name_of e = hd [name | (name, f) <- propernoun ; f [e]] check str wds = str , wds = [] = unwords wds , otherwise || Interactive session session = introduction ++ unllines (map interpret (llines (read "/dev/tty"))) ++ conclusion llines [] = [] llines (c:cs) = [] : llines cs , c = '\n' = (c : ln) : lns , otherwise where (ln : lns) = llines cs, cs ~= [] = [] : [] , otherwise unllines [] = "\n" unllines (ln : lns) = ln ++ "\n" ++ (unllines lns) introduction = "Hello . Please ask me some questions.\n" ++ "such as who discovered phobos?\n" conclusion = "\n\nGoodbye. . .\n\n" || Handling a single question interpret = disambiguate . map ffst . ((question $then ques) $applyrule ffst) . words . (++ "?") disambiguate [] = "I do not understand" disambiguate [ans] = ans disambiguate answers = "The question is ambiguous. The possible answers are" ++ concat (map newans answers) where newans a = "\n * " ++ a words [] = [] words (c : cs)= [] : words cs , c = ' ' = [] : [c] : words cs , (c = '.') \/ (c = '?') = (c : ln) : lns , otherwise where (ln : lns) = words cs unwords [x] = x ++ "." unwords [x, y] = x ++ ", and " ++ y ++ "." unwords (x : xs) = x ++ ",\n" ++ (unwords xs)