X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Focaml%2Fmathql%2FmQueryUtil.ml;h=1051e2a7e63113c0c1b569ea347b09caed804018;hb=a32bcc14672dae13e8bb725e54c819958dfdb677;hp=cb60eff629cf5fa90ef1f967e56e00875951178c;hpb=56e6fd40e7723c2b0301e3fcdb1273692c42e590;p=helm.git diff --git a/helm/ocaml/mathql/mQueryUtil.ml b/helm/ocaml/mathql/mQueryUtil.ml index cb60eff62..1051e2a7e 100644 --- a/helm/ocaml/mathql/mQueryUtil.ml +++ b/helm/ocaml/mathql/mQueryUtil.ml @@ -23,214 +23,83 @@ * http://cs.unibo.it/helm/. *) -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Ferruccio Guidi *) -(* 30/04/2002 *) -(* *) -(* *) -(******************************************************************************) - -open MathQL - -(* string linearization of a reference *) - -let str_btoken = function - | MQBC s -> s - | MQBD -> "/" - | MQBQ -> "?" - | MQBS -> "*" - | MQBSS -> "**" - -let str_prot = function - | Some s -> s - | None -> "*" - -let rec str_body = function - | [] -> "" - | head :: tail -> str_btoken head ^ str_body tail - -let str_frag l = - match l with - [] -> "" - | l -> - let str_ftokens = - List.fold_left - (fun i t -> - i ^ - match t with - MQFC i -> "/" ^ string_of_int i - | MQFS -> "/*" - | MQFSS -> "/**" - ) "" l - in - "#xpointer(1" ^ str_ftokens ^ ")" -;; - -let str_tref (p, b, i) = - str_prot p ^ ":/" ^ str_body b ^ str_frag i -;; - -let str_uref (u, i) = - UriManager.string_of_uri u ^ - match i with - [] -> "" - | l -> - "#xpointer(1" ^ - List.fold_left (fun i n -> i ^ "/" ^ string_of_int n) "" l ^ - ")" -;; - -(* raw HTML representation *) - -let key s = "" ^ s ^ " " - -let sub s = " " ^ s ^ " " - -let sub2 s = "" ^ s ^ "" - -let sym s = s - -let sep s = s - -let str s = "'" ^ s ^ "'" - -let pat s = "\"" ^ s ^ "\"" - -let res s = "\"" ^ s ^ "\"" - -let nl () = "
" - -let par () = "

" - -(* 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_sequence 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 - | MQMinimize l -> key "minimize" ^ out_list l - -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) +(* AUTOR: Ferruccio Guidi + *) -*) +(* time handling ***********************************************************) + +type time = float * float + +let start_time () = + (Sys.time (), Unix.time ()) + +let stop_time (s0, u0) = + let s1 = Sys.time () in + let u1 = Unix.time () in + Printf.sprintf "%.2fs,%.2fs" (s1 -. s0) (u1 -. u0) + +(* operations on lists *****************************************************) + +type 'a comparison = Lt + | Gt + | Eq of 'a + +let list_join f l1 l2 = + let rec aux = function + | [], v + | v, [] -> v + | ((h1 :: t1) as v1), ((h2 :: t2) as v2) -> begin + match f h1 h2 with + | Lt -> h1 :: aux (t1, v2) + | Gt -> h2 :: aux (v1, t2) + | Eq h -> h :: aux (t1, t2) + end + in aux (l1, l2) + +let list_meet f l1 l2 = + let rec aux = function + | [], v + | v, [] -> [] + | ((h1 :: t1) as v1), ((h2 :: t2) as v2) -> begin + match f h1 h2 with + | Lt -> aux (t1, v2) + | Gt -> aux (v1, t2) + | Eq h -> h :: aux (t1, t2) + end + in aux (l1, l2) + +let rec flat_list out f s = function + | [] -> () + | [a] -> f a + | a :: tail -> f a; out s; flat_list out f s tail + +let rec add_assoc ap = function + | [] -> [ap] + | head :: tail when fst head = fst ap -> ap :: tail + | head :: tail -> head :: add_assoc ap tail + +(* int of string ************************************************************) + +type t = End + | Space + | Figure of int + | Error + +let int_of_string s = + let l = String.length s in + let get_t i = + if i = l then End else + match s.[i] with + | ' ' | '\t' | '\r' | 'n' -> Space + | '0' .. '9' -> Figure (Char.code s.[i] - Char.code '0') + | _ -> Error + in + let rec aux i xv = match get_t i, xv with + | Error, _ + | End, None -> raise (Failure "int_of_string") + | End, Some v -> v + | Space, xv -> aux (succ i) xv + | Figure f, None -> aux (succ i) (Some f) + | Figure f, Some v -> aux (succ i) (Some (10 * v + f)) + in + aux 0 None