From ba824e867afc3eaf081ed1a1d6526d421242a6a0 Mon Sep 17 00:00:00 2001 From: natile Date: Mon, 21 Oct 2002 13:48:24 +0000 Subject: [PATCH] Merge of the new_mathql branch with the main branch: - new query language - new interpreter for the new query language NOTE: the galax version of the interpreted is not ported yet (and does not compile) --- helm/ocaml/mathql/.depend | 6 +- helm/ocaml/mathql/Makefile | 7 +- helm/ocaml/mathql/mQueryTLexer.mll | 104 +++--- helm/ocaml/mathql/mQueryTParser.mly | 208 ++++++++---- helm/ocaml/mathql/mQueryUtil.ml | 257 +++++--------- helm/ocaml/mathql/mQueryUtil.mli | 15 +- helm/ocaml/mathql/mathQL.ml | 168 ++++----- helm/ocaml/mathql_interpreter/.depend | 52 +-- helm/ocaml/mathql_interpreter/Makefile | 12 +- helm/ocaml/mathql_interpreter/context.ml | 30 ++ helm/ocaml/mathql_interpreter/dbconn.ml | 19 +- helm/ocaml/mathql_interpreter/dbconn.mli | 2 +- helm/ocaml/mathql_interpreter/diff.ml | 28 +- helm/ocaml/mathql_interpreter/diff.mli | 2 +- helm/ocaml/mathql_interpreter/func.ml | 63 +--- helm/ocaml/mathql_interpreter/func.mli | 2 +- helm/ocaml/mathql_interpreter/intersect.ml | 140 +++----- helm/ocaml/mathql_interpreter/intersect.mli | 5 +- helm/ocaml/mathql_interpreter/meet.ml | 34 ++ helm/ocaml/mathql_interpreter/meet.mli | 27 ++ helm/ocaml/mathql_interpreter/mqint.ml | 359 ++++++++------------ helm/ocaml/mathql_interpreter/mqint.mli | 23 +- helm/ocaml/mathql_interpreter/pattern.ml | 4 +- helm/ocaml/mathql_interpreter/relation.ml | 76 +++++ helm/ocaml/mathql_interpreter/relation.mli | 27 ++ helm/ocaml/mathql_interpreter/select.ml | 11 +- helm/ocaml/mathql_interpreter/sortedby.ml | 4 +- helm/ocaml/mathql_interpreter/sub.ml | 34 ++ helm/ocaml/mathql_interpreter/sub.mli | 27 ++ helm/ocaml/mathql_interpreter/union.ml | 119 +------ helm/ocaml/mathql_interpreter/union.mli | 2 +- helm/ocaml/mathql_interpreter/use.ml | 71 +--- 32 files changed, 936 insertions(+), 1002 deletions(-) create mode 100644 helm/ocaml/mathql_interpreter/context.ml create mode 100644 helm/ocaml/mathql_interpreter/meet.ml create mode 100644 helm/ocaml/mathql_interpreter/meet.mli create mode 100644 helm/ocaml/mathql_interpreter/relation.ml create mode 100644 helm/ocaml/mathql_interpreter/relation.mli create mode 100644 helm/ocaml/mathql_interpreter/sub.ml create mode 100644 helm/ocaml/mathql_interpreter/sub.mli diff --git a/helm/ocaml/mathql/.depend b/helm/ocaml/mathql/.depend index c898ba8b0..769e30c89 100644 --- a/helm/ocaml/mathql/.depend +++ b/helm/ocaml/mathql/.depend @@ -4,7 +4,5 @@ mQueryTParser.cmo: mathQL.cmo mQueryTParser.cmi mQueryTParser.cmx: mathQL.cmx mQueryTParser.cmi mQueryTLexer.cmo: mQueryTParser.cmi mQueryTLexer.cmx: mQueryTParser.cmx -mQueryUtil.cmo: mQueryHTML.cmo mQueryTLexer.cmo mQueryTParser.cmi mathQL.cmo \ - mQueryUtil.cmi -mQueryUtil.cmx: mQueryHTML.cmx mQueryTLexer.cmx mQueryTParser.cmx mathQL.cmx \ - mQueryUtil.cmi +mQueryUtil.cmo: mQueryTLexer.cmo mQueryTParser.cmi mathQL.cmo mQueryUtil.cmi +mQueryUtil.cmx: mQueryTLexer.cmx mQueryTParser.cmx mathQL.cmx mQueryUtil.cmi diff --git a/helm/ocaml/mathql/Makefile b/helm/ocaml/mathql/Makefile index 8cd40ee82..c381b8dc8 100644 --- a/helm/ocaml/mathql/Makefile +++ b/helm/ocaml/mathql/Makefile @@ -5,13 +5,12 @@ PREDICATES = INTERFACE_FILES = mQueryTParser.mli mQueryUtil.mli IMPLEMENTATION_FILES = mathQL.ml mQueryTParser.ml mQueryTLexer.ml \ - mQueryHTML.ml mQueryUtil.ml + mQueryUtil.ml EXTRA_OBJECTS_TO_INSTALL = mathQL.ml mathQL.cmi mQueryTLexer.cmi \ - mQueryTLexer.mll mQueryTParser.mly \ - mQueryHTML.ml mQueryHTML.cmi + mQueryTLexer.mll mQueryTParser.mly EXTRA_OBJECTS_TO_CLEAN = mQueryTParser.ml mQueryTParser.mli \ - mQueryTLexer.ml + mQueryTLexer.ml include ../Makefile.common diff --git a/helm/ocaml/mathql/mQueryTLexer.mll b/helm/ocaml/mathql/mQueryTLexer.mll index 0075f3ac1..a0884e79d 100644 --- a/helm/ocaml/mathql/mQueryTLexer.mll +++ b/helm/ocaml/mathql/mQueryTLexer.mll @@ -41,48 +41,64 @@ let SPC = [' ' '\t' '\n']+ let ALPHA = ['A'-'Z' 'a'-'z'] let NUM = ['0'-'9'] let IDEN = ALPHA (NUM | ALPHA)* -let DQ = '"' -let SQ = ''' -let QSTR = [^ ''']* -let USTR = [^ '"' ':' '/' '#' '?' '*']+ - -rule rtoken = parse - | DQ { DQT } - | ":/" { PROT } - | "/" { SLASH } - | "#1" { FRAG } - | "?" { QUEST } - | "**" { SSTAR } - | "*" { STAR } - | USTR { STR (Lexing.lexeme lexbuf) } -and stoken = parse - | SQ { SQT } - | QSTR { STR (Lexing.lexeme lexbuf) } -and qtoken = parse - | SPC { qtoken lexbuf } - | '(' { LPR } - | ')' { RPR } - | '$' { DLR } - | SQ { STR (qstr stoken lexbuf) } - | DQ { REF (ref rtoken lexbuf) } - | "name" { NAME } - | "mainconclusion" { MCONCL } - | "conclusion" { CONCL } - | "true" { TRUE } - | "false" { FALSE } - | "and" { AND } - | "or" { OR } - | "not" { NOT } - | "is" { IS } - | "select" { SELECT } - | "in" { IN } - | "where" { WHERE } - | "use" { USE } - | "position" { POS } - | "usedby" { USEDBY } - | "pattern" { PATT } - | "union" { UNION } - | "intersect" { INTER } - | IDEN { ID (Lexing.lexeme lexbuf) } - | eof { EOF } +let QSTR = [^ '"' '\\']+ +rule comm_token = parse + | "*)" { query_token lexbuf } + | [^ '*']* { comm_token lexbuf } +and string_token = parse + | '"' { DQ } + | '\\' _ { STR (String.sub (Lexing.lexeme lexbuf) 1 1) } + | QSTR { STR (Lexing.lexeme lexbuf) } + | eof { EOF } +and query_token = parse + | "(*" { comm_token lexbuf } + | SPC { query_token lexbuf } + | '"' { STR (qstr string_token lexbuf) } + | '(' { LP } + | ')' { RP } + | '{' { LC } + | '}' { RC } + | '@' { AT } + | '%' { PC } + | '$' { DL } + | '.' { FS } + | ',' { CM } + | '/' { SL } + | "and" { AND } + | "attr" { ATTR } + | "attribute" { ATTRIB } + | "be" { BE } + | "diff" { DIFF } + | "eq" { EQ } + | "ex" { EX } + | "false" { FALSE } + | "fun" { FUN } + | "in" { IN } + | "intersect" { INTER } + | "let" { LET } + | "meet" { MEET } + | "not" { NOT } + | "or" { OR } + | "pattern" { PAT } + | "ref" { REF } + | "refof" { REFOF } + | "relation" { REL } + | "select" { SELECT } + | "sub" { SUB } + | "super" { SUPER } + | "true" { TRUE } + | "union" { UNION } + | "where" { WHERE } + | IDEN { ID (Lexing.lexeme lexbuf) } + | eof { EOF } +and result_token = parse + | SPC { result_token lexbuf } + | '"' { STR (qstr string_token lexbuf) } + | '{' { LC } + | '}' { RC } + | ',' { CM } + | ';' { SC } + | '=' { IS } + | "attr" { ATTR } + | eof { EOF } diff --git a/helm/ocaml/mathql/mQueryTParser.mly b/helm/ocaml/mathql/mQueryTParser.mly index 9bfcd4e0c..f32a41187 100644 --- a/helm/ocaml/mathql/mQueryTParser.mly +++ b/helm/ocaml/mathql/mQueryTParser.mly @@ -34,86 +34,156 @@ /******************************************************************************/ %{ - open MathQL + let analyze x = + let module M = MathQL in + let rec join l1 l2 = match l1, l2 with + | [], _ -> l2 + | _, [] -> l1 + | s1 :: tl1, s2 :: _ when s1 < s2 -> s1 :: join tl1 l2 + | s1 :: _, s2 :: tl2 when s2 < s1 -> s2 :: join l1 tl2 + | s1 :: tl1, s2 :: tl2 -> s1 :: join tl1 tl2 + in + let rec an_val = function + | M.Const _ -> [] + | M.VVar _ -> [] + | M.Record (rv, _) -> [rv] + | M.Fun (_, x) -> an_val x + | M.Attribute (_, _, x) -> an_val x + | M.RefOf x -> an_set x + and an_boole = function + | M.False -> [] + | M.True -> [] + | M.Ex _ _ -> [] + | M.Not x -> an_boole x + | M.And (x, y) -> join (an_boole x) (an_boole y) + | M.Or (x, y) -> join (an_boole x) (an_boole y) + | M.Sub (x, y) -> join (an_val x) (an_val y) + | M.Meet (x, y) -> join (an_val x) (an_val y) + | M.Eq (x, y) -> join (an_val x) (an_val y) + and an_set = function + | M.SVar _ -> [] + | M.RVar _ -> [] + | M.Relation (_, _, x, _) -> an_set x + | M.Pattern x -> an_val x + | M.Ref x -> an_val x + | M.Union (x, y) -> join (an_set x) (an_set y) + | M.Intersect (x, y) -> join (an_set x) (an_set y) + | M.Diff (x, y) -> join (an_set x) (an_set y) + | M.LetSVar (_, x, y) -> join (an_set x) (an_set y) + | M.LetVVar (_, x, y) -> join (an_val x) (an_set y) + | M.Select (_, x, y) -> join (an_set x) (an_boole y) + in + an_boole x %} %token ID STR - %token REF - %token LPR RPR DLR SQT DQT EOF PROT SLASH FRAG QUEST STAR SSTAR - %token NAME - %token MCONCL CONCL - %token TRUE FALSE AND OR NOT IS - %token SELECT IN WHERE USE POS USEDBY PATT UNION INTER + %token SL IS LC RC CM SC LP RP AT PC DL FS DQ EOF + %token AND ATTR ATTRIB BE DIFF EQ EX FALSE FUN IN INTER LET MEET NOT OR + %token PAT REF REFOF REL SELECT SUB SUPER TRUE UNION WHERE + %left DIFF WHERE REFOF %left OR UNION %left AND INTER - %nonassoc NOT - %start qstr ref query - %type qstr - %type ref - %type query + %nonassoc REL + %nonassoc NOT EX IN ATTR + + %start qstr query result + %type qstr + %type query + %type result %% - prot: - | STR { Some $1 } - | STAR { None } - ; - body: - | { [] } - | SLASH body { MQBD :: $2 } - | QUEST body { MQBQ :: $2 } - | SSTAR body { MQBSS :: $2 } - | STAR body { MQBS :: $2 } - | STR body { MQBC $1 :: $2 } - frag: - | { [] } - | SLASH SSTAR frag { MQFSS :: $3 } - | SLASH STAR frag { MQFS :: $3 } - | SLASH STR frag { try let i = int_of_string $2 in - if i < 1 then raise Parsing.Parse_error; - MQFC i :: $3 - with e -> raise Parsing.Parse_error - } - ; - ref: - | prot PROT body DQT { ($1, $3, []) } - | prot PROT body FRAG frag DQT { ($1, $3, $5) } - ; qstr: - | STR SQT { $1 } + | DQ { "" } + | STR qstr { $1 ^ $2 } + ; + svar: + | PC ID { $2 } ; rvar: - | ID { $1 } + | AT ID { $2 } ; - svar: - | DLR ID { $2 } + vvar: + | DL ID { $2 } ; - func: - | NAME { MQName } - ; - str: - | MCONCL { MQMConclusion } - | CONCL { MQConclusion } - | STR { MQCons $1 } - | rvar { MQStringRVar $1 } - | svar { MQStringSVar $1 } - | func rvar { MQFunc ($1, $2) } - ; - boole: - | TRUE { MQTrue } - | FALSE { MQFalse } - | str IS str { MQIs ($1, $3) } - | NOT boole { MQNot $2 } - | boole AND boole { MQAnd ($1, $3) } - | boole OR boole { MQOr ($1, $3) } - | LPR boole RPR { $2 } + qstr_list: + | STR CM qstr_list { $1 :: $3 } + | STR { [$1] } + ; + vvar_list: + | vvar CM vvar_list { $1 :: $3 } + | vvar { [$1] } + ; + qstr_path: + | STR SL qstr_path { $1 :: $3 } + | STR { [$1] } + ; + ref_op: + | SUB { MathQL.SubOp } + | SUPER { MathQL.SuperOp } + | { MathQL.ExactOp } + ; + val_exp: + | STR { MathQL.Const [$1] } + | FUN STR val_exp { MathQL.Fun ($2, $3) } + | ATTRIB ref_op qstr_path val_exp { MathQL.Attribute ($2, $3, $4) } + | rvar FS vvar { MathQL.Record ($1, $3) } + | vvar { MathQL.VVar $1 } + | LC qstr_list RC { MathQL.Const $2 } + | LC RC { MathQL.Const [] } + | REFOF set_exp { MathQL.RefOf $2 } + | LP val_exp RP { $2 } + ; + boole_exp: + | TRUE { MathQL.True } + | FALSE { MathQL.False } + | LP boole_exp RP { $2 } + | NOT boole_exp { MathQL.Not $2 } + | EX boole_exp { MathQL.Ex (analyze $2) $2 } + | val_exp SUB val_exp { MathQL.Sub ($1, $3) } + | val_exp MEET val_exp { MathQL.Meet ($1, $3) } + | val_exp EQ val_exp { MathQL.Eq ($1, $3) } + | boole_exp AND boole_exp { MathQL.And ($1, $3) } + | boole_exp OR boole_exp { MathQL.Or ($1, $3) } ; - rlist: - | PATT REF { MQPattern $2 } - | rlist UNION rlist { MQUnion ($1, $3) } - | rlist INTER rlist { MQIntersect ($1, $3) } - | USE rlist POS svar { MQUse ($2, $4) } - | USEDBY rlist POS svar { MQUsedBy ($2, $4) } - | SELECT rvar IN rlist WHERE boole { MQSelect ($2, $4, $6) } - | LPR rlist RPR { $2 } + set_exp: + | REF val_exp { MathQL.Ref $2 } + | PAT val_exp { MathQL.Pattern $2 } + | LP set_exp RP { $2 } + | SELECT rvar IN set_exp WHERE boole_exp { MathQL.Select ($2, $4, $6) } + | REL ref_op qstr_path set_exp ATTR vvar_list { MathQL.Relation ($2, $3, $4, $6) } + | REL ref_op qstr_path set_exp { MathQL.Relation ($2, $3, $4, []) } + | svar { MathQL.SVar $1 } + | rvar { MathQL.RVar $1 } + | set_exp UNION set_exp { MathQL.Union ($1, $3) } + | set_exp INTER set_exp { MathQL.Intersect ($1, $3) } + | set_exp DIFF set_exp { MathQL.Diff ($1, $3) } + | LET svar BE set_exp IN set_exp { MathQL.LetSVar ($2, $4, $6) } + | LET vvar BE val_exp IN set_exp { MathQL.LetVVar ($2, $4, $6) } ; query: - rlist EOF { MQList $1 } + | set_exp EOF { $1 } + ; + attribute: + | STR IS qstr_list { ($1, $3) } + | STR { ($1, []) } + ; + attr_list: + | attribute SC attr_list { $1 :: $3 } + | attribute { [$1] } ; + group: + LC attr_list RC { $2 } + ; + group_list: + | group CM group_list { $1 :: $3 } + | group { [$1] } + ; + resource: + | STR ATTR group_list { ($1, $3) } + | STR { ($1, []) } + ; + resource_list: + | resource SC resource_list { $1 :: $3 } + | resource { [$1] } + | { [] } + ; + result: + | resource_list EOF { $1 } diff --git a/helm/ocaml/mathql/mQueryUtil.ml b/helm/ocaml/mathql/mQueryUtil.ml index 8943e5675..ea1829719 100644 --- a/helm/ocaml/mathql/mQueryUtil.ml +++ b/helm/ocaml/mathql/mQueryUtil.ml @@ -33,173 +33,92 @@ (* *) (******************************************************************************) -open MathQL -open MQueryHTML -(* string linearization of a reference **************************************) - -let str_btoken = function - | MQBC s -> s - | MQBD -> "/" - | MQBQ -> "?" - | MQBS -> "*" - | MQBSS -> "**" - -let str_ftoken = function - | MQFC i -> string_of_int i - | MQFS -> "*" - | MQFSS -> "**" - -let str_prot = function - | Some s -> s - | None -> "*" - -let rec str_body = function - | [] -> "" - | head :: tail -> str_btoken head ^ str_body tail - -let str_frag xpointer f l = - let sfi = List.fold_left (fun l0 t0 -> l0 ^ "/" ^ f t0) "" l in - if sfi = "" then "" else - if xpointer then "#xpointer(1" ^ sfi ^ ")" else - "#1" ^ sfi - -let str_tref (p, b, i) = - str_prot p ^ ":/" ^ str_body b ^ str_frag false str_ftoken i - -let xp_str_tref (p, b, i) = - str_prot p ^ ":/" ^ str_body b ^ str_frag true str_ftoken i - -let str_uref (u, i) = - UriManager.string_of_uri u ^ str_frag false string_of_int i - -let xp_str_uref (u, i) = - UriManager.string_of_uri u ^ str_frag true string_of_int i - -(* HTML representation of a query ********************************************) - -let out_rvar s = sym s - -let out_svar s = sep "$" ^ sym s - -let out_lvar s = sep "%" ^ sym s - -let out_tref r = pat (str_tref r) - -let rec out_sequence f = function - | [] -> sep "." - | [s] -> f s - | s :: tail -> f s ^ sep ", " ^ out_sequence f tail - -let out_order = function - | MQAsc -> sub2 "asc" - | MQDesc -> sub2 "desc" - -let out_func = function - | MQName -> key "name" - | MQTheory -> key "theory" - | MQTitle -> key "title" - | MQContributor -> key "contributor" - | MQCreator -> key "creator" - | MQPublisher -> key "publisher" - | MQSubject -> key "subject" - | MQDescription -> key "description" - | MQDate -> key "date" - | MQType -> key "type" - | MQFormat -> key "format" - | MQIdentifier -> key "identifier" - | MQLanguage -> key "language" - | MQRelation -> key "relation" - | MQSource -> key "source" - | MQCoverage -> key "coverage" - | MQRights -> key "rights" - | MQInstitution -> key "institution" - | MQContact -> key "contact" - | MQFirstVersion -> key "firstversion" - | MQModified -> key "modified" - -let out_str = function - | MQCons s -> str s - | MQStringRVar s -> out_rvar s - | MQStringSVar s -> out_svar s - | MQFunc (f, r) -> out_func f ^ out_rvar r - | MQMConclusion -> key "mainconclusion" - | MQConclusion -> key "inconclusion" - -let rec out_bool = function - | MQTrue -> key "true" - | MQFalse -> key "false" - | MQIs (s, t) -> out_str s ^ sub "is" ^ out_str t - | MQNot b -> key "not" ^ out_bool b - | MQAnd (b1, b2) -> sep "(" ^ out_bool b1 ^ sub "and" ^ out_bool b2 ^ sep ")" - | MQOr (b1, b2) -> sep "(" ^ out_bool b1 ^ sub "or" ^ out_bool b2 ^ sep ")" - | MQSubset (l1, l2) -> sep "(" ^ out_list l1 ^ sub "subset" ^ out_list l2 ^ sep ")" - | MQSetEqual (l1, l2) -> sep "(" ^ out_list l1 ^ sub "setequal" ^ out_list l2 ^ sep ")" - -and out_list = function - | MQSelect (r, l, b) -> - key "select" ^ out_rvar r ^ sub "in" ^ out_list l ^ sub "where" ^ out_bool b - | MQUse (l, v) -> key "use" ^ out_list l ^ sub "position" ^ out_svar v - | MQUsedBy (l, v) -> key "usedby" ^ out_list l ^ sub "position" ^ out_svar v - | MQPattern p -> key "pattern" ^ out_tref p - | MQUnion (l1, l2) -> sep "(" ^ out_list l1 ^ sub "union" ^ out_list l2 ^ sep ")" - | MQIntersect (l1, l2) -> sep "(" ^ out_list l1 ^ sub "intersect" ^ out_list l2 ^ sep ")" - | MQDiff (l1, l2) -> sep "(" ^ out_list l1 ^ sub "diff" ^ out_list l2 ^ sep ")" - | MQListRVar v -> out_rvar v - | MQSortedBy (l, o, f) -> sep "(" ^ out_list l ^ sub "sortedby" ^ out_func f ^ out_order o ^ sep ")" - | MQListLVar v -> out_lvar v - | MQLetIn (v, l1, l2) -> key "let" ^ out_lvar v ^ sub "be" ^ out_list l1 ^ sub "in" ^ out_list l2 - | MQReference s -> key "reference" ^ out_sequence str s - -let out_query = function - | MQList l -> out_list l - -(* HTML representation of a query result ************************************) - -let rec out_res_list = function - | [] -> "" - | u :: l -> res u ^ nl () ^ out_res_list l - -let out_result qr = - par () ^ "Result:" ^ nl () ^ - match qr with - | MQRefs l -> out_res_list l - -(* Converting functions *****************************************************) - -let tref_uref u = - let s = str_uref u in - MQueryTParser.ref MQueryTLexer.rtoken (Lexing.from_string s) - -let parse_text ch = - let lexbuf = Lexing.from_channel ch in - MQueryTParser.query MQueryTLexer.qtoken lexbuf - -(* implementazione manuale di tref_uref da controllare - -let split s = - try - let i = Str.search_forward (Str.regexp_string ":/") s 0 in - let p = Str.string_before s i in - let q = Str.string_after s (i + 2) in - (p, q) - with - Not_found -> (s, "") - -let encode = function - | Str.Text s -> MQBC s - | Str.Delim s -> - if s = "?" then MQBQ else - if s = "*" then MQBS else - if s = "**" then MQBSS else - if s = "/" then MQBD else MQBC s - -let tref_uref (u, i) = - let s = UriManager.string_of_uri u in - match split s with - | (p, q) -> - let rx = Str.regexp "\?\|\*\*\|\*\|/" in - let l = Str.full_split rx q in - (Some p, List.map encode l, i) - -*) +(* text linearization and parsing *******************************************) + +let rec txt_list f s = function + | [] -> "" + | [a] -> f a + | a :: tail -> f a ^ s ^ txt_list f s tail + +let txt_qstr s = "\"" ^ s ^ "\"" + +let text_of_query x = + let module M = MathQL in + let txt_svar sv = "%" ^ sv in + let txt_rvar rv = "@" ^ rv in + let txt_vvar vv = "$" ^ vv in + let txt_ref = function + | M.ExactOp -> "" + | M.SubOp -> "sub " + | M.SuperOp -> "super " + in + let txt_vvar_list l = + l + in + let rec txt_val = function + | M.Const [s] -> txt_qstr s + | M.Const l -> "{" ^ txt_list txt_qstr ", " l ^ "}" + | M.VVar vv -> txt_vvar vv + | M.Record (rv, vv) -> txt_rvar rv ^ "." ^ txt_vvar vv + | M.Fun (s, x) -> "fun " ^ txt_qstr s ^ " " ^ txt_val x + | M.Attribute (r, p, x) -> "attribute " ^ txt_ref r ^ txt_list txt_qstr "/" p ^ " " ^ txt_val x + | M.RefOf x -> "refof " ^ txt_set x + and txt_boole = function + | M.False -> "false" + | M.True -> "true" + | M.Ex b x -> "ex " ^ txt_boole x +(* | M.Ex b x -> "ex [" ^ txt_list txt_rvar "," b ^ "] " ^ txt_boole x *) + | M.Not x -> "not " ^ txt_boole x + | M.And (x, y) -> "(" ^ txt_boole x ^ " and " ^ txt_boole y ^ ")" + | M.Or (x, y) -> "(" ^ txt_boole x ^ " or " ^ txt_boole y ^ ")" + | M.Sub (x, y) -> "(" ^ txt_val x ^ " sub " ^ txt_val y ^ ")" + | M.Meet (x, y) -> "(" ^ txt_val x ^ " meet " ^ txt_val y ^ ")" + | M.Eq (x, y) -> "(" ^ txt_val x ^ " eq " ^ txt_val y ^ ")" + and txt_set = function + | M.SVar sv -> txt_svar sv + | M.RVar rv -> txt_rvar rv + | M.Relation (r, p, x, []) -> "relation " ^ txt_ref r ^ txt_list txt_qstr "/" p ^ " " ^ txt_set x + | M.Relation (r, p, x, l) -> "relation " ^ txt_ref r ^ txt_list txt_qstr "/" p ^ " " ^ txt_set x ^ " attr " ^ txt_list txt_vvar ", " l + | M.Union (x, y) -> "(" ^ txt_set x ^ " union " ^ txt_set y ^ ")" + | M.Intersect (x, y) -> "(" ^ txt_set x ^ " intersect " ^ txt_set y ^ ")" + | M.Diff (x, y) -> "(" ^ txt_set x ^ " diff " ^ txt_set y ^ ")" + | M.LetSVar (sv, x, y) -> "let " ^ txt_svar sv ^ " be " ^ txt_set x ^ " in " ^ txt_set y + | M.LetVVar (vv, x, y) -> "let " ^ txt_vvar vv ^ " be " ^ txt_val x ^ " in " ^ txt_set y + | M.Select (rv, x, y) -> "select " ^ txt_rvar rv ^ " in " ^ txt_set x ^ " where " ^ txt_boole y + | M.Pattern x -> "pattern " ^ txt_val x + | M.Ref x -> "ref " ^ txt_val x + in + txt_set x + +let text_of_result x sep = + let txt_attr = function + | (s, []) -> txt_qstr s + | (s, l) -> txt_qstr s ^ "=" ^ txt_list txt_qstr ", " l + in + let txt_group l = "{" ^ txt_list txt_attr "; " l ^ "}" in + let txt_res = function + | (s, []) -> txt_qstr s + | (s, l) -> txt_qstr s ^ " attr " ^ txt_list txt_group ", " l + in + let txt_set l = txt_list txt_res ("; " ^ sep) l ^ sep in + txt_set x + +let query_of_text lexbuf = + MQueryTParser.query MQueryTLexer.query_token lexbuf + +let result_of_text lexbuf = + MQueryTParser.result MQueryTLexer.result_token lexbuf + +(* conversion functions *****************************************************) + +type uriref = UriManager.uri * (int list) + +let string_of_uriref (uri, fi) = + let module UM = UriManager in + let str = UM.string_of_uri uri in + let xp t = "#xpointer(1/" ^ string_of_int (t + 1) in + match fi with + | [] -> str + | [t] -> str ^ xp t ^ ")" + | t :: c :: _ -> str ^ xp t ^ "/" ^ string_of_int c ^ ")" diff --git a/helm/ocaml/mathql/mQueryUtil.mli b/helm/ocaml/mathql/mQueryUtil.mli index 0e62e4a13..9881b3b54 100644 --- a/helm/ocaml/mathql/mQueryUtil.mli +++ b/helm/ocaml/mathql/mQueryUtil.mli @@ -33,18 +33,17 @@ (* *) (******************************************************************************) -val str_uref : MathQL.mquref -> string (* string linearization of a UriMan. reference *) -val str_tref : MathQL.mqtref -> string (* string linearization of a tokenized reference *) +val text_of_query : MathQL.query -> string -val xp_str_uref : MathQL.mquref -> string (* string linearization of a UriMan. reference *) +val text_of_result : MathQL.result -> string -> string -val xp_str_tref : MathQL.mqtref -> string (* string linearization of a tokenized reference *) +val query_of_text : Lexing.lexbuf -> MathQL.query -val out_query : MathQL.mquery -> string (* HTML representation of a query *) +val result_of_text : Lexing.lexbuf -> MathQL.result -val out_result : MathQL.mqresult -> string (* HTML representation of a query result *) -val tref_uref : MathQL.mquref -> MathQL.mqtref (* "tref of uref" conversion *) +type uriref = UriManager.uri * (int list) + +val string_of_uriref : uriref -> string -val parse_text : in_channel -> MathQL.mquery (* textual parsing of a query *) diff --git a/helm/ocaml/mathql/mathQL.ml b/helm/ocaml/mathql/mathQL.ml index d18ebbc92..d375d92af 100644 --- a/helm/ocaml/mathql/mathQL.ml +++ b/helm/ocaml/mathql/mathQL.ml @@ -28,109 +28,73 @@ (* PROJECT HELM *) (* *) (* Ferruccio Guidi *) -(* Domenico Lordi *) -(* 30/04/2002 *) +(* Irene Schena *) +(* 10/09/2002 *) (* *) (* *) (******************************************************************************) -exception MQInvalidURI of string -exception MQConnectionFailed of string -exception MQInvalidConnection of string - -(* Input types **************************************************************) -(* main type is mquery *) - -type mqrvar = string (* name *) - -type mqsvar = string (* name *) - -type mqlvar = string (* name *) - -type mqpt = string option (* PROTOCOL TOKENS *) - (* Some = constant string *) - (* None = single star: '*' *) - -type mqbt = (* BODY TOKENS *) - | MQBC of string (* a constant string *) - | MQBD (* a slash: '/' *) - | MQBQ (* a question mark: '?' *) - | MQBS (* a single star: '*' *) - | MQBSS (* a double star: '**' *) - -type mqft = (* FRAGMENT TOKENS *) - | MQFC of int (* a constant integer *) - | MQFS (* a single star: '*' *) - | MQFSS (* a double star: '**' *) - -type mquref = UriManager.uri * (int list) (* uri, fragment identifier *) - -type mqtref = mqpt * (mqbt list) * (mqft list) (* tokenized pattern reference *) - -type mqfunc = - | MQName (* Name *) - | MQTheory (* theory *) - | MQTitle (* DC properties *) - | MQContributor - | MQCreator - | MQPublisher - | MQSubject - | MQDescription - | MQDate - | MQType - | MQFormat - | MQIdentifier - | MQLanguage - | MQRelation - | MQSource - | MQCoverage - | MQRights - | MQInstitution - | MQContact - | MQFirstVersion - | MQModified - -type mqstring = - | MQCons of string (* constant *) - | MQFunc of mqfunc * mqrvar (* function, rvar *) - | MQStringRVar of mqrvar (* rvar *) - | MQStringSVar of mqsvar (* svar *) - | MQMConclusion (* main conclusion *) - | MQConclusion (* inner conclusion *) - -type mqorder = - | MQAsc (* ascending order *) - | MQDesc (* descending order *) - -type mqbool = - | MQTrue (* true *) - | MQFalse (* false *) - | MQAnd of mqbool * mqbool (* conjunction *) - | MQOr of mqbool * mqbool (* disjunction *) - | MQNot of mqbool (* negation *) - | MQIs of mqstring * mqstring (* case-sensitive comparison *) - | MQSetEqual of mqlist * mqlist (* the two lists denote the same set *) - | MQSubset of mqlist * mqlist (* the two lists denote two sets, the 1st subset of the 2nd *) - -and mqlist = - | MQReference of string list (* reference list *) - | MQPattern of mqtref (* pattern *) - | MQListLVar of mqlvar (* lvar *) - | MQListRVar of mqrvar (* rvar *) - | MQSelect of mqrvar * mqlist * mqbool (* rvar, list, boolean *) - | MQUse of mqlist * mqsvar (* list, Position attribute *) - | MQUsedBy of mqlist * mqsvar (* list, Position attribute *) - | MQUnion of mqlist * mqlist (* operands *) - | MQIntersect of mqlist * mqlist (* operands *) - | MQSortedBy of mqlist * mqorder * mqfunc (* ordering *) - | MQDiff of mqlist * mqlist (* set difference *) - | MQLetIn of mqlvar * mqlist * mqlist (* explicit lvar assignment *) - -type mquery = - | MQList of mqlist - -(* Output types *************************************************************) -(* main type is mqresult *) - -type mqresult = - | MQRefs of string list + +(* input data structures ****************************************************) + +type svar = string (* the name of a variable for a resource set *) + +type rvar = string (* the name of a variable for a resource *) + +type vvar = string (* the name of a variable for an attribute value *) + +type refine_op = ExactOp + | SubOp + | SuperOp + +type path = string list + +type vvar_list = vvar list + +type set_exp = SVar of svar + | RVar of rvar + | Ref of val_exp + | Pattern of val_exp + | Relation of refine_op * path * set_exp * vvar_list + | Select of rvar * set_exp * boole_exp + | Union of set_exp * set_exp + | Intersect of set_exp * set_exp + | Diff of set_exp * set_exp + | LetSVar of svar * set_exp * set_exp + | LetVVar of vvar * val_exp * set_exp + +and boole_exp = False + | True + | Not of boole_exp + | Ex of rvar list * boole_exp + | And of boole_exp * boole_exp + | Or of boole_exp * boole_exp + | Sub of val_exp * val_exp + | Meet of val_exp * val_exp + | Eq of val_exp * val_exp + +and val_exp = Const of string list + | RefOf of set_exp + | Record of rvar * vvar + | VVar of vvar + | Fun of string * val_exp + | Attribute of refine_op * path * val_exp + +type query = set_exp + + +(* output data structures ***************************************************) + +type value = string list (* the value of an attribute *) + +type attribute = string * value (* an attribute *) + +type attribute_group = attribute list (* a group of attributes *) + +type attribute_set = attribute_group list (* the attributes of an URI *) + +type resource = string * attribute_set (* an attributed URI *) + +type resource_set = resource list (* the query result *) + +type result = resource_set diff --git a/helm/ocaml/mathql_interpreter/.depend b/helm/ocaml/mathql_interpreter/.depend index fd3aadd14..72a3dd440 100644 --- a/helm/ocaml/mathql_interpreter/.depend +++ b/helm/ocaml/mathql_interpreter/.depend @@ -1,38 +1,22 @@ -diff.cmi: mathql_semantics.cmo -sortedby.cmi: mathql_semantics.cmo -select.cmi: mathql_semantics.cmo -intersect.cmi: mathql_semantics.cmo -union.cmi: mathql_semantics.cmo -pattern.cmi: mathql_semantics.cmo -use.cmi: mathql_semantics.cmo -letin.cmi: mathql_semantics.cmo dbconn.cmo: dbconn.cmi dbconn.cmx: dbconn.cmi -eval.cmo: eval.cmi -eval.cmx: eval.cmi utility.cmo: dbconn.cmi utility.cmi utility.cmx: dbconn.cmx utility.cmi -func.cmo: dbconn.cmi utility.cmi func.cmi -func.cmx: dbconn.cmx utility.cmx func.cmi -diff.cmo: mathql_semantics.cmo diff.cmi -diff.cmx: mathql_semantics.cmx diff.cmi -sortedby.cmo: func.cmi mathql_semantics.cmo utility.cmi sortedby.cmi -sortedby.cmx: func.cmx mathql_semantics.cmx utility.cmx sortedby.cmi -select.cmo: func.cmi mathql_semantics.cmo utility.cmi select.cmi -select.cmx: func.cmx mathql_semantics.cmx utility.cmx select.cmi -intersect.cmo: mathql_semantics.cmo intersect.cmi -intersect.cmx: mathql_semantics.cmx intersect.cmi -union.cmo: mathql_semantics.cmo union.cmi -union.cmx: mathql_semantics.cmx union.cmi -pattern.cmo: dbconn.cmi eval.cmi mathql_semantics.cmo utility.cmi pattern.cmi -pattern.cmx: dbconn.cmx eval.cmx mathql_semantics.cmx utility.cmx pattern.cmi -use.cmo: dbconn.cmi mathql_semantics.cmo utility.cmi use.cmi -use.cmx: dbconn.cmx mathql_semantics.cmx utility.cmx use.cmi -letin.cmo: letin.cmi -letin.cmx: letin.cmi -mqint.cmo: dbconn.cmi diff.cmi eval.cmi intersect.cmi letin.cmi \ - mathql_semantics.cmo pattern.cmi select.cmi sortedby.cmi union.cmi \ - use.cmi utility.cmi mqint.cmi -mqint.cmx: dbconn.cmx diff.cmx eval.cmx intersect.cmx letin.cmx \ - mathql_semantics.cmx pattern.cmx select.cmx sortedby.cmx union.cmx \ - use.cmx utility.cmx mqint.cmi +union.cmo: union.cmi +union.cmx: union.cmi +relation.cmo: dbconn.cmi union.cmi utility.cmi relation.cmi +relation.cmx: dbconn.cmx union.cmx utility.cmx relation.cmi +diff.cmo: diff.cmi +diff.cmx: diff.cmi +meet.cmo: meet.cmi +meet.cmx: meet.cmi +sub.cmo: sub.cmi +sub.cmx: sub.cmi +intersect.cmo: intersect.cmi +intersect.cmx: intersect.cmi +func.cmo: dbconn.cmi intersect.cmi utility.cmi func.cmi +func.cmx: dbconn.cmx intersect.cmx utility.cmx func.cmi +mqint.cmo: context.cmo dbconn.cmi diff.cmi intersect.cmi meet.cmi \ + relation.cmi sub.cmi union.cmi mqint.cmi +mqint.cmx: context.cmx dbconn.cmx diff.cmx intersect.cmx meet.cmx \ + relation.cmx sub.cmx union.cmx mqint.cmi diff --git a/helm/ocaml/mathql_interpreter/Makefile b/helm/ocaml/mathql_interpreter/Makefile index 290258d17..cd63e8ab4 100644 --- a/helm/ocaml/mathql_interpreter/Makefile +++ b/helm/ocaml/mathql_interpreter/Makefile @@ -2,16 +2,14 @@ PACKAGE = mathql_interpreter REQUIRES = helm-urimanager postgres unix helm-mathql PREDICATES = -INTERFACE_FILES = dbconn.mli eval.mli utility.mli func.mli diff.mli \ - sortedby.mli select.mli intersect.mli union.mli \ - pattern.mli use.mli letin.mli mqint.mli +INTERFACE_FILES = dbconn.mli utility.mli union.mli relation.mli diff.mli meet.mli sub.mli intersect.mli func.mli mqint.mli -IMPLEMENTATION_FILES = mathql_semantics.ml \ - $(INTERFACE_FILES:%.mli=%.ml) +IMPLEMENTATION_FILES = dbconn.ml utility.ml union.ml relation.ml diff.ml meet.ml sub.ml intersect.ml context.ml func.ml mqint.ml -EXTRA_OBJECTS_TO_INSTALL = mathql_semantics.ml mathql_semantics.cmi +# $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_CLEAN = +EXTRA_OBJECTS_TO_INSTALL = context.ml +EXTRA_OBJECTS_TO_CLEAN = include ../Makefile.common diff --git a/helm/ocaml/mathql_interpreter/context.ml b/helm/ocaml/mathql_interpreter/context.ml new file mode 100644 index 000000000..c9431d1af --- /dev/null +++ b/helm/ocaml/mathql_interpreter/context.ml @@ -0,0 +1,30 @@ +(* contexts *****************************************************************) + +type svar_context = (MathQL.svar * MathQL.resource_set) list + +type rvar_context = (MathQL.rvar * MathQL.resource) list + +type group_context = (MathQL.rvar * MathQL.attribute_group) list + +type vvar_context = (MathQL.vvar * MathQL.value) list + + +type context = {svars: svar_context; (* contesto delle svar *) + rvars: rvar_context; (* contesto delle rvar *) + groups: group_context; (* contesto dei gruppi *) + vvars: vvar_context (* contesto delle vvar introdotte con let-in *) + } + +let upd_svars c s = + {svars = s; rvars = c.rvars; groups = c.groups; vvars = c.vvars} + +let upd_rvars c s = + {svars = c.svars; rvars = s; groups = c.groups; vvars = c.vvars} + +let upd_groups c s = + {svars = c.svars; rvars = c.rvars; groups = s; vvars = c.vvars} + +let upd_vvars c s = + {svars = c.svars; rvars = c.rvars; groups = c.groups; vvars = s} + + diff --git a/helm/ocaml/mathql_interpreter/dbconn.ml b/helm/ocaml/mathql_interpreter/dbconn.ml index db4b8fb9c..b38eabe87 100644 --- a/helm/ocaml/mathql_interpreter/dbconn.ml +++ b/helm/ocaml/mathql_interpreter/dbconn.ml @@ -33,26 +33,21 @@ *) open MathQL;; -(* - * paramentri della connessione - * - * TODO: bisogna scegliere se questi parametri vengono - * passati come argomento - *) -(*let connection_param = "dbname=helm";;*) -let connection_param = "host=dotto.cs.unibo.it dbname=helm user=helm";; +exception InvalidURI of string +exception ConnectionFailed of string +exception InvalidConnection (* * connessione al db *) -let conn = ref None;; +let conn = ref None (* * controllo sulla connessione *) let pgc () = match !conn with - None -> raise (MQInvalidConnection connection_param) + None -> raise InvalidConnection | Some c -> c ;; @@ -62,11 +57,11 @@ let pgc () = * TODO * passare i parametri della connessione come argomento di init *) -let init () = +let init connection_param = try ( conn := Some (new Postgres.connection connection_param); ) with - _ -> raise (MQConnectionFailed ("init: " ^ connection_param)) + _ -> raise (ConnectionFailed ("init: " ^ connection_param)) ;; (* diff --git a/helm/ocaml/mathql_interpreter/dbconn.mli b/helm/ocaml/mathql_interpreter/dbconn.mli index c162cf00e..ecfbcd66a 100644 --- a/helm/ocaml/mathql_interpreter/dbconn.mli +++ b/helm/ocaml/mathql_interpreter/dbconn.mli @@ -24,5 +24,5 @@ *) val pgc : unit -> Postgres.connection -val init : unit -> unit +val init : string -> unit val close : unit -> unit diff --git a/helm/ocaml/mathql_interpreter/diff.ml b/helm/ocaml/mathql_interpreter/diff.ml index e2eea1bc1..b4e09196e 100644 --- a/helm/ocaml/mathql_interpreter/diff.ml +++ b/helm/ocaml/mathql_interpreter/diff.ml @@ -24,8 +24,8 @@ *) (* - * implementazione del comando DIFF - *) + * vecchia implementazione del comando DIFF + exception NotCompatible;; @@ -45,9 +45,7 @@ let rec intersect_attributes (attr1, attr2) = | _, _ -> raise NotCompatible (* same keys, different values *) ;; -(* - * implementazione del comando DIFF - *) + let rec diff_ex l1 l2 = let module S = Mathql_semantics in match (l1, l2) with @@ -67,11 +65,27 @@ let rec diff_ex l1 l2 = NotCompatible -> {S.uri = uri1 ; S.attributes = attributes1 ; S.extra = ""}::(diff_ex tl1 tl2) ;; +*) + +(* + * implementazione del comando DIFF + *) +let rec diff_ex rs1 rs2 = + match (rs1, rs2) with + [],_ -> [] + | l,[] -> l + | (uri1,l)::tl1,(uri2,_)::_ when uri1 < uri2 -> (uri1,l)::(diff_ex tl1 rs2) + | (uri1,_)::_,(uri2,_)::tl2 when uri2 < uri1 -> (diff_ex rs1 tl2) + | (uri1,_)::tl1, (uri2,_)::tl2 -> (diff_ex tl1 tl2) +;; + + + let diff_ex l1 l2 = - let before = Unix.time () in + let before = Sys.time () in let res = diff_ex l1 l2 in - let after = Unix.time () 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 diff --git a/helm/ocaml/mathql_interpreter/diff.mli b/helm/ocaml/mathql_interpreter/diff.mli index 8c247687f..1cd9cf4de 100644 --- a/helm/ocaml/mathql_interpreter/diff.mli +++ b/helm/ocaml/mathql_interpreter/diff.mli @@ -24,4 +24,4 @@ *) val diff_ex : - Mathql_semantics.result -> Mathql_semantics.result -> Mathql_semantics.result + MathQL.resource_set -> MathQL.resource_set -> MathQL.resource_set diff --git a/helm/ocaml/mathql_interpreter/func.ml b/helm/ocaml/mathql_interpreter/func.ml index 857a4c698..1338af008 100644 --- a/helm/ocaml/mathql_interpreter/func.ml +++ b/helm/ocaml/mathql_interpreter/func.ml @@ -29,65 +29,28 @@ open Dbconn;; open Utility;; -open MathQL;; - -(* - * implementazione della funzione NAME - * - * esempio: - * name "cic:/Algebra/CC_Props/CC_CauchySeq.ind#xpointer(1/1/1)" = CC_CauchySeq - *) -let func_name value = - try ( - let i = Str.search_forward (Str.regexp "[^/]*\.") value 0 in - let s = Str.matched_string value in - let retVal = Str.string_before s ((String.length s) - 1) in - retVal - ) with - Not_found -> "" -;; - -(* - * - *) -let func_theory value = - "" -;; +open Intersect;; (* * implementazione delle funzioni dublin core *) -let func_dc (value, name) = - let c = pgc () - and p = helm_property_id name in - pgresult_to_string (c#exec ("select t" ^ p ^ ".att1 from t" ^ p ^ " where " ^ "t" ^ p ^ ".att0 = '" ^ value ^ "'")) +let rec func_dc tab outv inv = function + [] -> [] + | s::tl -> let res = + let c = pgc () in + let q = ("select " ^ tab ^ "." ^ outv ^ " from " ^ tab ^ " where " ^ tab ^ "." ^ inv ^ " = '" ^ s ^ "'") in + pgresult_to_string_list (c#exec q) + in + append (res,(func_dc tab outv inv tl)) ;; (* * *) -let apply_func f value = +let fun_ex f value = match f with - MQName -> func_name value - | MQTheory -> func_theory value - | MQTitle -> func_dc (value, "title") - | MQContributor -> func_dc (value, "contributor") - | MQCreator -> func_dc (value, "creator") - | MQPublisher -> func_dc (value, "publisher") - | MQSubject -> func_dc (value, "subject") - | MQDescription -> func_dc (value, "description") - | MQDate -> func_dc (value, "date") - | MQType -> func_dc (value, "type") - | MQFormat -> func_dc (value, "format") - | MQIdentifier -> func_dc (value, "identifier") - | MQLanguage -> func_dc (value, "language") - | MQRelation -> func_dc (value, "relation") - | MQSource -> func_dc (value, "source") - | MQCoverage -> func_dc (value, "coverage") - | MQRights -> func_dc (value, "rights") - | MQInstitution -> func_dc (value, "institution") - | MQContact -> func_dc (value, "contact") - | MQFirstVersion -> func_dc (value, "firstversion") - | MQModified -> func_dc (value, "modified") + "name" -> func_dc "names" "name" "uri" value + | "reference" -> func_dc "names" "uri" "name" value + | _ -> [] ;; diff --git a/helm/ocaml/mathql_interpreter/func.mli b/helm/ocaml/mathql_interpreter/func.mli index fb68df82a..2858ce0da 100644 --- a/helm/ocaml/mathql_interpreter/func.mli +++ b/helm/ocaml/mathql_interpreter/func.mli @@ -23,4 +23,4 @@ * http://cs.unibo.it/helm/. *) -val apply_func: MathQL.mqfunc -> string -> string +val fun_ex: string -> MathQL.value -> MathQL.value diff --git a/helm/ocaml/mathql_interpreter/intersect.ml b/helm/ocaml/mathql_interpreter/intersect.ml index bf0d05c2c..73bebaa50 100644 --- a/helm/ocaml/mathql_interpreter/intersect.ml +++ b/helm/ocaml/mathql_interpreter/intersect.ml @@ -23,105 +23,53 @@ * http://cs.unibo.it/helm/. *) -exception NotCompatible;; -(* intersect_attributes is successful iff there is no attribute with *) -(* two different values in the two lists. The returned list is the *) -(* union of the two lists. *) -let rec intersect_attributes (attr1, attr2) = - match attr1, attr2 with - [],_ -> attr2 - | _,[] -> attr1 - | (key1,value1)::tl1, (key2,_)::_ when key1 < key2 -> - (key1,value1)::(intersect_attributes (tl1,attr2)) - | (key1,_)::_, (key2,value2)::tl2 when key2 < key1 -> - (key2,value2)::(intersect_attributes (attr1,tl2)) - | entry1::tl1, entry2::tl2 when entry1 = entry2 -> - entry1::(intersect_attributes (tl1,tl2)) - | _, _ -> raise NotCompatible (* same keys, different values *) +(* Catenates two lists preserving order and getting rid of duplicates *) +let rec append (l1,l2) = + match l1,l2 with + [],_ -> l2 + | _,[] -> l1 + | s1::tl1, s2::_ when s1 < s2 -> s1::append (tl1,l2) + | s1::_, s2::tl2 when s2 < s1 -> s2::append (l1,tl2) + | s1::tl1, s2::tl2 -> s1::append (tl1,tl2) + +;; + + +(* Sums two attribute groups preserving order *) +let rec sum_groups(gr1, gr2) = + match gr1, gr2 with + [],_ -> gr2 + | _,[] -> gr1 + | gr1, gr2 when gr1 = gr2 -> gr1 + | (key1,l1)::tl1, (key2,l2)::_ when key1 < key2 -> (key1,l1)::(sum_groups (tl1,gr2)) + | (key1,l1)::_, (key2,l2)::tl2 when key2 < key1 -> (key2,l2)::(sum_groups (gr1,tl2)) + | (key1,l1)::tl1, (key2,l2)::tl2 -> (key1,(append (l1,l2)))::(sum_groups (tl1,tl2)) + +;; + +(* Product between an attribute set and a group of attributes *) +let rec sub_prod (aset, gr) = (*prende un aset e un gr, fa la somma tra tutti i gruppi di aset e gr*) + match aset with + [] -> [] + | gr1::tl1 -> sum_groups (gr1, gr)::(sub_prod(tl1, gr)) ;; -(* preserves order and gets rid of duplicates *) -let rec intersect_ex l1 l2 = - let module S = Mathql_semantics in - match (l1, l2) with - [],_ - | _,[] -> [] - | {S.uri = uri1}::tl1, - {S.uri = uri2}::_ when uri1 < uri2 -> intersect_ex tl1 l2 - | {S.uri = uri1}::_, - {S.uri = uri2}::tl2 when uri2 < uri1 -> intersect_ex l1 tl2 - | {S.uri = uri1 ; S.attributes = attributes1}::tl1, - {S.uri = uri2 ; S.attributes = attributes2}::tl2 -> - try - let attributes' = intersect_attributes (attributes1,attributes2) in - {S.uri = uri1 ; S.attributes = attributes' ; S.extra = ""}::(intersect_ex tl1 tl2) - with - NotCompatible -> - intersect_ex tl1 tl2 + +(* Cartesian product between two attribute sets*) +let rec prod (as1, as2) = + match as1, as2 with + [],_ -> [] + | _,[] -> [] + | gr1::tl1, _ -> append((sub_prod (as2, gr1)), (prod (tl1, as2))) (* chiamo la sub_prod con un el. as1 e as2 *) ;; -let intersect_ex l1 l2 = - (* PRE-CLAUDIO - (*let _ = print_string ("INTERSECT ") - and t = Unix.time () in*) - let result = - match (l1, l2) with - ((head1::tail1), (head2::tail2)) -> - (match (head1, head2) with - ([], _) -> assert false (* gli header non devono mai essere vuoti *) - | (_, []) -> assert false (* devono contenere almeno [retVal] *) - | (_, _) -> - (match (tail1, tail2) with - ([], _) -> [["retVal"]] (* se una delle due code e' vuota... *) - | (_, []) -> [["retVal"]] (* ... l'intersezione e' vuota *) - | (_, _) -> - [head2 @ - (List.find_all - (function t -> not (List.mem t head2)) - head1 - ) - ] (* header del risultato finale *) - @ - intersect_tails (List.tl head1) tail1 (List.tl head2) tail2 - (* - List.fold_left - (fun par1 elem1 -> par1 @ - List.map - (fun elem2 -> - [(List.hd elem1)] @ - (xres_join_context (List.tl head1) (List.tl elem1) - (List.tl head2) (List.tl elem2) - ) - ) - (List.find_all (* *) - (fun elem2 -> (* trova tutti gli elementi della lista tail2 *) - ((List.hd elem1) = (List.hd elem2)) && (* che stanno in tail1 *) - not ((xres_join_context (List.tl head1) (List.tl elem1) - (List.tl head2) (List.tl elem2)) = []) - (* e per i quali la xres_join_context non sia vuota *) - ) - tail2 (* List.find_all *) - ) - ) - [] - tail1 (* per ogni elemento di tail1 applica la List.fold_left *) - *) - ) (* match *) - ) - | _ -> [] - in - (*let _ = print_endline (string_of_float (Unix.time () -. t)); flush stdout in*) - result*) - let before = Unix.time () in - let res = intersect_ex l1 l2 in - let after = Unix.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 - ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^ - ": " ^ diff ^ "s") ; - flush stdout ; - res +(* Intersection between two resource sets, preserves order and gets rid of duplicates *) +let rec intersect_ex rs1 rs2 = + match (rs1, rs2) with + [],_ + | _,[] -> [] + | (uri1,_)::tl1, (uri2,_)::_ when uri1 < uri2 -> intersect_ex tl1 rs2 + | (uri1,_)::_, (uri2,_)::tl2 when uri2 < uri1 -> intersect_ex rs1 tl2 + | (uri1,as1)::tl1, (uri2,as2)::tl2 -> (uri1, prod(as1,as2))::intersect_ex tl1 tl2 ;; diff --git a/helm/ocaml/mathql_interpreter/intersect.mli b/helm/ocaml/mathql_interpreter/intersect.mli index 3b721b4f7..5045162b6 100644 --- a/helm/ocaml/mathql_interpreter/intersect.mli +++ b/helm/ocaml/mathql_interpreter/intersect.mli @@ -24,4 +24,7 @@ *) val intersect_ex : - Mathql_semantics.result -> Mathql_semantics.result -> Mathql_semantics.result + MathQL.result -> MathQL.result -> MathQL.result + +val append: + (string list * string list) -> string list diff --git a/helm/ocaml/mathql_interpreter/meet.ml b/helm/ocaml/mathql_interpreter/meet.ml new file mode 100644 index 000000000..bf0b5d780 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/meet.ml @@ -0,0 +1,34 @@ +(* Copyright (C) 2000, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + + +let rec meet_ex v1 v2 = + match v1,v2 with + [],_ + | _,[] -> false + | s1::tl1, s2::_ when s1 < s2 -> meet_ex tl1 v2 + | s1::_, s2::tl2 when s2 < s1 -> meet_ex v1 tl2 + | _, _ -> true +;; diff --git a/helm/ocaml/mathql_interpreter/meet.mli b/helm/ocaml/mathql_interpreter/meet.mli new file mode 100644 index 000000000..366abd7fd --- /dev/null +++ b/helm/ocaml/mathql_interpreter/meet.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2000, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + + +val meet_ex: MathQL.value -> MathQL.value -> bool diff --git a/helm/ocaml/mathql_interpreter/mqint.ml b/helm/ocaml/mathql_interpreter/mqint.ml index ed6b515c7..e1dc6f8d9 100644 --- a/helm/ocaml/mathql_interpreter/mqint.ml +++ b/helm/ocaml/mathql_interpreter/mqint.ml @@ -23,223 +23,166 @@ * http://cs.unibo.it/helm/. *) + + + (* * implementazione del'interprete MathQL *) -open MathQL;; -open Eval;; -open Utility;; + + + + open Dbconn;; -open Pattern;; open Union;; open Intersect;; +open Meet;; +open Sub;; +open Context;; open Diff;; -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) -;; +open Relation;; +open Func;; -(* - * inizializzazione della connessione al database - *) -let init () = - let _ = Dbconn.init () in - 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 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 = Unix.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 (Unix.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;; +let init connection_param = Dbconn.init connection_param -(* - * 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 close () = Dbconn.close () +let check () = Dbconn.pgc () -(* - * - *) -let execute q = - match q with - MQList qq -> xres_to_res (execute_ex [] qq) -;; +exception BooleExpTrue -(* - * chiusura della connessione al database - *) -let close () = Dbconn.close ();; +let stat = ref false + +let set_stat b = stat := b + +let get_stat () = ! stat + +(* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *) + +let rec exec_set_exp c = function + MathQL.SVar svar -> List.assoc svar c.svars + | 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) -> + let before = Sys.time() in + let rs1 = exec_set_exp c sexp1 in + let rs2 = exec_set_exp c sexp2 in + let res = intersect_ex rs1 rs2 in + let after = Sys.time() in + let ll1 = string_of_int (List.length rs1) in + let ll2 = string_of_int (List.length rs2) in + let diff = string_of_float (after -. before) in + if !stat then + (print_endline("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^ + ": " ^ diff ^ "s"); + flush stdout); + res + | 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 + if !stat then + (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 + if !stat then + (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 + let res = exec_set_exp c1 sexp in + if !stat then + (print_string ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": "); + print_endline (string_of_float (Sys.time() -. before) ^ "s"); + flush stdout); + res + | MathQL.Relation (rop, path, sexp, attl) -> + let before = Sys.time() in + let res = relation_ex rop path (exec_set_exp c sexp) attl in + if !stat then + (print_string ("RELATION " ^ (List.hd path) ^ " = " ^ string_of_int(List.length res) ^ ": "); + print_endline (string_of_float (Sys.time() -. before) ^ "s"); + flush stdout); + res + | MathQL.Select (rvar, sexp, bexp) -> + let before = Sys.time() in + 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 + let res = select_ex rset in + if !stat then + (print_string ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": "); + print_endline (string_of_float (Sys.time() -. before) ^ "s"); + flush stdout); + res + | MathQL.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) + | _ -> assert false + +(* valuta una MathQL.boole_exp e ritorna un boole *) + +and exec_boole_exp c = function + MathQL.False -> false + | MathQL.True -> true + | MathQL.Not x -> not (exec_boole_exp c x) + | MathQL.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y) + | MathQL.Or (x, y) -> (exec_boole_exp c x) || (exec_boole_exp c y) + | MathQL.Sub (vexp1, vexp2) -> sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2) + | MathQL.Meet (vexp1, vexp2) -> meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2) + | MathQL.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2) + | 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 = + 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 + +(* 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 + let rec edup = function + + [] -> [] + | s::tl -> if tl <> [] then + if s = (List.hd tl) then edup tl + else s::(edup tl) + else s::[] + in + edup ol + | MathQL.Record (rvar, vvar) -> List.assoc vvar (List.assoc rvar c.groups) + + | MathQL.VVar s -> List.assoc s c.vvars + | MathQL.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp) + | MathQL.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp) + | _ -> assert false + +(* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *) +and execute x = + exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x diff --git a/helm/ocaml/mathql_interpreter/mqint.mli b/helm/ocaml/mathql_interpreter/mqint.mli index 60f00f50c..e969e5c66 100644 --- a/helm/ocaml/mathql_interpreter/mqint.mli +++ b/helm/ocaml/mathql_interpreter/mqint.mli @@ -23,23 +23,14 @@ * http://cs.unibo.it/helm/. *) -(* - * interfaccia dell'interprete MathQL - *) +val init : string -> unit (* open database *) -open MathQL;; +val execute : MathQL.query -> MathQL.result (* execute query *) -(* - * inizializzazione del database - *) -val init: unit -> unit +val close : unit -> unit (* close database *) -(* - * esecuzione di query - *) -val execute: mquery -> mqresult;; +val check : unit -> Postgres.connection (* check connection *) -(* - * chiusura del database - *) -val close: unit -> unit +val set_stat : bool -> unit (* set stat emission *) + +val get_stat : unit -> bool (* check stat emission *) diff --git a/helm/ocaml/mathql_interpreter/pattern.ml b/helm/ocaml/mathql_interpreter/pattern.ml index 576226008..993617bb8 100644 --- a/helm/ocaml/mathql_interpreter/pattern.ml +++ b/helm/ocaml/mathql_interpreter/pattern.ml @@ -35,7 +35,7 @@ open Mathql_semantics;; let pattern_ex (apreamble, apattern, afragid) = let c = pgc () in (*let _ = print_string ("USE ") - and t = Unix.time () in*) + and t = Sys.time () in*) (*let r1 = helm_class_id "MathResource" in*) (*let qq = "select att0 from t" ^ r1 ^ " where att0 " ^ (pattern_match apreamble apattern afragid) ^ " order by t" ^ r1 ^ ".att0 asc" in*) (*PRE-CLAUDIO @@ -52,7 +52,7 @@ print_endline qq ; flush stderr ; c#exec (qq) in (* PRE-CLAUDIO - (*let _ = print_endline (string_of_float (Unix.time () -. t)); flush stdout in*) + (*let _ = print_endline (string_of_float (Sys.time () -. t)); flush stdout in*) result*) List.map (function uri -> {uri = uri ; attributes = [] ; extra = ""}) diff --git a/helm/ocaml/mathql_interpreter/relation.ml b/helm/ocaml/mathql_interpreter/relation.ml new file mode 100644 index 000000000..159369ad2 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/relation.ml @@ -0,0 +1,76 @@ +(* Copyright (C) 2000, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://www.cs.unibo.it/helm/. + *) + + +(* + * implementazione del comando Relation + *) + + + + +open Union;; +open Dbconn;; +open Utility;; + + + + +let get_prop_id propl = + let prop = List.hd propl in + if prop="refObj" then "F" + else if prop="backPointer" then "B" + else assert false +;; + + +let relation_ex rop path rset attl = + if path = [] then [] + else + let usek = get_prop_id path in + let vvar = if attl = [] then "position" + else List.hd attl + in + let c = pgc () in + let rset_list = (* lista di singoletti:resource_set di un elemento *) + (List.fold_left (fun acc (uri,l) -> + let tv = pgresult_to_string (c#exec ("select id from registry where uri='" ^ uri ^ "'")) in + let qq = "select uri, context from t" ^ tv ^ " where prop_id='" ^ usek ^ "' order by uri asc" in + let res = c#exec qq in + (List.map + (function + [uri;context] -> [(uri,[[(vvar,[context])]])] + | _ -> assert false ) + res#get_list) @ acc + ) + [] rset + ) + in + let rec edup = function + [] -> [] + | rs1::tl -> union_ex rs1 (edup tl) + in + edup rset_list +;; diff --git a/helm/ocaml/mathql_interpreter/relation.mli b/helm/ocaml/mathql_interpreter/relation.mli new file mode 100644 index 000000000..392d670cf --- /dev/null +++ b/helm/ocaml/mathql_interpreter/relation.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2000, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +val relation_ex : + MathQL.refine_op -> MathQL.path -> MathQL.resource_set -> MathQL.vvar_list -> MathQL.resource_set diff --git a/helm/ocaml/mathql_interpreter/select.ml b/helm/ocaml/mathql_interpreter/select.ml index c25ea2625..ee9f329ba 100644 --- a/helm/ocaml/mathql_interpreter/select.ml +++ b/helm/ocaml/mathql_interpreter/select.ml @@ -26,7 +26,7 @@ (* * implementazione del comando SELECT *) - +(* open MathQL;; open Func;; open Utility;; @@ -139,12 +139,15 @@ let rec is_good env = *) let select_ex env avar alist abool = let _ = print_string ("SELECT = ") - and t = Unix.time () in + and t = Sys.time () in let result = List.filter (function entry -> is_good ((avar,entry)::env) abool) alist in print_string (string_of_int (List.length result) ^ ": ") ; - print_endline (string_of_float (Unix.time () -. t) ^ "s") ; + print_endline (string_of_float (Sys.time () -. t) ^ "s") ; flush stdout ; result -;; +;; *) + +let select_ex rvar rset bexp + diff --git a/helm/ocaml/mathql_interpreter/sortedby.ml b/helm/ocaml/mathql_interpreter/sortedby.ml index 177cf3c03..b9a05a002 100644 --- a/helm/ocaml/mathql_interpreter/sortedby.ml +++ b/helm/ocaml/mathql_interpreter/sortedby.ml @@ -35,7 +35,7 @@ open Utility;; * implementazione del comando SORTEDBY *) let sortedby_ex alist order afunc = - let before = Unix.time () in + let before = Sys.time () in let res = let module S = Mathql_semantics in (Sort.list @@ -50,7 +50,7 @@ let sortedby_ex alist order afunc = ) ) in - let after = Unix.time () + let after = Sys.time () and ll1 = string_of_int (List.length alist) in let diff = string_of_float (after -. before) in print_endline diff --git a/helm/ocaml/mathql_interpreter/sub.ml b/helm/ocaml/mathql_interpreter/sub.ml new file mode 100644 index 000000000..e59bf049d --- /dev/null +++ b/helm/ocaml/mathql_interpreter/sub.ml @@ -0,0 +1,34 @@ +(* Copyright (C) 2000, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + + +let rec sub_ex v1 v2 = + match v1,v2 with + [],_ -> true + | _,[] -> false + | s1::_, s2::_ when s1 < s2 -> false + | s1::_, s2::tl2 when s2 < s1 -> sub_ex v1 tl2 + | s1::tl1, s2::tl2 -> sub_ex tl1 tl2 +;; diff --git a/helm/ocaml/mathql_interpreter/sub.mli b/helm/ocaml/mathql_interpreter/sub.mli new file mode 100644 index 000000000..b81f542c4 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/sub.mli @@ -0,0 +1,27 @@ +(* Copyright (C) 2000, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + + +val sub_ex: MathQL.value -> MathQL.value -> bool diff --git a/helm/ocaml/mathql_interpreter/union.ml b/helm/ocaml/mathql_interpreter/union.ml index c8e46cd0b..e2d9fcb01 100644 --- a/helm/ocaml/mathql_interpreter/union.ml +++ b/helm/ocaml/mathql_interpreter/union.ml @@ -27,113 +27,26 @@ * 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 + [],l + | l,[] -> l + | g1::tl1,g2::_ when g1 < g2 -> g1::(merge tl1 l2) + | g1::_,g2::tl2 when g2 < g1 -> g2::(merge l1 tl2) + | g1::tl1,g2::tl2 -> g1::(merge tl1 tl2) +;; (* preserves order and gets rid of duplicates *) -let rec union_ex l1 l2 = - let module S = Mathql_semantics in - match (l1, l2) with +let rec union_ex rs1 rs2 = + match (rs1, rs2) with [],l | l,[] -> l - | ({S.uri = uri1} as entry1)::tl1, - ({S.uri = uri2} as entry2)::_ when uri1 < uri2 -> - entry1::(union_ex tl1 l2) - | ({S.uri = uri1} as entry1)::_, - ({S.uri = uri2} as entry2)::tl2 when uri2 < uri1 -> - entry2::(union_ex l1 tl2) - | entry1::tl1,entry2::tl2 -> (* same entry *) - if entry1 = entry2 then (* same attributes *) - entry1::(union_ex tl1 tl2) - else - assert false + | (uri1,l1)::tl1,(uri2,_)::_ when uri1 < uri2 -> (uri1,l1)::(union_ex tl1 rs2) + | (uri1,_)::_,(uri2,l2)::tl2 when uri2 < uri1 -> (uri2,l2)::(union_ex rs1 tl2) + | (uri1,l1)::tl1,(uri2,l2)::tl2 -> if l1 = l2 then (uri1,l1)::(union_ex tl1 tl2) + else (uri1,merge l1 l2)::(union_ex tl1 tl2) ;; -let union_ex l1 l2 = - let before = Unix.time () in - let res = union_ex l1 l2 in - let after = Unix.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 -;; + diff --git a/helm/ocaml/mathql_interpreter/union.mli b/helm/ocaml/mathql_interpreter/union.mli index 6b6ba6d27..6890bdb0c 100644 --- a/helm/ocaml/mathql_interpreter/union.mli +++ b/helm/ocaml/mathql_interpreter/union.mli @@ -24,4 +24,4 @@ *) val union_ex : - Mathql_semantics.result -> Mathql_semantics.result -> Mathql_semantics.result +MathQL.result -> MathQL.result -> MathQL.result diff --git a/helm/ocaml/mathql_interpreter/use.ml b/helm/ocaml/mathql_interpreter/use.ml index 93ed9a8a4..f5648cab1 100644 --- a/helm/ocaml/mathql_interpreter/use.ml +++ b/helm/ocaml/mathql_interpreter/use.ml @@ -44,66 +44,25 @@ open Dbconn;; * output: string list list; lista su cui e' stato eseguito il * comando USE/USED BY *) -let use_ex alist asvar usek = - (*(*let _ = print_string ("USE ") - and t = Unix.time () in*) - let result = - let c = pgc () - in - [ (List.hd alist) @ [asvar] ] - @ - Sort.list - (fun l m -> List.hd l < List.hd m) - (List.fold_left - (fun parziale xres -> - (*let r1 = helm_property_id usek - and r2 = helm_property_id "position" - and r3 = helm_property_id "occurrence" - in - let qq = "select distinct t" ^ r3 ^ ".att1, t" ^ r2 ^ ".att1 " ^ - "from t" ^ r3 ^ ", t" ^ r2 ^ ", t" ^ r1 ^ " " ^ - "where " ^ "t" ^ r1 ^ ".att0 = '" ^ (List.hd xres) ^ "' and t" ^ r1 ^ - ".att1 = t" ^ r2 ^ ".att0 and t" ^ r1 ^ ".att1 = t" ^ r3 ^ - ".att0 order by t" ^ r3 ^ ".att1 asc"*) - let tv = pgresult_to_string (c#exec ("select id from registry where uri='" ^ (List.hd xres) ^ "'")) in - let _ = print_endline ("DEBUG (use.ml): " ^ tv) in - let qq = "select uri, context from t" ^ tv ^ " where back_for='" ^ usek ^ "'" in - let res = c#exec qq in - (List.map - (fun l -> [List.hd l] @ List.tl xres @ List.tl l) - res#get_list - ) - @ - parziale - ) - [] - (List.tl alist) - ) - in - (*let _ = print_endline (string_of_float (Unix.time () -. t)); flush stdout in*) +let get_prop_id prop = + if prop="refObj" then "F" + else if prop="backPointer" then "B" + else assert false + ;; + + +let relation_ex rop path rset attl = + let usek = get_prop_id (List.hd path) in - *) -let module S = Mathql_semantics in -let _ = print_string ("USE ") -and t = Unix.time () in +let _ = print_string ("RELATION "^usek) +and t = Sys.time () in let result = let c = pgc () in Sort.list - (fun {S.uri = uri1} {S.uri = uri2} -> uri1 < uri2) + (fun (uri1-> uri1 < uri2) (List.fold_left - (fun parziale {S.uri = uri ; S.attributes = attributes} -> + (fun parziale (uri,aset)-> print_string uri ; - (* RSSDB - let r1 = helm_property_id usek - and r2 = helm_property_id "position" - and r3 = helm_property_id "occurrence" - in - let qq = "select distinct t" ^ r3 ^ ".att1, t" ^ r2 ^ ".att1 " ^ - "from t" ^ r3 ^ ", t" ^ r2 ^ ", t" ^ r1 ^ " " ^ - "where " ^ "t" ^ r1 ^ ".att0 = '" ^ (List.hd xres) ^ "' and t" ^ r1 ^ - ".att1 = t" ^ r2 ^ ".att0 and t" ^ r1 ^ ".att1 = t" ^ r3 ^ - ".att0 order by t" ^ r3 ^ ".att1 asc" - *) let tv = pgresult_to_string (c#exec ("select id from registry where uri='" ^ uri ^ "'")) @@ -120,11 +79,11 @@ let result = ) res#get_list ) @ parziale - ) [] alist + ) [] rset ) in print_string (" = " ^ string_of_int (List.length result) ^ ": ") ; -print_endline (string_of_float (Unix.time () -. t) ^ "s") ; +print_endline (string_of_float (Sys.time () -. t) ^ "s") ; flush stdout ; result ;; -- 2.39.2