on top of RDF-Suite.
META.helm-cic_proof_checking
META.helm-cic_textual_parser
META.helm-cic_unification
+META.helm-mathql_interpreter
Makefile
Makefile.common
configure
--- /dev/null
+requires="helm-urimanager pgocaml"
+version="0.0.1"
+archive(byte)="mathql_interpreter.cma"
+archive(native)="mathql_interpreter.cmxa"
+linkopts=""
# Warning: the modules must be in compilation order
MODULES = xml urimanager getter pxp cic cic_annotations cic_annotations_cache \
- cic_cache cic_proof_checking cic_textual_parser cic_unification
+ cic_cache cic_proof_checking cic_textual_parser cic_unification \
+ mathql_interpreter
OCAMLFIND_DEST_DIR = @OCAMLFIND_DEST_DIR@
OCAMLFIND_META_DIR = @OCAMLFIND_META_DIR@
--- /dev/null
+*.cm[iaox] *.cmxa
--- /dev/null
+eval.cmi: mathql.cmo
+select.cmi: mathql.cmo
+pattern.cmi: mathql.cmo
+mqint.cmi: mathql.cmo
+dbconn.cmo: mathql.cmo dbconn.cmi
+dbconn.cmx: mathql.cmx dbconn.cmi
+eval.cmo: mathql.cmo eval.cmi
+eval.cmx: mathql.cmx eval.cmi
+utility.cmo: utility.cmi
+utility.cmx: utility.cmi
+func.cmo: func.cmi
+func.cmx: func.cmi
+select.cmo: func.cmi mathql.cmo utility.cmi select.cmi
+select.cmx: func.cmx mathql.cmx utility.cmx select.cmi
+intersect.cmo: intersect.cmi
+intersect.cmx: intersect.cmi
+union.cmo: union.cmi
+union.cmx: union.cmi
+pattern.cmo: dbconn.cmi eval.cmi utility.cmi pattern.cmi
+pattern.cmx: dbconn.cmx eval.cmx utility.cmx pattern.cmi
+use.cmo: dbconn.cmi utility.cmi use.cmi
+use.cmx: dbconn.cmx utility.cmx use.cmi
+mqint.cmo: dbconn.cmi eval.cmi intersect.cmi mathql.cmo pattern.cmi \
+ select.cmi union.cmi use.cmi utility.cmi mqint.cmi
+mqint.cmx: dbconn.cmx eval.cmx intersect.cmx mathql.cmx pattern.cmx \
+ select.cmx union.cmx use.cmx utility.cmx mqint.cmi
--- /dev/null
+PACKAGE = mathql_interpreter
+REQUIRES = helm-urimanager pgocaml
+PREDICATES =
+
+INTERFACE_FILES = dbconn.mli eval.mli utility.mli func.mli \
+ select.mli intersect.mli union.mli pattern.mli use.mli \
+ mqint.mli
+
+IMPLEMENTATION_FILES = mathql.ml $(INTERFACE_FILES:%.mli=%.ml)
+
+EXTRA_OBJECTS_TO_INSTALL = mathql.ml mathql.cmi
+EXTRA_OBJECTS_TO_CLEAN =
+
+
+include ../Makefile.common
--- /dev/null
+
+(*
+ * gestione della connessione al database
+ *)
+
+(*
+ * le eccezzioni lanciate dalle funzioni init e pgc sono
+ * definite nel modulo Mathql
+ *)
+open Mathql;;
+
+(*
+ * paramentri della connessione
+ *)
+(*let connection_param = "host=127.0.0.1 dbname=helm";;*)
+let connection_param = "host=dotto.cs.unibo.it dbname=helm user=helm";;
+
+(*
+ * connessione al db
+ *)
+let conn = ref None;;
+
+(*
+ * controllo sulla connessione
+ *)
+let pgc () =
+ match !conn with
+ None -> raise (MQInvalidConnection connection_param)
+ | Some c -> c
+;;
+
+(*
+ * inizializzazione della connessione
+ *
+ * TODO
+ * passare i parametri della connessione come argomento di init
+ *)
+let init () =
+ try (
+ conn := Some (new Postgres.connection connection_param);
+ ) with
+ _ -> raise (MQConnectionFailed ("init: " ^ connection_param))
+;;
+
+(*
+ * chiusura della connessione
+ *)
+let close () =
+ match !conn with
+ None -> ()
+ | Some c -> c#close
+;;
--- /dev/null
+val pgc : unit -> Postgres.connection
+val init : unit -> unit
+val close : unit -> unit
--- /dev/null
+
+(*
+ *
+ *)
+
+open Mathql;;
+
+(*
+ * conversione di un pattern
+ *)
+let rec patterneval p =
+ match p with
+ [] -> ""
+ | head::tail ->
+ let h = match head with
+ MQString (s) -> s
+ | MQSlash -> "/"
+ | MQAnyChr -> "[^/]?"
+ | MQAst -> "[^/]*"
+ | MQAstAst -> ".*"
+ in
+ h ^ (patterneval tail)
+;;
+
+(*
+ * conversione di un fragment identifier
+ *)
+let fieval fi =
+ match fst fi with
+ None -> ""
+ | Some i ->
+ let s = "#xpointer\(1/" ^ string_of_int (i) in
+ match snd fi with
+ None ->
+ s ^ "\)"
+ | Some j ->
+ s ^ "/" ^ string_of_int j ^ "\)"
+;;
+
+(*
+ * trasforma un pattern MathQL in un pattern postgresql
+ *
+ * si utilizzano espressioni regolari POSIX anziche' l'operatore
+ * SQL standard LIKE perche' MathQL prevede esperssioni con "*"
+ * e con "**".
+ *)
+let pattern_match preamble pattern ext fragid =
+ " ~ '" ^ preamble ^ ":/" ^ (patterneval pattern) ^ "." ^ ext ^ (fieval fragid) ^ "'"
+;;
--- /dev/null
+val pattern_match :
+ string ->
+ Mathql.mquptoken list -> string -> int option * int option -> string
--- /dev/null
+
+(*
+ *
+ *)
+
+(*
+ * implementazione della funzione NAME
+ *)
+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 -> ""
+;;
+
+(** TEST **)
+
+(*
+print_endline (func_name Sys.argv.(1));;
+*)
--- /dev/null
+val func_name : string -> string
--- /dev/null
+
+(*
+ * implementazione del comando INTERSECT
+ *)
+
+(*
+ * eccezione sollevata quando il join dei contesti
+ * deve essere vuoto
+ *)
+exception Join_must_be_empty;;
+
+(*
+ * join fra due contesti
+ *)
+let xres_join_context h1 l1 h2 l2 =
+ match (l1, l2) with
+ ([], _) -> l2
+ | (_, []) -> l1
+ | (_, _) ->
+ let hh = h2 @ (List.find_all (function t -> not (List.mem t h2)) h1)
+ and m1 = List.combine h1 l1
+ and m2 = List.combine h2 l2
+ in
+ try
+ (List.map
+ (fun elem ->
+ let value1 = try (List.assoc elem m1) with Not_found -> List.assoc elem m2
+ and value2 = try (List.assoc elem m2) with Not_found -> List.assoc elem m1
+ in
+ if value1 = value2 then value1 else raise Join_must_be_empty
+ )
+ hh
+ ) with
+ Join_must_be_empty -> []
+;;
+
+(*
+ * implementazione del comando INTERSECT
+ *)
+let intersect_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] *)
+ | (_, _) ->
+ (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 *)
+ @
+ 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
+ )
+ )
+ []
+ tail1 (* per ogni elemento di tail1 applica la List.fold_left *)
+ ) (* match *)
+;;
+
+(*
+let h1 = ["retVal"; "a"; "b"];;
+let l1 = ["pippo"; "3"; "3"];;
+let l3 = ["pluto"; "7";"8"]
+let r1 = [h1; l1; l3];;
+
+let h2 = ["retVal"; "b"; "c"];;
+let l2 = ["pippo"; "3"; "1"];;
+let r2 = [h2; l2];;
+
+List.map (fun l -> List.iter print_endline l) (xres_intersect (r1, r2));;
+*)
--- /dev/null
+val intersect_ex : string list list -> string list list -> string list 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/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Ferruccio Guidi <fguidi@cs.unibo.it> *)
+(* Domenico Lordi <lordi@cs.unibo.it> *)
+(* 30/04/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 mquptoken =
+ | MQString of string (* a constant string *)
+ | MQSlash (* a slash: '/' *)
+ | MQAnyChr (* Any single character: '?' *)
+ | MQAst (* single asterisk: '*' *)
+ | MQAstAst (* double asterisk: '**' *)
+
+type mqup = mquptoken list (* uri pattern (helper) *)
+
+type mqfi = int option * int option
+
+type mqtref = string * mqup * string * mqfi (* HELM preamble,
+ uri pattern,
+ extension,
+ fragment identifier *)
+
+type mqpattern = mqtref (* constant pattern *)
+
+type mqfunc =
+ | MQName (* NAME *)
+
+type mqstring =
+ | MQCons of string (* constant *)
+ | MQFunc of mqfunc * mqrvar (* function, rvar *)
+ | MQRVar of mqrvar (* rvar *)
+ | MQSVar of mqsvar (* svar *)
+ | MQMConclusion (* main conclusion *)
+ | MQConclusion (* inner conclusion *)
+
+type mqbool =
+ | MQTrue
+ | MQFalse
+ | MQAnd of mqbool * mqbool
+ | MQOr of mqbool * mqbool
+ | MQNot of mqbool
+ | MQIs of mqstring * mqstring (* operands *)
+
+type mqlist =
+ | MQSelect of mqrvar * mqlist * mqbool (* rvar, list, boolean *)
+ | MQUse of mqlist * mqsvar (* list, Position attribute *)
+ | MQUsedBy of mqlist * mqsvar (* list, Position attribute *)
+ | MQPattern of mqpattern (* pattern *)
+ | MQUnion of mqlist * mqlist (* *)
+ | MQIntersect of mqlist * mqlist (* *)
+
+type mquery =
+ | MQList of mqlist
+
+(* Output types *************************************************************)
+(* main type is mqresult *)
+
+(* TODO: usare le uri in questo formato *)
+type mquref = UriManager.uri * mqfi (* uri, fragment identifier *)
+
+type mqrefs = mqtref list (* list of references (helper) *)
+
+type mqresult =
+ | MQStrUri of string list
+ | MQRefs of mqrefs
--- /dev/null
+
+(*
+ * implementazione del'interprete MathQL
+ *)
+open Mathql;;
+open Eval;;
+open Utility;;
+open Dbconn;;
+open Pattern;;
+open Union;;
+open Intersect;;
+open Use;;
+open Select;;
+
+(*
+ * inizializzazione della connessione al database
+ *)
+let init () = Dbconn.init ();;
+
+(*
+ * esecuzione di una query
+ *
+ * parametri:
+ * q
+ *
+ * output: string list list; risultato internto formato da uri + contesto.
+ *)
+let rec execute_ex q =
+ match q with
+ MQSelect (apvar, alist, abool) ->
+ select_ex apvar (execute_ex alist) abool
+ | MQUsedBy (alist, asvar) ->
+ use_ex (execute_ex alist) asvar "refObj"
+ | MQUse (alist, asvar) ->
+ use_ex (execute_ex alist) asvar "backPointer"
+ | MQPattern (apreamble, apattern, ext, afragid) ->
+ pattern_ex apreamble apattern ext afragid
+ | MQUnion (l1, l2) ->
+ union_ex (execute_ex l1) (execute_ex l2)
+ | MQIntersect (l1, l2) ->
+ intersect_ex (execute_ex l1) (execute_ex l2)
+;;
+
+(*
+ * 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 =
+ MQStrUri
+ (
+ List.map
+ List.hd
+ (List.tl l)
+ )
+;;
+
+(*
+ *
+ *)
+let execute q =
+ match q with
+ MQList qq -> xres_to_res (execute_ex qq)
+;;
+
+(*
+ * chiusura della connessione al database
+ *)
+let close () = Dbconn.close ();;
+
--- /dev/null
+
+(*
+ * interfaccia dell'interprete MathQL
+ *)
+
+open Mathql;;
+
+(*
+ * inizializzazione del database
+ *)
+val init: unit -> unit
+
+(*
+ * esecuzione di query
+ *)
+val execute: mquery -> mqresult;;
+
+(*
+ * chiusura del database
+ *)
+val close: unit -> unit
--- /dev/null
+
+open Dbconn;;
+open Utility;;
+open Eval;;
+
+let pattern_ex apreamble apattern ext afragid =
+ let c = pgc () in
+ let r1 = c#exec "select att0 from class where att2='Object'" in
+ let res =
+ c#exec ("select att0 from t" ^ (pgresult_to_string r1) ^
+ " where att0 " ^ (pattern_match apreamble apattern ext afragid))
+ in
+ [["retVal"]] @ List.map (fun l -> [l]) (pgresult_to_string_list res)
+;;
--- /dev/null
+val pattern_ex :
+ string ->
+ Mathql.mquptoken list ->
+ string -> int option * int option -> string list list
--- /dev/null
+
+(*
+ * implementazione del comando SELECT
+ *)
+
+open Mathql;;
+open Func;;
+open Utility;;
+
+(*
+ * valutazione di una stringa
+ *)
+let stringeval s l =
+ match s with
+ MQCons s ->
+ s
+ | MQFunc (f, rvar) ->
+ (
+ match f with
+ MQName -> func_name (List.assoc rvar l)
+ )
+ | MQRVar rvar ->
+ List.assoc rvar l
+ | MQSVar svar ->
+ List.assoc svar l
+ | MQMConclusion ->
+ "MainConclusion"
+ | MQConclusion ->
+ "InConclusion"
+;;
+
+(*
+ *
+ *)
+let rec is_good l abool =
+ match abool with
+ MQAnd (b1, b2) ->
+ (is_good l b1) && (is_good l b2)
+ | MQOr (b1, b2) ->
+ (is_good l b1) || (is_good l b2)
+ | MQNot b1 ->
+ not (is_good l b1)
+ | MQTrue ->
+ true
+ | MQFalse ->
+ false
+ | MQIs (s1, s2) ->
+ (stringeval s1 l) = (stringeval s2 l)
+;;
+
+(*
+ *
+ *)
+let rec replace avar newval l =
+ match l with
+ MQAnd (b1, b2) -> MQAnd (replace avar newval b1, replace avar newval b2)
+ | MQOr (b1, b2) -> MQOr (replace avar newval b1, replace avar newval b2)
+ | MQNot b1 -> MQNot (replace avar newval b1)
+ | MQIs (s1, s2) ->
+ let ns1 = (
+ match s1 with
+ MQRVar v when v = avar -> MQRVar newval
+ | MQFunc (f, v) when v = avar -> MQFunc (f, newval)
+ | _ -> s1
+ )
+ and ns2 = (
+ match s2 with
+ MQRVar v when v = avar -> MQRVar newval
+ | MQFunc (f, v) when v = avar -> MQFunc (f, newval)
+ | _ -> s2
+ )
+ in
+ MQIs (ns1, ns2)
+ | _ -> l (* i casi non compresi sono MQTrue e MQFalse *)
+;;
+
+let rec print_booltree b =
+ match b with
+ MQAnd (b1, b2) ->
+ let i = print_booltree b1 in
+ let j = print_string " AND " in
+ print_booltree b2
+ | MQOr (b1, b2) ->
+ let i = print_booltree b1 in
+ let j = print_string " OR " in
+ print_booltree b2
+ | MQNot b1 ->
+ let j = print_string " NOT " in
+ print_booltree b1
+ | MQTrue ->
+ print_string " TRUE "
+ | MQFalse ->
+ print_string " FALSE "
+ | MQIs (s1, s2) ->
+ let s1v = match s1 with
+ MQCons s ->
+ "'" ^ s ^ "'"
+ | MQFunc (f, rvar) ->
+ (
+ match f with
+ MQName -> "NAME " ^ rvar
+ )
+ | MQRVar rvar ->
+ rvar
+ | MQSVar svar ->
+ svar
+ | MQMConclusion ->
+ "MainConclusion"
+ | MQConclusion ->
+ "InConclusion"
+ and s2v = match s2 with
+ MQCons s ->
+ s
+ | MQFunc (f, rvar) ->
+ (
+ match f with
+ MQName -> "NAME " ^ rvar
+ )
+ | MQRVar rvar ->
+ rvar
+ | MQSVar svar ->
+ svar
+ | MQMConclusion ->
+ "MainConclusion"
+ | MQConclusion ->
+ "InConclusion"
+ in
+ print_string (s1v ^ " = " ^ s2v)
+;;
+
+(*
+ * implementazione del comando SELECT
+ *)
+let select_ex avar alist abool =
+ let wrt = replace avar "retVal" abool in
+ (*let j = print_booltree wrt in*)
+ [List.hd alist]
+ @
+ List.find_all
+ (fun l -> is_good (List.combine (List.hd alist) l) wrt)
+ (List.tl alist)
+;;
+
--- /dev/null
+val select_ex :
+ Mathql.mqrvar ->
+ Mathql.mqsvar list list -> Mathql.mqbool -> Mathql.mqsvar list list
--- /dev/null
+
+(*
+ * 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 ...*)
+ (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
+ tail2
+(* first @
+ List.map (fun l -> [List.hd l] @
+ xres_fill_context
+ (List.tl headr) (List.tl head2) (List.tl l)
+ ) tail2
+*)
+ ) (* match *)
+;;
+
+(** TEST **)
+
+(*
+let h1 = ["retVal"; "a"; "b"];;
+let l1 = ["pippo"; "3"; "3"];;
+let l3 = ["pluto"; "7"; "8"]
+let r1 = [h1; l1; l3];;
+
+(*let h2 = ["retVal"; "b"; "c"];;
+let l2 = ["pippo"; "3"; "1"];;*)
+let h2 = ["retVal"; "a"; "b"];;
+let l2 = ["pippo"; "3"; "3"];;
+let r2 = [h2; l2];;
+
+List.map (fun l -> List.iter print_endline l) (xres_union (r1, r2));;
+*)
--- /dev/null
+val union_ex : string list list -> string list list -> string list list
--- /dev/null
+
+(*
+ * implementazione dei comandi USE/USED BY
+ *)
+
+open Utility;;
+open Dbconn;;
+
+(*
+ * implementazione dei comandi USE/USED BY
+ *
+ * parametri:
+ * alist: string list list; lista su cui eseguire il comando USE/USED BY
+ * asvar: string; nome della variabile del comando use
+ * usek: string; nome della tabella in cui ricercare le occorrenze;
+ * la distinzione fra l'esecuzione del comando USE e USED BY
+ * sta nell'utilizzo della tabella 'backPointer' per USE
+ * e 'refObj' per USED BY
+ *
+ * output: string list list; lista su cui e' stato eseguito il
+ * comando USE/USED BY
+ *
+ * TODO
+ * USE e USED BY sono identici dal punto di vista algoritmico, per questo
+ * sono stati accorpati in una sola funzione; stilisticamente, sarebbe meglio
+ * avere due implementazioni distinte...
+ *)
+let use_ex alist asvar usek =
+ let c = pgc () in
+ List.fold_left
+ (fun parziale xres ->
+ let r1 = pgresult_to_string (c#exec
+ ("select att0 from property where att2='" ^ usek ^ "'"))
+ and r2 = pgresult_to_string (c#exec
+ "select att0 from property where att2='position'")
+ and r3 = pgresult_to_string (c#exec
+ "select att0 from property where att2='occurrence'")
+ in
+ let res = c#exec (
+ "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")
+ in
+ parziale
+ @
+ if not (List.mem asvar (List.tl (List.hd alist))) then
+ List.map
+ (fun l -> [List.hd l] @ List.tl xres @ List.tl l)
+ res#get_list
+ else
+ List.map
+ (fun l ->
+ let t =
+ match xres with
+ hd::tl -> (List.hd l)::tl
+ | [] -> []
+ in
+ List.map
+ snd
+ (Utility.set_assoc
+ asvar
+ (List.hd (List.tl l))
+ (List.combine (List.hd alist) t)
+ )
+ )
+ (List.find_all
+ (fun l ->
+ let currv =
+ List.hd (List.tl l)
+ and xresv =
+ try (
+ List.assoc
+ asvar
+ (List.combine
+ (List.tl (List.hd alist))
+ (List.tl xres)
+ )
+ ) with
+ Not_found -> ""
+ in
+ xresv = "" or xresv = currv
+ )
+ res#get_list
+ )
+ )
+ [ (List.hd alist)
+ @
+ if not (List.mem asvar (List.tl (List.hd alist))) then
+ [asvar]
+ else
+ []
+ ]
+ (List.tl alist)
+;;
+
+(** TEST **)
+
+(*
+let use_ex alist asvar =
+ if (List.find_all asvar (List.tl (List.hd alist))) = [] then
+ use_ex_nc alist asvar
+ else
+ use_ex_co alist asvar
+;;
+
+List.map
+ (fun l ->
+ let t =
+ match xres with
+ hd::tl -> (List.hd l)::tl
+ | [] -> []
+ in
+ let hash = List.combine (List.hd alist) t in
+ snd (set_assoc asvar (snd l) hash)
+ )
+ (List.find_all
+ (fun l ->
+ let currv =
+ List.hd (List.tl l)
+ and xresv =
+ try (
+ List.assoc asvar (List.combine (List.tl (List.hd alist)) (List.tl xres))
+ ) with
+ Not_found -> ""
+ in
+ xresv = "" or xresv = currv
+ )
+ res#get_list
+ )
+;;
+*)
--- /dev/null
+val use_ex : string list list -> string -> string -> string list list
--- /dev/null
+
+(*
+ * funzioni di utilita' generale
+ *)
+
+(*
+ * converte il risultato di una query in una lista di stringhe
+ *
+ * parametri:
+ * l: Postgres.result; risultato della query
+ *
+ * output: string list; lista di stringhe (una per tupla)
+ *
+ * assumo che il risultato della query sia
+ * costituito da un solo valore per tupla
+ *
+ * TODO
+ * verificare che l sia effettivamente costruita come richiesto
+ *)
+let pgresult_to_string_list l = List.map (List.hd) l#get_list;;
+
+(*
+ * converte il risultato di una query in una stringa
+ *
+ * paramteri:
+ * l: Postgres.result; risultato della query
+ *
+ * output: string; valore dell'unica tupla del risultato
+ *
+ * mi aspetto che il risultato contenga una sola tupla
+ * formata da un solo valore
+ *
+ * TODO
+ * verificare che l sia costruita come richiesto
+ *)
+let pgresult_to_string l = List.hd (List.hd l#get_list);;
+
+(*
+ * parametri:
+ * x: 'a; chiave di cui settare il valore
+ * v: 'b; valore da assegnare alla chiave
+ * l: ('a * 'b) list; lista di coppie in cui effettuare
+ * l'assegnamento
+ *
+ * output: ('a * 'b) list; lista di coppie contenente (x, v)
+ *
+ * TODO
+ * gestire i casi in cui in l compaiono piu' coppie (x, _)
+ * si sostituiscono tutte? se ne sostituisce una e si eliminano
+ * le altre?
+ *)
+let set_assoc x v l =
+ let rec spila testa key value lista =
+ match lista with
+ [] -> testa @ [(key, value)]
+ | (j, _)::tl when j = key -> testa @ [(key, value)] @ tl
+ | hd::tl -> spila (testa @ [hd]) key value tl
+ in
+ spila [] x v l
+;;
+
+(** TEST **)
+
+(*
+let h = ["d";"b"];;
+let v = ["1";"2"];;
+let c = List.combine h v;;
+
+List.iter (fun (a,b) -> print_endline (a ^ ": " ^ b)) (set_assoc "a" "3" c);;
+*)
--- /dev/null
+val pgresult_to_string_list : < get_list : 'a list list; .. > -> 'a list
+val pgresult_to_string : < get_list : 'a list list; .. > -> 'a
+val set_assoc : 'a -> 'b -> ('a * 'b) list -> ('a * 'b) list
projects / helm.git / commitdiff