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
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
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 }
/******************************************************************************/
%{
- 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 <string> ID STR
- %token <MathQL.mqtref> 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 <string> qstr
- %type <MathQL.mqtref> ref
- %type <MathQL.mquery> query
+ %nonassoc REL
+ %nonassoc NOT EX IN ATTR
+
+ %start qstr query result
+ %type <string> qstr
+ %type <MathQL.query> query
+ %type <MathQL.result> 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 }
(* *)
(******************************************************************************)
-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 ^ ")"
(* *)
(******************************************************************************)
-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 *)
(* PROJECT HELM *)
(* *)
(* Ferruccio Guidi <fguidi@cs.unibo.it> *)
-(* Domenico Lordi <lordi@cs.unibo.it> *)
-(* 30/04/2002 *)
+(* Irene Schena <schena@cs.unibo.it> *)
+(* 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.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
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
--- /dev/null
+(* 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}
+
+
*)
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
;;
* 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))
;;
(*
*)
val pgc : unit -> Postgres.connection
-val init : unit -> unit
+val init : string -> unit
val close : unit -> unit
*)
(*
- * implementazione del comando DIFF
- *)
+ * vecchia implementazione del comando DIFF
+
exception NotCompatible;;
| _, _ -> 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
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
*)
val diff_ex :
- Mathql_semantics.result -> Mathql_semantics.result -> Mathql_semantics.result
+ MathQL.resource_set -> MathQL.resource_set -> MathQL.resource_set
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
+ | _ -> []
;;
* http://cs.unibo.it/helm/.
*)
-val apply_func: MathQL.mqfunc -> string -> string
+val fun_ex: string -> MathQL.value -> MathQL.value
* 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
;;
*)
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
--- /dev/null
+(* 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
+;;
--- /dev/null
+(* 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
* 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
* 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 *)
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
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 = ""})
--- /dev/null
+(* 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
+;;
--- /dev/null
+(* 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
(*
* implementazione del comando SELECT
*)
-
+(*
open MathQL;;
open Func;;
open Utility;;
*)
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
+
* 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
)
)
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
--- /dev/null
+(* 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
+;;
--- /dev/null
+(* 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
* 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
-;;
+
*)
val union_ex :
- Mathql_semantics.result -> Mathql_semantics.result -> Mathql_semantics.result
+MathQL.result -> MathQL.result -> MathQL.result
* 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 ^ "'"))
) 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
;;
projects / helm.git / commitdiff