Commits

Sébastien Ferré  committed 41337e7

Handling of question words moved from [syntax] to [semantics].

  • Participants
  • Parent commits 94a72d8

Comments (0)

Files changed (3)

File semantics.ml

   | `Not f1 -> f1
   | f1 -> `Not f1
 
-let bool0 =
+let bool =
   object (self)
-    method id s args g mode = s args g mode
-    method func op la res args g mode = `Func (op,la,res)
-    method maybe_ s args g mode = `Option (s args g mode)
-    method or_ ls args g mode = `Or (List.map (fun s -> s args g mode) ls)
-    method and_ ls args g mode = and_ (List.map (fun s -> s args g mode) ls)
-    method not_ s args g mode = not_ (s args g mode)
-    method true_ args g mode = `True
-    method exists lv s args g mode =
+    method id f = f
+    method func op la res = `Func (op,la,res)
+    method maybe_ f = `Option f
+    method or_ lf = `Or lf
+    method and_ lf = and_ lf
+    method not_ f = not_ f
+    method true_ = `True
+    method exists lv f =
       if lv = []
-      then s args g mode
-      else and_ [`Exists (lv,`True); s args g mode]
-    method forall lv s1 s2 args g mode =
-      let f1 =
-	if lv = []
-	then s1 args g `Interrogative
-	else and_ [`Exists (lv, `True); s1 args g `Interrogative] in
-      let f2 = s2 args g mode in
+      then f
+      else merge [`Exists (lv,`True); f]
+    method forall lv f1 f2 =
+      let f1 = self#exists lv f1 in
       match f2 with
       | `Forall (f21,f22) ->
 	  ( match merge_bin f1 f21 with
 	  | Some f121 -> `Forall (f121,f22)
 	  | None -> `Forall (f1,f2) )
-      | f2 -> `Forall (f1,f2)
-    method the lv s1 s2 args g mode =
-      match mode with
-      | `Interrogative -> self#exists lv (self#and_ [s1;s2]) args g mode
-      | `Affirmative -> self#forall lv s1 s2 args g mode
+      | _ -> `Forall (f1,f2)
+
+  end
+
+
+let bool0 =
+  object (self)
+    method private merge_xs_opt l =
+      List.fold_right
+	(fun xs_opt res ->
+	  match xs_opt, res with
+	  | None, _ -> res
+	  | _, None -> xs_opt
+	  | Some xs1, Some xs2 -> Some (xs1@xs2))
+	l None
+    method return f =
+      None, (fun args g mode -> f)
+    method apply (xs_opt,s) transf =
+      xs_opt, (fun args g mode -> transf (s args g mode))
+    method apply_list la transf =
+      let lxs_opt, ls = List.split la in
+      self#merge_xs_opt lxs_opt, (fun args g mode -> transf (List.map (fun s -> s args g mode) ls))
+    method map (xs_opt,s) transf =
+      xs_opt, (fun args g mode -> transf (s args g mode))
+
+    method id xss = self#map xss bool#id
+    method func op la res = self#return (bool#func op la res)
+    method maybe_ xss = self#apply xss bool#maybe_
+    method or_ lxss = self#apply_list lxss bool#or_
+    method and_ lxss = self#apply_list lxss bool#and_
+    method not_ xss = self#apply xss bool#not_
+    method true_ = self#return bool#true_
+    method exists lv xss = self#apply xss (bool#exists lv)
+    method forall lv (xs_opt1,s1) (xs_opt2,s2) =
+      self#merge_xs_opt [xs_opt1; xs_opt2],
+      (fun args g mode ->
+	bool#forall lv (s1 args g `Interrogative) (s2 args g mode))
+    method the lv (xs_opt1,s1) (xs_opt2,s2) =
+      self#merge_xs_opt [xs_opt1; xs_opt2],
+      (fun args g mode ->
+	match mode with
+	| `Interrogative -> bool#exists lv (bool#and_ [s1 args g mode; s2 args g mode])
+	| `Affirmative -> bool#forall lv (s1 args g `Interrogative) (s2 args g mode))
+    method whether (xs_opt,s) =
+      self#merge_xs_opt [Some []; xs_opt],
+      s
+    method which x (xs_opt1,s1) (xs_opt2,s2) =
+      self#merge_xs_opt [Some ([(x,s1)]); xs_opt1; xs_opt2],
+      s2
+    method select (xs_opt,s) =
+      match xs_opt with
+      | None -> s
+      | Some xs ->
+	  let lx, ls = List.split xs in
+	  (fun args g mode -> `Select (lx, bool#and_ (List.map (fun s -> s args g `Interrogative) (ls@[s]))))
+(*
+    method relativize (xs_opt,s) =
+      match xs_opt with
+      | None
+      | Some [] -> failwith "not a relative"
+      | Some ((x1,_s1)::xs) ->
+	  (fun x ->
+	    (if xs = [] then None else Some xs),
+	    (fun args g mode -> bool#and_ [`Unify (x,x1); s args g mode]))
+*)
   end
 
 let bool1 =
     method the lv r1 r2 x y = bool0#the lv (r1 x y) (r2 x y)
   end
 
-let close s mode = s [] (fun t -> `True) mode
-let init d x args g mode = d x [] g mode
-let arg uri z s args g mode = s ((uri,z)::args) g mode
+(* let close s mode = s [] (fun t -> `True) mode *)
+let init d x =
+  let xs_opt, s = d x in
+  xs_opt, (fun args g mode -> s [] g mode)
+let arg uri z (xs_opt,s) =
+  xs_opt,
+  (fun args g mode -> s ((uri,z)::args) g mode)
 
 (* pseudo predicates and prepositions *)
 let pseudo_p1_belongs = "belongs"
 let nil = Uri "rdf:nil"
 let cons x l = Cons (x,l)
 
-let stat t s p o args g mode =
-  let s, p, o, args =
-    if p = Uri "rdf:type" && o = Uri pseudo_p1_belongs then
-      if List.mem_assoc pseudo_prep_to args
-      then s, Uri "rdf:type", List.assoc pseudo_prep_to args, List.remove_assoc pseudo_prep_to args
-      else failwith "'belong(s)' expects a complement introduced by 'to'"
-    else if p = Uri pseudo_p2_relates then
-      if List.mem_assoc pseudo_prep_to args
-      then o, s, List.assoc pseudo_prep_to args, List.remove_assoc pseudo_prep_to args
-      else failwith "'relate(s)' expects a complement introduced by 'to'"
-    else s, p, o, args in
-  (try 
-    let prep = List.find (fun prep -> List.mem_assoc prep args) list_pseudo_prep in
-    failwith ("unexpected preposition '" ^ prep ^ "'")
-  with _ -> ());
-  match args, g t with
-  | [], `True -> `Triple (s,p,o)
-  | args, fg ->
-      and_ (`Exists ([t], `True) ::
-	    fg ::
-	    List.map
-	      (fun (uri,z) -> `Triple (t,Uri uri,z))
-	      (("rdf:subject",s)::("rdf:predicate",p)::("rdf:object",o)::args))
-let triple s p o args g mode = `Triple (s,p,o)
+let stat t s p o =
+  None,
+  (fun args g mode ->
+    let s, p, o, args =
+      if p = Uri "rdf:type" && o = Uri pseudo_p1_belongs then
+	if List.mem_assoc pseudo_prep_to args
+	then s, Uri "rdf:type", List.assoc pseudo_prep_to args, List.remove_assoc pseudo_prep_to args
+	else failwith "'belong(s)' expects a complement introduced by 'to'"
+      else if p = Uri pseudo_p2_relates then
+	if List.mem_assoc pseudo_prep_to args
+	then o, s, List.assoc pseudo_prep_to args, List.remove_assoc pseudo_prep_to args
+	else failwith "'relate(s)' expects a complement introduced by 'to'"
+      else s, p, o, args in
+    (try 
+      let prep = List.find (fun prep -> List.mem_assoc prep args) list_pseudo_prep in
+      failwith ("unexpected preposition '" ^ prep ^ "'")
+    with _ -> ());
+    match args, g t with
+    | [], `True -> `Triple (s,p,o)
+    | args, fg ->
+	and_ (`Exists ([t], `True) ::
+	      fg ::
+	      List.map
+		(fun (uri,z) -> `Triple (t,Uri uri,z))
+		(("rdf:subject",s)::("rdf:predicate",p)::("rdf:object",o)::args)))
+let triple s p o = bool0#return (`Triple (s,p,o))
 let a c t x = stat t x (Uri "rdf:type") c
 let rel p t x y = stat t x p y
-let unify x y args g mode = `Unify (x,y)
-let matches (lre : string list) x args g mode = `Matches (x,lre)
-let pred1 op x args g mode = `Pred1 (op,x)
-let pred2 op x y args g mode = `Pred2 (op,x,y)
+let unify x y = bool0#return (`Unify (x,y))
+let matches (lre : string list) x = bool0#return (`Matches (x,lre))
+let pred1 op x = bool0#return (`Pred1 (op,x))
+let pred2 op x y = bool0#return (`Pred2 (op,x,y))
 let func0 op x = bool0#func op [] x
 let func1 op x y = bool0#func op [x] y
-let proc1 op x args g mode = `Proc1 (op,x)
-let graph x s args g mode =
+let proc1 op x = bool0#return (`Proc1 (op,x))
+let graph x xss =
   let rec aux x = function
     | `Exists (xs,f1) -> `Exists (xs, aux x f1)
     | `Forall (f1,f2) -> `Forall (aux x f1, aux x f2)
     | f -> `Graph (x,f) in
-  aux x (s args g mode)
-let aggreg op lz y s x args g mode =
-  `Aggreg (op, x, y, lz, s args g `Interrogative)
+  bool0#apply xss (aux x)
+let aggreg op lz y (xs_opt,s) x =
+  xs_opt,
+  (fun args g mode -> `Aggreg (op, x, y, lz, s args g `Interrogative))
 
 let func1_id = `Id
 let pred2_eq = `Eq
 let modif_highest = `Highest
 let modif_lowest = `Lowest
 
+let whether s = bool0#whether s
+let which x d1 d2 = bool0#which x (d1 x) (d2 x)
 let exists x d = bool0#exists [x] (d x)
 let forall x d1 d2 = bool0#forall [x] (d1 x) (d2 x)
 let ifthen s1 s2 = bool0#forall [] s1 s2
 let the x d1 d2 = bool0#the [x] (d1 x) (d2 x)
 let where s1 s2 = bool0#the [] s2 s1
 let a_number y d1 d2 x = aggreg aggreg_count [] y (bool0#and_ [d1 y; d2 y]) x
-let modif op x args g mode = `Modif (op, x, `True)
+let modif op x = bool0#return (`Modif (op, x, `True))
+(* let that (xs_opt,s) d = xs_opt, (fun args g mode -> s [] (fun t -> d t args g mode) mode) *)
 
-let select xs s args g mode = `Select (xs, s args g `Interrogative)
+let select xss = bool0#select xss
 
-let tell s = close s `Affirmative
+let tell xss = select xss [] (fun t -> `True) `Affirmative
 
 (* formula analysis and validation by adding iterators on resources *)
 
 open Semantics
 
 class ['s] context =
-  object
+  object (self)
     val var_cpt = 1
     method new_var =
       Var ("x" ^ string_of_int var_cpt),
       {< sentence_start = coord >}
     method is_sentence_start coord = (coord = sentence_start)
 
-    val selects : (term list option * 's) list = []
-    method init_select =
-      {< selects = (None, bool0#true_)::selects >}
-    method add_ask =
-      {< selects =
-	 let select, selects1 = List.hd selects, List.tl selects in
-	 let xs, s = select in
-	 let xs' = match xs with None -> Some [] | Some l -> Some l in
-	 (xs',s)::selects1 >}
-    method add_select x d =
-      {< selects =
-	 let select, selects1 = List.hd selects, List.tl selects in
-	 let xs, s = select in
-	 let xs' = match xs with None -> Some [x] | Some l -> Some (l @ [x]) in
-	 let s' = bool0#and_ [s; d x] in
-	 (xs',s')::selects1 >}
-    method get_select = List.hd selects
-    method reset_select =
-      {< selects = List.tl selects >}
-
     method is_kwd coord s =
       let s = if sentence_start = coord then String.uncapitalize s else s in
       List.mem s
 let new_var = dcg "new var" [ ?ctx; v, ctx' in "new_var" [ctx#new_var]; !ctx' -> v ]
 let set_sentence_start = dcg "set sentence start" [ @cursor; ?ctx; ctx' in "new ctx" [ctx#set_sentence_start cursor#coord]; !ctx' -> () ]
 let is_sentence_start = dcg "is sentence start" [ @cursor; ?ctx; when "" ctx#is_sentence_start cursor#coord -> () ]
-let init_select = dcg [ ?ctx; !(ctx#init_select) -> () ]
-let add_ask = dcg "add ask" [ ?ctx; ctx' in "add_ask" [ctx#add_ask]; !ctx' -> () ]
-let add_select x d = dcg "add select" [ ?ctx; ctx' in "add_select" [ctx#add_select x d]; !ctx' -> () ]
-let new_var_select = dcg "new var select" [ v = new_var; _ = add_select v bool1#true_ -> v ]
-let get_select = dcg [ ?ctx; xs, s in "get_select" [ctx#get_select] -> xs, s ]
-let reset_select = dcg [ ?ctx; ctx' in "reset_select" [ctx#reset_select]; !ctx' -> () ]
 
 let parse_pred1 = dcg [ ?ctx; op = ctx#parse_pred1 -> op ]
 let parse_func0 = dcg [ ?ctx; op = ctx#parse_func0 -> op ]
 and parse_text = dcg
     [ lf = LIST1 parse_s SEP ws -> and_ lf ]
 and parse_s = dcg
-    [ _ = set_sentence_start; _ = init_select;
-      s2 = parse_s_whether; _ = parse_sentence_end;
-      xs_opt, s1 = get_select; _ = reset_select ->
-	match xs_opt with
-	| None -> tell s2
-	| Some xs -> tell (select xs (bool0#and_ [s1; s2])) ]
-and parse_sentence_end = dcg
-    [ _ = dot -> ()
-    | _ = interro; _ = add_ask -> () ]
+    [ _ = set_sentence_start; s = parse_s_whether;
+      ( _ = dot -> tell s
+      | _ = interro -> tell (whether s) ) ]
 and parse_s_whether = dcg
-    [ _ = kwd "whether"; _ = add_ask; _ = ws; s = parse_s_for -> s
+    [ _ = kwd "whether"; _ = ws; s = parse_s_for -> whether s
     | s = parse_s_for -> s ]
 and parse_s_for = dcg
     [ _ = kwd "if"; _ = ws; s1 = parse_s_for; _ = [ _ = comma -> () | _ = ws; _ = kwd "then"; _ = ws -> () ];
 and parse_s_bool = dcg
     [ s = parse_bool bool0 parse_s_atom -> s ]
 and parse_s_atom = dcg
-    [ _ = does; _ = add_ask; _ = ws; np = parse_np; _ = ws; vp = parse_vp_atom -> np vp
-    | _ = be; _ = add_ask; _ = ws; 
-      ( np = parse_np; _ = ws; vp = parse_vp_be -> np vp
-      | _ = kwd "there"; _ = ws; np = parse_np_gen parse_det_unary -> np (fun _ -> bool0#true_) )
-    | _ = have; _ = add_ask; _ = ws; np = parse_np; _ = ws; vp = parse_vp_have -> np vp
+    [ _ = does; _ = ws; np = parse_np; _ = ws; vp = parse_vp_atom -> whether (np vp)
+    | _ = be; _ = ws; 
+      ( np = parse_np; _ = ws; vp = parse_vp_be -> whether (np vp)
+      | _ = kwd "there"; _ = ws; np = parse_np_gen parse_det_unary -> whether (np (fun _ -> bool0#true_)) )
+    | _ = have; _ = ws; np = parse_np; _ = ws; vp = parse_vp_have -> whether (np vp)
     | pr1 = parse_proc1; _ = ws; op = parse_op -> op (proc1 pr1)
     | np = parse_np; _ = ws; vp = parse_vp -> np vp ]
 and parse_graph = dcg
     | patt = parse_pattern; x = new_var -> (fun d -> exists x (bool1#and_ [d; patt]))
     | b = parse_b; x = new_var -> (fun d -> exists x (bool1#and_ [b; d]))
     | det = parse_det; _ = ws; x, p1 = parse_ng1 -> (fun d -> det x (init p1) d)
-    | _ = kwd "which"; _ = ws; x, p1 = parse_ng1; _ = add_select x p1 -> (fun d -> d x)
+    | _ = kwd "which"; _ = ws; x, p1 = parse_ng1 -> (fun d -> which x (init p1) d)
     | np2 = parse_np2_gen parse_det; np = parse_p2' -> (fun d -> np (fun x -> np2 x d))
-    | _ = what; x = new_var_select -> (fun d -> d x)
-    | _ = kwd "whose"; x = new_var_select; _ = ws; y, p2 = parse_ng2 -> (fun d -> exists y (bool1#and_ [init (p2 x); d]))
-    | _ = kwd "that"; _ = ws; s = parse_s_for -> (fun d args g mode -> s [] (fun t -> d t args g mode) mode) ]
+    | _ = what; x = new_var -> (fun d -> which x bool1#true_ d)
+    | _ = kwd "whose"; x = new_var; _ = ws; y, p2 = parse_ng2 ->
+	(fun d ->
+	  which x bool1#true_ (fun x ->
+	    exists y (bool1#and_ [init (p2 x); d]))) ]
+(*    | _ = kwd "that"; _ = ws; s = parse_s_for -> (fun d -> that s d) ] *) (* deprecated *)
 and parse_np2_gen parse_det = dcg
     [ np2 = parse_bool bool2 (parse_np2_gen_expr parse_det) -> np2 ]
 and parse_np2_gen_expr parse_det = dcg
 and parse_np2_gen_atom parse_det = dcg
     [ det = parse_det; _ = ws; y, p2 = parse_ng2 ->
         (fun x d -> det y (init (p2 x)) d)
-    | _ = kwd "which"; _ = ws; y, p2 = parse_ng2; _ = add_select y bool1#true_ ->
-	(fun x d -> bool0#and_ [init (p2 x) y; d y]) ]
+    | _ = kwd "which"; _ = ws; y, p2 = parse_ng2 ->
+	(fun x d -> which y bool1#true_ (bool1#and_ [init (p2 x); d])) ]
 and parse_np_gen_term parse_det = dcg "np_term"
     [ v = parse_var -> (fun d -> d (Var v))
     | s = parse_literal -> (fun d -> d (Literal s))
 	(fun y d1 d2 -> exists x (bool1#and_ [a_number y d1 d2; pred2 pred2_gt n]))
     | _ = kwd "between"; _ = ws; n1 = parse_literal_nat; _ = ws; _ = kwd "and"; _ = ws; n2 = parse_literal_nat; x = new_var ->
 	(fun y d1 d2 -> exists x (bool1#and_ [a_number y d1 d2; pred2 pred2_leq n1; pred2 pred2_geq n2]))
-    | _ = kwd "how"; _ = ws; _ = kwd "many"; x = new_var_select ->
-	(fun y d1 d2 -> a_number y d1 d2 x) ]
+    | _ = kwd "how"; _ = ws; _ = kwd "many"; x = new_var ->
+	(fun y d1 d2 -> which x bool1#true_ (a_number y d1 d2)) ]
 and parse_det = dcg
     [ det = parse_det_unary -> det
     | _ = kwd "every" -> (fun x d1 d2 -> forall x d1 d2)
-    | _ = kwd "all" -> (fun x d1 d2 -> forall x d1 d2) ]
+    | _ = kwd "all" -> (fun x d1 d2 -> forall x d1 d2)
+    | _ = kwd "which" -> (fun x d1 d2 -> which x d1 d2) ]
 and parse_np = dcg
     [ np = parse_np_gen parse_det -> np ]
 and parse_np2 = dcg
         | _ = ws; op = parse_op -> (fun x -> op (fun y -> p2 x y)) )]
 *)
 and parse_vp_have = dcg
-    [ _ = kwd "which"; _ = ws; y, p2 = parse_ng2; rel_opt = parse_rel_opt; _ = add_select y (rel_opt None) ->
-	(fun x -> p2 x y)
+    [ _ = kwd "which"; _ = ws; y, p2 = parse_ng2; rel_opt = parse_rel_opt ->
+	(fun x -> which y (rel_opt None) (p2 x))
     | np2 = parse_np2; rel_opt = parse_rel_opt ->
 	(fun x -> np2 x (rel_opt None))
     | p2 = parse_p2; _ = ws; op = parse_op ->
 	  (fun s -> np (fun z -> prep z s))
       | det = parse_det; _ = ws; prep = parse_prep; z = parse_app_opt; rel_opt = parse_rel_opt ->
 	  (fun s -> det z (fun z -> prep z s) (rel_opt None))
-      | _ = kwd "which"; _ = ws; prep = parse_prep; z = parse_app_opt; rel_opt = parse_rel_opt; _ = add_select z (rel_opt None) ->
-	  (fun s -> prep z s) ) ]
+      | _ = kwd "which"; _ = ws; prep = parse_prep; z = parse_app_opt; rel_opt = parse_rel_opt ->
+	  (fun s -> which z (rel_opt None) (fun z -> prep z s)) ) ]
 and parse_prep = dcg
     [ _ = kwd "graph" -> graph
     | uri = parse_uri -> arg uri ]
 		    [example_cell "To which nationality an author of X belongs?"]);
                    (dt [pcdata "Reification of triples"], []),
                    (example_cell "In which graph X has some topic?",
-		    [example_cell "Which publication say-s that X know-s Y?";
-		     example_cell "At least 3 publication-s do say that which person know-s Y?"]);
+		    [example_cell "At source which publication X know-s Y?";
+		     example_cell "Which person know-s Y at source at least 3 publication-s?"]);
 		   (dt [pcdata "Patterns"], []),
 		   (example_cell "How many publication-s have topic 'Computer Science' ?",
 		    [example_cell "Which person whose rdfs:label is 'John Smith' is an author of X ?"]);