X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fmathql%2FlistAvs.ml;fp=helm%2Focaml%2Fmathql%2FlistAvs.ml;h=e25fc61c730975236bd11137672a97def63308d5;hb=381006cf8b418cfdeaf145ab7df9e8f2b19ae2e6;hp=0000000000000000000000000000000000000000;hpb=efdc3184ccd0738fe48aa0056fc444fba23329e8;p=helm.git diff --git a/helm/ocaml/mathql/listAvs.ml b/helm/ocaml/mathql/listAvs.ml new file mode 100644 index 000000000..e25fc61c7 --- /dev/null +++ b/helm/ocaml/mathql/listAvs.ml @@ -0,0 +1,189 @@ +(* 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/. + *) + +(* AUTOR: Ferruccio Guidi + *) + +type path = Avs.path (* the name of an attribute *) + +type value = Avs.value (* the value of an attribute *) + +type attribute = path * value (* an attribute *) + +type group = attribute list (* a group of attributes *) + +type attribute_set = group list (* the attributes of an URI *) + +type av = string * attribute_set (* an attributed URI *) + +type avs = av list (* the query result *) + +type peek_t = Empty + | Single of (string * group list) + | Many of (string * group list) + + +(* constructors *************************************************************) + +let grp_empty = [] + +let grp_make p v = [(p, [v])] + +let empty = grp_empty + +let make s = function + | [] -> [(s, [])] + | g -> [(s, [g])] + +(* projections **************************************************************) + +let subj v = List.rev (List.rev_map (fun x -> (x, [])) v) + +let grp_read g p = subj (List.assoc p g) + +let single = function + | [s, _] -> Some s + | _ -> None + +(* iterators ****************************************************************) + +let rec iter f a = function + | [] -> a + | [s, _] -> f a s false + | (s, _) :: v -> iter f (f a s true) v + +let rec x_iter f a = function + | [] -> a + | [s, gl] -> f a s gl false + | (s, gl) :: v -> x_iter f (f a s gl true) v + +let rec x_grp_iter f a g = x_iter f a g + +(* tests ********************************************************************) + +let rec sub v1 v2 = + match (v1, v2) with + | [], _ -> true + | _, [] -> false + | (h1, _) :: _, (h2, _) :: _ when h1 < h2 -> false + | (h1, _) :: _, (h2, _) :: t2 when h1 > h2 -> sub v1 t2 + | _ :: t1, _ :: t2 -> sub t1 t2 + +let rec meet v1 v2 = + match v1, v2 with + | [], _ + | _, [] -> false + | (h1, _) :: t1, (h2, _) :: _ when h1 < h2 -> meet t1 v2 + | (h1, _) :: _, (h2, _) :: t2 when h1 > h2 -> meet v1 t2 + | _, _ -> true + +let rec eq v1 v2 = + match v1, v2 with + | [], [] -> true + | (h1, _) :: t1, (h2, _) :: t2 when h1 = h2 -> eq t1 t2 + | _, _ -> false + +(* union ********************************************************************) + +let rec set_union v1 v2 = + match v1, v2 with + | [], v -> v + | v, [] -> v + | h1 :: t1, h2 :: t2 when h1 < h2 -> h1 :: set_union t1 v2 + | h1 :: t1, h2 :: t2 when h1 > h2 -> h2 :: set_union v1 t2 + | h1 :: t1, _ :: t2 -> h1 :: set_union t1 t2 + +let set_iter f al = List.fold_left (fun s a -> set_union (f a) s) [] al + +let grps_make l g = set_union l [g] + +let rec union s1 s2 = + match s1, s2 with + | [], s -> s + | s, [] -> s + | (r1, g1) :: t1, (r2, _) :: _ when r1 < r2 -> + (r1, g1) :: union t1 s2 + | (r1, _) :: _, (r2, g2) :: t2 when r1 > r2 -> + (r2, g2) :: union s1 t2 + | (r1, g1) :: t1, (_, g2) :: t2 -> + (r1, set_union g1 g2) :: union t1 t2 + +let grp_union = union + +let prod g1 g2 = + let aux a = set_iter (fun h -> [union a h]) g2 in + set_iter aux g1 + +let rec d_union s1 s2 = + match s1, s2 with + | [], s -> s + | s, [] -> s + | (r1, g1) :: t1, (r2, _) :: _ when r1 < r2 -> + (r1, g1) :: d_union t1 s2 + | (r1, _) :: _, (r2, g2) :: t2 when r1 > r2 -> + (r2, g2) :: d_union s1 t2 + | (r1, g1) :: t1, (_, g2) :: t2 -> + (r1, prod g1 g2) :: d_union t1 t2 + +(* intersect ****************************************************************) + +let rec set_intersect v1 v2 = + match v1, v2 with + | [], v -> [] + | v, [] -> [] + | h1 :: t1, h2 :: _ when h1 < h2 -> set_intersect t1 v2 + | h1 :: _, h2 :: t2 when h1 > h2 -> set_intersect v1 t2 + | h1 :: t1, _ :: t2 -> h1 :: set_intersect t1 t2 + +let rec intersect s1 s2 = + match s1, s2 with + | [], s -> [] + | s, [] -> [] + | (r1, _) :: t1, (r2, _) :: _ when r1 < r2 -> intersect t1 s2 + | (r1, _) :: _, (r2, _) :: t2 when r1 > r2 -> intersect s1 t2 + | (r1, g1) :: t1, (_, g2) :: t2 -> + (r1, set_intersect g1 g2) :: intersect t1 t2 + +(* diff *********************************************************************) + +let rec diff s1 s2 = + match s1, s2 with + | [], _ -> [] + | s, [] -> s + | (r1, g1) :: t1 , (r2, _) ::_ when r1 < r2 -> + (r1, g1) :: (diff t1 s2) + | (r1, _) :: _, (r2, _) :: t2 when r1 > r2 -> diff s1 t2 + | _ :: t1, _ :: t2 -> diff t1 t2 + +(* concatenation ************************************************************) + +let append v1 v2 = v1 @ v2 + +(* peeking ******************************************************************) + +let peek = function + | [] -> Empty + | [s, gl] -> Single (s, gl) + | (s, gl) :: _ -> Many (s, gl)