* http://cs.unibo.it/helm/.
*)
+
+
+
(*
* implementazione del'interprete MathQL
*)
-(*
-(* FG: ROBA VECCHIA DA BUTTARE (tranne apertura e chiusura database *)
-open MathQL;;
-open Eval;;
-open Utility;;
-open Pattern;;*)
+
open Dbconn;;
open Union;;
open Intersect;;
open Context;;
open Diff;;
open Relation;;
-(*open Sortedby;;
-open Use;;
-open Select;;
-open Letin;;
-open Mathql_semantics;;
-
-
-
-let prop_pool = ref None;;
-
-let fi_to_string fi =
- match fi with
- (None, _) ->
- ""
- | (Some i, y) ->
- "#xpointer(1/" ^
- string_of_int i ^
- (
- match y with
- None ->
- ""
- | Some j ->
- "/" ^ (string_of_int j)
- ) ^
- ")"
-;;
-let see_prop_pool () =
- let _ = print_endline "eccomi" in
- List.iter
- (fun elem -> print_endline (fst elem ^ ": " ^ snd elem))
- (match !prop_pool with Some l -> l | _ -> print_endline "ciao"; assert false)
-;;
-
-
-
-let get_prop_id prop =
- if prop="refObj" then "F"
- else if prop="backPointer" then "B"
- else List.assoc prop (match !prop_pool with Some l -> l | _ -> assert false)
-;;
-
-(* execute_ex env q *)
-(* [env] is the attributed uri environment in which the query [q] *)
-(* must be evaluated *)
-(* [q] is the query to evaluate *)
-(* It returns a [Mathql_semantics.result] *)
-let rec execute_ex env =
- function
- MQSelect (apvar, alist, abool) ->
- select_ex env apvar (execute_ex env alist) abool
- | MQUsedBy (alist, asvar) ->
- use_ex (execute_ex env alist) asvar (get_prop_id "refObj") (* "F" (*"refObj"*) *)
- | MQUse (alist, asvar) ->
- use_ex (execute_ex env alist) asvar (get_prop_id "backPointer") (* "B" (*"backPointer"*) *)
- | MQPattern (apreamble, apattern, afragid) ->
- pattern_ex (apreamble, apattern, afragid)
- | MQUnion (l1, l2) ->
- union_ex (execute_ex env l1) (execute_ex env l2)
- | MQDiff (l1, l2) ->
- diff_ex (execute_ex env l1) (execute_ex env l2)
- | MQSortedBy (l, o, f) ->
- sortedby_ex (execute_ex env l) o f
- | MQIntersect (l1, l2) ->
- intersect_ex (execute_ex env l1) (execute_ex env l2)
- | MQListRVar rvar -> [List.assoc rvar env]
- | MQLetIn (lvar, l1, l2) ->
- let t = Sys.time () in
- let res =
- (*CSC: The interesting code *)
- let _ = letin_ex lvar (execute_ex env l1) in
- execute_ex env l2
- (*CSC: end of the interesting code *)
- in
- letdispose ();
- print_string ("LETIN = " ^ string_of_int (List.length res) ^ ": ") ;
- print_endline (string_of_float (Sys.time () -. t) ^ "s") ;
- flush stdout ;
- res
- | MQListLVar lvar ->
- letref_ex lvar
- | MQReference l ->
- let rec build_result = function
- | [] -> []
- | s :: tail ->
- {uri = s ; attributes = [] ; extra = ""} :: build_result tail
- in build_result (List.sort compare l)
-;;
-
-(* Let's initialize the execute in Select, creating a cyclical recursion *)
-Select.execute := execute_ex;;
-
-(*
- * converte il risultato interno di una query (uri + contesto)
- * in un risultato di sole uri
- *
- * parametri:
- * l: string list list;
- *
- * output: mqresult;
- *
- * note:
- * il tipo del risultato mantenuto internamente e' diverso dal tipo di risultato
- * restituito in output poiche', mentre chi effettua le query vuole come risultato
- * solo le eventuali uri che soddisfano le query stesse, internamente ad una uri
- * sono associati anche i valori delle variabili che ancora non sono state valutate
- * perche', ad esempio, si trovano in altri rami dell'albero.
- *
-* Esempio:
- * SELECT x IN USE PATTERN "cic:/**.con" POSITION $a WHERE $a IS MainConclusion
- * L'albero corrispondente a questa query e':
- *
- * SELECT
- * / | \
- * x USE IS
- * / \ /\
- * PATTERN $a $a MainConclusion
- *
- * Nel momento in cui si esegue il ramo USE non sono noti i vincoli sullla variabile $a
- * percui e' necessario considerare, oltre alle uri, i valori della variabile per i quali
- * la uri puo' far parte del risultato.
- *)
-let xres_to_res l =
- MQRefs (List.map (function {Mathql_semantics.uri = uri} -> uri) l)
-(*
- let tmp = List.map (function {Mathql_semantics.uri = uri} -> uri) l in
- MQRefs
- (List.map
- (function l ->
- (*let _ = print_endline ("DEBUG: (mqint.ml: xres_to_res)" ^ l) in*)
- match Str.split (Str.regexp ":\|#\|/\|(\|)") l with
- hd::""::tl -> (
- match List.rev tl with
- n::"1"::"xpointer"::tail ->
- (
- Some hd,
- List.fold_left
- (fun par t ->
- match par with
- [] -> [MQBC t]
- | _ -> (MQBC t) :: MQBD :: par
- )
- []
- tail,
- [MQFC (int_of_string n)]
- )
- | n::m::"1"::"xpointer"::tail ->
- (
- Some hd,
- List.fold_left
- (fun par t ->
- match par with
- [] -> [MQBC t]
- | _ -> (MQBC t) :: MQBD :: par
- )
- []
- tail,
- [MQFC (int_of_string m); MQFC (int_of_string n)]
- )
- | tail ->
- (
- Some hd,
- List.fold_left
- (fun par t ->
- match par with
- [] -> [MQBC t]
- | _ -> (MQBC t) :: MQBD :: par
- )
- []
- tail,
- []
- )
- )
- | _ -> assert false
- )
- tmp
- )
-*)
-;;
-
-
-(*
- *
- *)
-let execute q =
- match q with
- MQList qq -> xres_to_res (execute_ex [] qq)
-;;
-
-let prop_pool = ref None;;
-
-*****************************************************************************)
let init connection_param = Dbconn.init connection_param
-(*
- let c = pgc () in
- let res =
- c#exec "select name,id from property where ns_id in (select id from namespace where url='http://www.cs.unibo.it/helm/schemas/mattone.rdf#')"
- in
- prop_pool := Some
- (
- List.map
- (function
- a::b::_ -> (a, b)
- | _ -> print_endline "no"; assert false
- )
- res#get_list
- )
-*)
let close () = Dbconn.close ()
|MathQL.RVar rvar -> [List.assoc rvar c.rvars]
| MathQL.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
| MathQL.Intersect (sexp1, sexp2) -> intersect_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
- | MathQL.Union (sexp1, sexp2) -> union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
- | MathQL.LetSVar (svar, sexp1, sexp2) -> let _ = (svar, (exec_set_exp c sexp1)):: (List.remove_assoc svar c.svars)
- in (exec_set_exp c sexp2)
+ | MathQL.Union (sexp1, sexp2) ->
+ let before = Sys.time () in
+ let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
+ let after = Sys.time () in
+ let diff = string_of_float (after -. before) in
+ print_endline ("UNION: " ^ diff ^ "s") ;
+ flush stdout ;
+ res
+ | MathQL.LetSVar (svar, sexp1, sexp2) ->
+ let before = Sys.time () in
+ let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in
+ let res = exec_set_exp c1 sexp2 in
+ print_string ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ") ;
+ print_endline (string_of_float (Sys.time () -. before) ^ "s") ;
+ flush stdout ; res
| MathQL.LetVVar (vvar, vexp, sexp) ->
let before = Sys.time () in
let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
print_endline (string_of_float (Sys.time () -. before) ^ "s") ;
flush stdout ; res
| MathQL.Relation (rop, path, sexp, attl) -> relation_ex rop path (exec_set_exp c sexp) attl
- | MathQL.Select (rvar, sexp, bexp) -> let rset = (exec_set_exp c sexp) in
- let rec select_ex rset =
- match rset with
- [] -> []
- | r::tl -> let c1 = upd_rvars c ((rvar,r)::c.rvars) in
- if (exec_boole_exp c1 bexp) then r::(select_ex tl)
- else select_ex tl
- in select_ex rset
-
-
-
+ | MathQL.Select (rvar, sexp, bexp) ->
+ let rset = (exec_set_exp c sexp) in
+ let rec select_ex rset =
+ match rset with
+ [] -> []
+ | r::tl -> let c1 = upd_rvars c ((rvar,r)::c.rvars) in
+ if (exec_boole_exp c1 bexp) then r::(select_ex tl)
+ else select_ex tl
+ in select_ex rset
| MathQL.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
| _ -> assert false
| MathQL.Ex l bexp ->
if l = [] then (exec_boole_exp c bexp)
else
- let latt = List.map (fun uri ->
- let (r,attl) = List.assoc uri c.rvars
- in (uri,attl)) l (*latt = l + attributi*)
- in
- try
- let rec prod c = function
- [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue
- | (uri,attl)::tail1 -> let rec sub_prod attl =
+ let latt = List.map (fun uri ->
+ let (r,attl) = List.assoc uri c.rvars in (uri,attl)) l (*latt = l + attributi*)
+ in
+ try
+ let rec prod c = function
+ [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue
+ | (uri,attl)::tail1 -> let rec sub_prod attl =
match attl with
(*per ogni el. di attl *) [] -> ()
(*devo andare in ric. su tail1*) | att::tail2 -> let c1 = upd_groups c ((uri,att)::c.groups) in
prod c1 tail1; sub_prod tail2
in
sub_prod attl
- in
- prod c latt; false
- with BooleExpTrue -> true
+ in
+ prod c latt; false
+ with BooleExpTrue -> true
| _ -> assert false
(* valuta una MathQL.val_exp e ritorna un MathQL.value *)
and exec_val_exp c = function
| MathQL.Const x -> let
- ol = List.sort compare x in
+ ol = List.sort compare x in
let rec edup = function
[] -> []
* implementazione del comando UNION
*)
-(*
-(*
- *
- *)
-let xres_fill_context hr h1 l1 =
- match l1 with
- [] -> []
- | _ ->
- let hh = List.combine h1 l1
- in
- List.map
- (fun x ->
- if (List.mem_assoc x hh) then
- List.assoc x hh
- else
- ""
- )
- hr
-;;
-(*
- * implementazione del comando UNION
- *)
-let union_ex alist1 alist2 =
- let head1 = List.hd alist1
- and tail1 = List.tl alist1
- and head2 = List.hd alist2
- and tail2 = List.tl alist2 (* e fin qui ... *)
- in
- match (head1, head2) with
- ([], _) -> assert false (* gli header non devono mai essere vuoti *)
- | (_, []) -> assert false (* devono contenere almeno [retVal] *)
- | (_, _) -> let headr = (head2 @
- (List.find_all
- (function t -> not (List.mem t head2))
- head1)
- ) in (* header del risultato finale *)
- List.append (* il risultato finale e' la concatenazione ...*)
- [headr] (* ... dell'header costruito prima ...*)
- (Sort.list
- (fun l m -> List.hd l < List.hd m)
- (match (tail1, tail2) with (* e di una coda "unione" *)
- ([], _) -> tail2 (* va bene perche' l'altra lista e' vuota *)
- | (_, []) -> tail1 (* va bene perche' l'altra lista e' vuota *)
- | (_, _) ->
- let first = (* parte dell'unione che riguarda solo il primo set *)
- List.map
- (
- fun l ->
- [List.hd l] @
- xres_fill_context (List.tl headr) (List.tl head1) (List.tl l)
- )
- tail1
- in
- List.fold_left
- (fun par x ->
- let y = (* elemento candidato ad entrare *)
- [List.hd x]
- @
- xres_fill_context
- (List.tl headr) (List.tl head2) (List.tl x)
- in
- par @ if (List.find_all (fun t -> t = y) par) = [] then
- [y]
- else
- []
- )
- first (* List.fold_left *)
- tail2 (* List.fold_left *)
-(* first @
- List.map (fun l -> [List.hd l] @
- xres_fill_context
- (List.tl headr) (List.tl head2) (List.tl l)
- ) tail2
-*)
- ) (* match *)
- )
-;;
-*)
(* Merges two attribute group lists preserves order and gets rid of duplicates*)
let rec merge l1 l2 =
match (l1,l2) with
else (uri1,merge l1 l2)::(union_ex tl1 tl2)
;;
-let union_ex l1 l2 =
- let before = Sys.time () in
- let res = union_ex l1 l2 in
- let after = Sys.time () in
- let ll1 = string_of_int (List.length l1) in
- let ll2 = string_of_int (List.length l2) in
- let diff = string_of_float (after -. before) in
- print_endline ("UNION(" ^ ll1 ^ "," ^ ll2 ^ "): " ^ diff ^ "s") ;
- flush stdout ;
- res
-;;
+
projects / helm.git / commitdiff