1. Sébastien Ferré
  2. ocaml-lib

Commits

Sébastien Ferré  committed d4ce9a3

???

  • Participants
  • Parent commits 3df75ad
  • Branches master

Comments (0)

Files changed (1)

File term.ml

View file
  • Ignore whitespace
-(** Utility code for the representation and managing of taxonomic relations over terms. *)
 
-open Token
+(* useful code for representing idents and terms as integers *)
+(* --------------------------------------------------------- *)
 
-(* type of data associated to a term *)
-type t = {
-    mutable sufs : Syntax.t_list LSet.t;  (* list of sufficient conditions *)
-    mutable necs : Syntax.t_list LSet.t  (* list of necessary conditions *)
-  }
+let cpt : int ref = ref 0
 
-(* dictionary of terms *)
-let tbl : (string,t) Hashtbl.t = Hashtbl.create 1000
+type id = int (* >0 for terms, <0 for idents *)
 
-(* load and save *)
+let h_term2id : (string,id) Hashtbl.t = Hashtbl.create 100
+let h_ident2id : (string,id) Hashtbl.t = Hashtbl.create 100
+    
+let h_id2s : (id,string) Hashtbl.t = Hashtbl.create 100
 
-type data = (string * t) list
+let term_exists s = Hashtbl.mem h_term2id s
 
-let init () =
-  Hashtbl.clear tbl
+let ident_exists s = Hashtbl.mem h_ident2id s
 
-let load (t : data) =
-  Hashtbl.clear tbl;
-  List.iter (fun (name,x) -> Hashtbl.add tbl name x) t
+let term2id s =
+  try Hashtbl.find h_term2id s
+  with Not_found ->
+    incr cpt;
+    let id = !cpt in
+    Hashtbl.add h_term2id s id;
+    Hashtbl.add h_id2s id s;
+    id
 
-let save () =
-  let t = Hashtbl.fold (fun name x l -> (name,x)::l) tbl [] in
-  (t : data)
+let ident2id s =
+  try Hashtbl.find h_ident2id s
+  with Not_found ->
+    incr cpt;
+    let id = - !cpt in
+    Hashtbl.add h_ident2id s id;
+    Hashtbl.add h_id2s id s;
+    id
+
+let id2s id = (* may raise Not_found *)
+  Hashtbl.find h_id2s id
+
+
+(** Utility code for the representation and managing of taxonomic relations over terms. *)
+
+(* type of data associated to a term *)
+type t = {
+    mutable sufs : int LSet.t;  (* list of sufficient conditions *)
+    mutable necs : int LSet.t  (* list of necessary conditions *)
+  }
+
+(* dictionary of terms *)
+let tbl : (int,t) Hashtbl.t = Hashtbl.create 1000
 
 (* Invariants
    - a term absent from tbl has all fields equal to []
 *)
 
 (* get data about a term *)
-let get : string -> t =
-  fun name ->
-    try Hashtbl.find tbl name
+let get : int -> t =
+  fun id ->
+    try Hashtbl.find tbl id
     with Not_found ->
       let data = {sufs = LSet.empty (); necs = LSet.empty ()} in
-      Hashtbl.add tbl name data; data
-
-let get_sufs : string -> Syntax.t_list list =
-  fun name -> (get name).sufs
+      Hashtbl.add tbl id data;
+      data
 
-let get_necs : string -> Syntax.t_list list =
-  fun name -> (get name).necs
+let get_sufs : int -> int list =
+  fun id ->
+    try (Hashtbl.find tbl id).sufs
+    with Not_found ->  LSet.empty ()
 
-(* add a sufficient condition *)
-let add_suf : string -> Syntax.t_list -> unit =
-  fun name suf ->
-    let data = get name in
-    data.sufs <- LSet.add suf data.sufs;
-    match suf with
-    | [Token.Term name2] ->
-	let data2 = get name2 in
-	data2.necs <- LSet.add [Token.Term name] data2.necs
-    | _ -> ()
+let get_necs : int -> int list =
+  fun id ->
+    try (Hashtbl.find tbl id).necs
+    with Not_found -> LSet.empty ()
 
 (* add a necessary condition *)
-let add_nec : string -> Syntax.t_list -> unit =
-  fun name nec ->
-    let data = get name in
+let add : int -> int -> unit =
+  fun id nec ->
+    let data = get id in
     data.necs <- LSet.add nec data.necs;
-    match nec with
-    | [Token.Term name2] ->
-	let data2 = get name2 in
-	data2.sufs <- LSet.add [Token.Term name] data2.sufs
-    | _ -> ()
-
-(*
-(* add a relation between 2 terms *)
-let add_suf_nec : string -> string -> unit =
-  fun suf nec ->
-    add_suf nec [Token.Term suf];
-    add_nec suf [Token.Term nec]
-*)
-
-(* delete a sufficient condition *)
-let del_suf : string -> Syntax.t_list -> unit =
-  fun name suf ->
-    let data = get name in
-    data.sufs <- LSet.remove suf data.sufs;
-    match suf with
-    | [Token.Term name2] ->
-	let data2 = get name2 in
-	data2.necs <- LSet.remove [Token.Term name] data2.necs
-    | _ -> ()
+    let data2 = get nec in
+    data2.sufs <- LSet.add id data2.sufs
 
 (* delete a necessary condition *)
-let del_nec : string -> Syntax.t_list -> unit =
-  fun name nec ->
-    let data = get name in
-    data.necs <- LSet.remove nec data.necs;
-    match nec with
-    | [Token.Term name2] ->
-	let data2 = get name2 in
-	data2.sufs <- LSet.remove [Token.Term name] data2.sufs
-    | _ -> ()
-
-(*
-(* delete a relation between 2 terms *)
-let del_suf_nec : string -> string -> unit =
-  fun suf nec ->
-    del_suf nec [Term suf];
-    del_nec suf [Term nec]
-*)
+let remove : int -> int -> unit =
+  fun id nec ->
+    (try
+      let data = Hashtbl.find tbl id in
+      data.necs <- LSet.remove nec data.necs
+    with Not_found -> ());
+    (try
+      let data2 = Hashtbl.find tbl nec in
+      data2.sufs <- LSet.remove id data2.sufs
+    with Not_found -> ())
+
+(* rename a term/ident *)
+let rename : int -> string -> unit =
+  fun id s ->
+    if id > 0
+    then begin
+      assert (not (Hashtbl.mem h_term2id s));
+      let old_term = Hashtbl.find h_id2s id in
+      Hashtbl.remove h_term2id old_term;
+      Hashtbl.add h_term2id s id;
+      Hashtbl.replace h_id2s id s end
+    else begin
+      assert (not (Hashtbl.mem h_ident2id s));
+      let old_ident = Hashtbl.find h_id2s id in
+      Hashtbl.remove h_ident2id old_ident;
+      Hashtbl.add h_ident2id s id;
+      Hashtbl.replace h_id2s id s
+    end
+
+(* load and save *)
+
+type data = {
+    cpt : int;
+    id2s : (id * string) list;
+    tbl : (int * t) list;
+  }
+
+let init () =
+  cpt := 0;
+  Hashtbl.clear h_id2s;
+  Hashtbl.clear h_term2id;
+  Hashtbl.clear h_ident2id;
+  Hashtbl.clear tbl
+
+let load (t : data) =
+  init ();
+  cpt := t.cpt;
+  List.iter
+    (fun (id,s) ->
+      Hashtbl.add h_id2s id s;
+      if id > 0
+      then Hashtbl.add h_term2id s id
+      else Hashtbl.add h_ident2id s id)
+    t.id2s;
+  List.iter
+    (fun (id,x) ->
+      Hashtbl.add tbl id x)
+    t.tbl
+
+let save () =
+  let t = {
+    cpt = !cpt;
+    id2s = Hashtbl.fold (fun id s l -> (id,s)::l) h_id2s [];
+    tbl = Hashtbl.fold (fun id x l -> (id,x)::l) tbl [];
+  } in
+  (t : data)