Commits

Sébastien Ferré committed 06460f4

Git

  • Participants
  • Parent commits ac1a82a

Comments (0)

Files changed (7)

 (**
-   Compact integer sets.
-   Attention: integers must be strictly positive !
- *)
+   Cis : compact integer sets
+
+   This module implements compact integer sets, represented as a (custom) list
+   of integer intervals. Usual set operations are provided.
+   The advantage compared to ordered lists is that the actual size may be smaller
+   than the cardinal of a set when many elements are contiguous. Most set operations
+   are linear w.r.t. the size, not the cardinal.
+
+   Author: Sébastien Ferré <ferre@irisa.fr>
+   License: LGPL
+*)
 
 (* for test
 #load "nums.cma"
 #load "lSet.cmo"
 *)
 
-type elt = int (* in fact only positive integers *)
+(* copied from module Common *)
+
+let fold_for : (int -> 'a -> 'a) -> int -> int -> 'a -> 'a =
+  fun f a b e ->
+    let res = ref e in
+    for x = a to b do
+      res := f x !res
+    done;
+    !res
+
+let fold_for_down : (int -> 'a -> 'a) -> int -> int -> 'a -> 'a =
+  fun f a b e ->
+    let res = ref e in
+    for x = a downto b do
+      res := f x !res
+    done;
+    !res
+
+(* end of copy *)
+
+type elt = int
+
+type t = Nil | Single of int * t | Interv of int * int * t
+      (** integers in decreasing order *)
+
+let memory_size l =
+  let rec aux acc = function
+    | Nil -> acc
+    | Single (_,l) -> aux (acc + 3) l
+    | Interv (_,_,l) -> aux (acc + 4) l
+  in
+  aux 1 l (* 1 for the root reference *)
+
+let compare x y = Pervasives.compare y x
+
+let max_elt : t -> int =
+  function
+    | Nil -> raise (Invalid_argument "Cis.max_elt: set is empty")
+    | Single (x,_) -> x
+    | Interv (xmax,_,_) -> xmax
 
-type t = int list
-      (** integers in decreasing order, and negative value to mark beginning of interval. *)
+let rec min_elt : t -> int =
+  function
+    | Nil -> raise (Invalid_argument "Cis.max: set is empty")
+    | Single (x,Nil) -> x
+    | Interv (_,xmin,Nil) -> xmin
+    | Single (_,l) -> min_elt l
+    | Interv (_,_,l) -> min_elt l
 
 let step : t -> nil:(unit -> 'a) -> single:(int -> t -> 'a) -> interv:(int * int -> t -> 'a) -> 'a =
   fun l ~nil ~single ~interv ->
     match l with
-    | [] -> nil ()
-    | x::y::l' when x < 0 -> interv (-x,y) l'
-    | x::l' -> single x l';;
+    | Nil -> nil ()
+    | Single (x,l') -> single x l'
+    | Interv (x,y,l') -> interv (x,y) l';;
 
 let cons_single : int -> t -> t =
   fun x l ->
     step l
-      ~nil:(fun () -> [x])
-      ~single:(fun x' l' -> assert (x > x'); if x=x'+1 then (-x)::x'::l' else x::l)
-      ~interv:(fun (xmax',xmin') l' -> assert (x > xmax'); if x=xmax'+1 then (-x)::xmin'::l' else x::l);;
+      ~nil:(fun () -> Single (x,Nil))
+      ~single:(fun x' l' -> (* assert (x > x');*) if x=x'+1 then Interv (x,x',l') else Single (x,l))
+      ~interv:(fun (xmax',xmin') l' -> (* assert (x > xmax');*) if x=xmax'+1 then Interv (x,xmin',l') else Single (x,l));;
 
 let cons_interv : int * int -> t -> t =
   fun (xmax,xmin) l ->
     if xmax > xmin then
       step l
-	~nil:(fun () -> [-xmax; xmin])
-	~single:(fun x' l' -> assert (xmin > x'); if xmin=x'+1 then (-xmax)::x'::l' else (-xmax)::xmin::l)
-	~interv:(fun (xmax',xmin') l' -> assert (xmin > xmax'); if xmin=xmax'+1 then (-xmax)::xmin'::l' else (-xmax)::xmin::l)
+	~nil:(fun () -> Interv (xmax, xmin, Nil))
+	~single:(fun x' l' -> (* assert (xmin > x');*) if xmin=x'+1 then Interv (xmax,x',l') else Interv (xmax,xmin,l))
+	~interv:(fun (xmax',xmin') l' -> (* assert (xmin > xmax');*) if xmin=xmax'+1 then Interv (xmax, xmin', l') else Interv (xmax,xmin,l))
     else if xmin=xmax then (* inlining of 'cons_single xmin l' *)
       step l
-	~nil:(fun () -> [xmin])
-	~single:(fun x' l' -> assert (xmin > x'); if xmin=x'+1 then (-xmin)::x'::l' else xmin::l)
-	~interv:(fun (xmax',xmin') l' -> assert (xmin > xmax'); if xmin=xmax'+1 then (-xmin)::xmin'::l' else xmin::l)
+	~nil:(fun () -> Single (xmin,Nil))
+	~single:(fun x' l' -> (* assert (xmin > x');*) if xmin=x'+1 then Interv (xmin,x',l') else Single (xmin,l))
+	~interv:(fun (xmax',xmin') l' -> (* assert (xmin > xmax');*) if xmin=xmax'+1 then Interv (xmin,xmin',l') else Single (xmin,l))
     else (* xmin > xmax *) l;;
 
-let empty : t = [];;
+let rec append : t -> t -> t = (* assumes (min_elt l1) > (max_elt l2) *)
+  fun l1 l2 ->
+    if l2 = Nil
+    then l1
+    else
+      let m = max_elt l2 in
+      append_aux l1 (m,l2)
+and append_aux l1 (m,l2) =
+  match l1 with
+  | Nil -> l2
+  | Single (x,Nil) -> if x=m+1 then cons_single x l2 else Single (x,l2)
+  | Interv (xmax,xmin,Nil) -> if xmin=m+1 then cons_interv (xmax,xmin) l2 else Interv (xmax,xmin,l2)
+  | Single (x,l') -> Single (x, append_aux l' (m,l2))
+  | Interv (xmax,xmin,l') -> Interv (xmax, xmin, append_aux l' (m,l2))
+
+(* -------------------------- *)
+
+let empty : t = Nil;;
 
 let is_empty : t -> bool =
-  fun l -> l = []
+  fun l -> l = Nil
 
 let rec cardinal : t -> int =
   fun l -> cardinal_aux 0 l
       ~interv:(fun (xmax,xmin) l_tail ->
 	(xmax >= e & e >= xmin) or (pred xmin > e & mem e l_tail));;
 
+let choose : t -> elt =
+  fun l ->
+    step l
+      ~nil:(fun () -> raise Not_found)
+      ~single:(fun x _ -> x)
+      ~interv:(fun (xmax,xmin) _ -> xmax);;
+
 let singleton : elt -> t =
-  fun x -> [x]
+  fun x -> Single (x,Nil)
 
 let rec add : int -> t -> t =
   fun x l ->
 	for x = xmax downto xmin do proc x done;
 	iter proc l_tail);;
 
-let rec fold : ('a -> elt -> 'a) -> 'a -> t -> 'a =
+let rec fold_left : ('a -> elt -> 'a) -> 'a -> t -> 'a =
   fun f e l ->
     step l
       ~nil:(fun () -> e)
       ~single:(fun x l_tail ->
-	fold f (f e x) l_tail)
+	fold_left f (f e x) l_tail)
+      ~interv:(fun (xmax,xmin) l_tail ->
+	fold_left f (fold_for_down (fun x res -> f res x) xmax xmin e) l_tail);;
+
+let rec fold_right : (elt -> 'a -> 'a) -> t -> 'a -> 'a =
+  fun f l e ->
+    step l
+      ~nil:(fun () -> e)
+      ~single:(fun x l_tail ->
+	f x (fold_right f l_tail e))
       ~interv:(fun (xmax,xmin) l_tail ->
-	fold f (Common.fold_for_down (fun x res -> f res x) xmax xmin e) l_tail);;
+	fold_for (fun x res -> f x res) xmin xmax (fold_right f l_tail e));;
 
 let rec elements : t -> elt list =
   fun l ->
-    fold (fun res x -> x::res) [] l;;
+    List.rev (fold_left (fun res x -> x::res) [] l);;
 
 
 (* test section *)
     | None::l -> filter l
     | Some x::l -> x::filter l
 
+let rec remove_first : 'a -> 'a list -> 'a list =
+  fun e -> function
+    | [] -> []
+    | x::l ->
+	if x = e
+	then l
+	else x::remove_first e l
+
 let rec mapfilter : ('a -> 'b option) -> 'a list -> 'b list =
   fun f -> function
       [] -> []
     | [] -> []
     | x::xs -> sub_list xs (pos-1) len
 
+let rec list_set_nth l n x =
+  match l with
+  | [] -> invalid_arg "Common.list_set_nth"
+  | e::l' ->
+      if n = 0
+      then x::l'
+      else e::list_set_nth l' (n-1) x
+
+let rec list_insert_nth l n l1 =
+  match l with
+  | [] -> invalid_arg "Common.list_insert_nth"
+  | e::l' ->
+      if n = 0
+      then l1 @ l'
+      else e :: list_insert_nth l' (n-1) l1
+
+let rec list_remove_nth l n =
+  match l with
+  | [] -> invalid_arg "Common.list_remove_nth"
+  | e::l' ->
+      if n = 0
+      then l'
+      else e::list_remove_nth l' (n-1)
+
+let list_n n =
+  let aux i acc =
+    if i = 0
+    then acc
+    else aux (i-1) ((i-1)::acc)
+  in
+  aux n []
+
+let rec list_index i = function
+  | [] -> []
+  | x::l -> (i,x)::list_index (i+1) l
 
 (* utilities on streams *)
 
 
 (* for profiling *)
 
-let tbl_prof : (string,(int * float * float)) Hashtbl.t = Hashtbl.create 100
+type prof_elem = {mutable prof_on : bool; mutable prof_nb : int; mutable prof_time : float; mutable prof_mem : float}
+let tbl_prof : (string, prof_elem) Hashtbl.t = Hashtbl.create 100
 
 let prof : string -> (unit -> 'a) -> 'a =
   fun s f -> (* f () *)
+    let elem =
+      try Hashtbl.find tbl_prof s
+      with Not_found ->
+	let elem = {prof_on = false; prof_nb = 0; prof_time = 0.; prof_mem = 0.} in
+	Hashtbl.add tbl_prof s elem;
+	elem in
+    let on = elem.prof_on in
 (* print_string ("<"^s^":"); flush stdout; *)
+    elem.prof_on <- true;
     let m1 = Gc.allocated_bytes () (* float_of_int (Gc.stat ()).Gc.live_words *) in
     let d, y = chrono f in
     let m2 = Gc.allocated_bytes () (* float_of_int (Gc.stat ()).Gc.live_words *) in
-    let n, t, m = try Hashtbl.find tbl_prof s with Not_found -> 0, 0., 0. in
-    Hashtbl.replace tbl_prof s (n+1, t +. d, m +. (m2 -. m1));
+    elem.prof_on <- on;
+    elem.prof_nb <- elem.prof_nb + 1;
+    if not on then elem.prof_time <- elem.prof_time +. d;
+    if not on then elem.prof_mem <- elem.prof_mem +. (m2 -. m1);
 (* print_string (s^">\n"); flush stdout; *)
     y
 
       val add : int * int -> t -> t
       val remove : int * int -> t -> t
       val domain : t -> R1.t
+      val domain_inter : R1.t -> t -> R1.t
       val range : t -> R1.t
+      val range_inter : R1.t -> t -> R1.t
       val forward : t -> R1.t -> R1.t
       val backward : t -> R1.t -> R1.t
-      val domain_inter : R1.t -> t -> t
-      val domain_diff : R1.t -> t -> t
-      val range_inter : R1.t -> t -> t
-      val range_diff : R1.t -> t -> t
+      val inter_domain : t -> R1.t -> t
+      val diff_domain : t -> R1.t -> t
+      val inter_range : t -> R1.t -> t
+      val diff_range : t -> R1.t -> t
       val union : t -> t -> t
       val inter : t -> t -> t
       val diff : t -> t -> t
       val fold : ('a -> int * int -> 'a) -> 'a -> t -> 'a
       val memory_size : t -> int
     end
+
+(*
+    module R : sig
+      type 'a t
+      val dim : 'a t -> int
+      val empty : 'a t
+      val cardinal : 'a t -> int
+      val mem : 'a -> 'a t -> bool
+      val add : 'a -> 'a t -> 'a t
+      val union : 'a t -> 'a t -> 'a t
+    end	
+*)
   end
 
 module Map : T =
 
 	let domain p = M.fold (fun x ran res -> R1.add x res) p R1.empty
 
+	let domain_inter a p = M.fold (fun x ran res -> if R1.mem x a then R1.add x res else res) p R1.empty
+
 	let range p = M.fold (fun x ran res -> R1.union ran res) p R1.empty
 
-	let domain_inter a p = M.fold (fun x ran res -> if R1.mem x a then M.add x ran res else res) p M.empty
+	let range_inter b p = M.fold (fun x ran res -> let ran' = R1.inter ran b in if R1.is_empty ran' then R1.union ran' res else res) p R1.empty
+
+	let inter_domain p a = M.fold (fun x ran res -> if R1.mem x a then M.add x ran res else res) p M.empty
 
-	let domain_diff a p = M.fold (fun x ran res -> if R1.mem x a then res else M.add x ran res) p M.empty
+	let diff_domain p a = M.fold (fun x ran res -> if R1.mem x a then res else M.add x ran res) p M.empty
 
-	let range_inter b p = M.fold (fun x ran res -> let ran' = R1.inter ran b in if R1.is_empty ran' then res else M.add x ran' res) p M.empty
+	let inter_range p b = M.fold (fun x ran res -> let ran' = R1.inter ran b in if R1.is_empty ran' then res else M.add x ran' res) p M.empty
 
-	let range_diff b p = M.fold (fun x ran res -> let ran' = R1.diff ran b in if R1.is_empty ran' then res else M.add x ran' res) p M.empty
+	let diff_range p b = M.fold (fun x ran res -> let ran' = R1.diff ran b in if R1.is_empty ran' then res else M.add x ran' res) p M.empty
 
 	let forward p a = M.fold (fun x ran res -> if R1.mem x a then R1.union ran res else res) p R1.empty
 
 
 	let domain p = M.domain p
 
+	let domain_inter a p = M.domain_inter a p
+
 	let range p = M.fold (fun res x ran -> R1.union res ran) R1.empty p
 
-	let domain_inter a p =
-	  M.map (fun x ran -> if R1.mem x a then Some ran else None) p
-	  (* M.map_inter (fun x _ ran -> Some ran) a p *)
+	let range_inter b p = M.fold (fun res x ran -> let ran' = R1.inter ran b in if R1.is_empty ran' then res else R1.union res ran') R1.empty p
+
+	let inter_domain p a =
+	  (* M.map (fun x ran -> if R1.mem x a then Some ran else None) p *)
+	  M.map_inter (fun x ran _ -> Some ran) p a
 
-	let domain_diff a p = M.map (fun x ran -> if R1.mem x a then None else Some ran) p
+	let diff_domain p a =
+	  (* M.map (fun x ran -> if R1.mem x a then None else Some ran) p *)
+	  M.map_diff (fun x ran -> function None -> Some ran | Some _ -> None) p a
 
-	let range_inter b p = M.map (fun x ran -> let ran' = R1.inter ran b in if R1.is_empty ran' then None else Some ran') p
+	let inter_range p b = M.map (fun x ran -> let ran' = R1.inter ran b in if R1.is_empty ran' then None else Some ran') p
 
-	let range_diff b p = M.map (fun x ran -> let ran' = R1.diff ran b in if R1.is_empty ran' then None else Some ran') p
+	let diff_range p b = M.map (fun x ran -> let ran' = R1.diff ran b in if R1.is_empty ran' then None else Some ran') p
 
-	let forward p a =
-	  M.fold (fun res x ran -> if R1.mem x a then R1.union res ran else res) R1.empty p
-	  (* range (M.map_inter (fun x ran _ -> Some ran) p a) *) (* M.map_inter looks buggy *)
-	  (* should be: M.fold_inter (fun res x ran _ -> R1.union res ran) R1.empty p a) *)
+	let forward p a = M.fold_inter (fun res x ran _ -> R1.union res ran) R1.empty p a
 
 	let backward p b = M.domain ~filter:(fun x ran -> let ran' = R1.inter ran b in not (R1.is_empty ran')) p
 
 
 	let memory_size p = M.memory_size ~f:R1.memory_size p
       end
+
   end
 
+
+
 module Test (X : T) =
   struct
     module R1 = X.R1
     method subst : (int * 'a term) list -> 'a term = fun env -> (self :> 'a term)
     method reduce : 'a term = (self :> 'a term)
     method virtual to_string : string
-    method virtual map : ('a -> 'a term) -> 'a term
-(*
-    method virtual fold_left : 'b. ('b -> 'a -> 'b) -> 'b -> 'b
-*)
+    method map : ('a -> 'a term) -> 'a term = fun f -> (self :> 'a term)
   end
 
 type ('a, 'b) expr = Expr of 'a term
 
-class ['a] var =
+class ['a] var (id : int) =
   object (self)
     inherit ['a] term
-    method case = `Var (Oo.id self)
+    val id = id
+    method case = `Var id
     method subst env =
-      try List.assoc (Oo.id self) env
+      try List.assoc id env
       with Not_found -> (self :> 'a term)
-    method to_string = "x" ^ string_of_int (Oo.id self)
-    method map f = (self :> 'a term)
+    method to_string = "x" ^ string_of_int id
+    method map f = (f (`Var id) :> 'a term)
 (*    method fold_left f init = f init self#case *)
   end
 
-class ['a] abs (x : 'a var) (t : 'a term) =
+class ['a] abs (x : int) (t : 'a term) =
   object (self)
     inherit ['a] term
     val x = x
     method case = `Abs (x,t)
     method subst env = ({<x = x; t = t#subst env>} :> 'a term)
     method reduce = ({<x = x; t = t#reduce>} :> 'a term)
-    method to_string = x#to_string ^ "\\" ^ t#to_string
+    method to_string = "x" ^ string_of_int x ^ "\\" ^ t#to_string
     method map f = f (`Abs (x, t#map f))
   end
-let abs (f : 'a term -> 'a term) =
-  let x = new var in
-  (new abs x (f (x :> 'a term)) :> 'a term)
+let cpt = ref 0
+let abs =
+  fun (f : 'a term -> 'a term) ->
+    let x = incr cpt; !cpt in
+    (new abs x (f (new var x :> 'a term)) :> 'a term)
 let eabs (f : ('a,'b) expr -> ('a,'c) expr) : ('a,'b -> 'c) expr =
   Expr (abs (fun x -> let Expr y = f (Expr x) in y))
 
     method case = `App (t,u)
     method subst env = ({<t = t#subst env; u = u#subst env>} :> 'a term)
     method reduce =
-      match t#case with
-      | `Abs (x,v) -> (v#subst [(Oo.id x, u)])#reduce
-      | _ -> ({<t = t#reduce; u = u#reduce>} :> 'a term)
+      let t' = t#reduce in
+      match t'#case with
+      | `Abs (x,v) -> (v#subst [(x, u)])#reduce
+      | _ -> ({<t = t'; u = u#reduce>} :> 'a term)
     method to_string = "(" ^ t#to_string ^ " " ^ u#to_string ^ ")"
     method map f = f (`App (t#map f, u#map f))
   end
 (* Optional *)
 type 'a case =
     [ `Var of int
-    | `Abs of 'a * 'a
+    | `Abs of int * 'a
     | `App of 'a * 'a ]
 type closed_term = 'a case term as 'a
 type 'b closed_expr = (closed_term case,'b) expr
 let t0 () : closed_term = abs (fun x -> app x x)
 (* let et0 = eabs (fun x -> eapp x x) *) (* should not typecheck *)
 
+(* another (orthogonal) implementation of reduce *)
+let reduce_case reduce_rec =
+  function
+    | `Var x -> new var x
+    | `Abs (x,v') -> new abs x v'
+    | `App (u',v') ->
+	match u'#case with
+	| `Abs (x,w) -> reduce_rec (w#subst [(x, v')])
+	| _ -> new app u' v'
+let rec reduce t = t#map (reduce_case reduce)
+
 let rec reduce t =
-  t#map
-    (function
-      | `Var _ -> new var
-      | `Abs (x,v) -> new abs x v
-      | `App (u,v) ->
-	  match u#case with
-	  | `Abs (x,w) -> reduce (w#subst [(Oo.id x, v)])
-	  | _ -> new app u v)
+  match t#case with
+  | `Var x -> new var x
+  | `Abs (x,v) -> new abs x (reduce v)
+  | `App (u,v) ->
+      let u' = reduce u in
+      let v' = reduce v in
+      match u'#case with
+      | `Abs (x,w) -> reduce (w#subst [(x,v')])
+      | _ -> new app u' v'
+
+let rec to_string t =
+  match t#case with
+  | `Var x -> "x" ^ string_of_int x
+  | `Abs (x,v) -> "x" ^ string_of_int x ^ "\\" ^ to_string v
+  | `App (u,v) -> "(" ^ to_string u ^ ", " ^ to_string v ^ ")"
+
+class ['a] to_string = (* allows extendable recursion without need for additional names *)
+  object (self)
+    method apply (t : 'a term case) : string =
+      match t with
+      | `Var x -> "x" ^ string_of_int x
+      | `Abs (x,v) -> "x" ^ string_of_int x ^ "\\" ^ self#apply v#case
+      | `App (u,v) -> "(" ^ self#apply u#case ^ ", " ^ self#apply v#case ^ ")"
+  end
 
 (* Tests *)
 
 	      eapp (eapp p2 x) y))))) in
   let t1 = t#reduce in
   print_endline t1#to_string
+
+(* Extension with constants *)
+
+class ['a,'c] const (c : 'c) =
+  object
+    inherit ['a] term
+    val c = c
+    method case = `Const c
+    method to_string = "const"
+  end
+let const c = new const c
+let econst c : ('a,'b) expr = Expr (const c)
+
+type ('a,'c) case2 = [ 'a case | `Const of 'c]
+
+class ['a,'c] to_string2 =
+  object
+    inherit ['a] to_string as to_string
+    method apply t =
+      match t with
+      | #case as t1 -> to_string#apply t1
+      | `Const (c : 'c) -> "const"
+  end
+
+let etest2 () =
+  let Expr t = eapp (eabs (fun (x : ('a,'b) expr) -> x)) (econst 1 : ('a,'b) expr) in
+  print_endline (to_string2#apply t#case);
+  let t1 = t#reduce in
+  print_endline t1#to_string
+
 {
-open Token
+open Tokens
 
 let norm_string : string -> string =
   fun s ->
 let skip_char = [' ' '\t' '\n']
 let ident_char = ['A'-'Z' 'a'-'z' '0'-'9' '_']
 let digit = ['0'-'9']
-(* let special_char = ['~' '@' '#' '$' '%' '^' '&' '*' '-' '+' '=' '|' '\\' '/' '>' '<'] *)
+let special_char = ['~' '@' '#' '$' '%' '^' '&' '*' '-' '+' '=' '|' '\\' '/' '>' '<']
 
 rule token = parse
 | skip_char { token lexbuf }
 | "\\\n" { token lexbuf }
 | '`' { BackQuote }
-| '~' { Tilda }
 | '!' { Exclam }
-| '@' { At }
-| '#' { Sharp }
-| '$' { Dollar }
-| '%' { Percent }
-| '^' { Hat }
-| '&' { Et }
-| '*' { Star }
 | '(' { LeftPar }
 | ')' { RightPar }
-| '-' { Minus }
-| '+' { Plus }
-| '=' { Equal }
 | '{' { LeftAcc }
 | '}' { RightAcc }
 | '[' { LeftBra }
 | ']' { RightBra }
-| '|' { Pipe }
-| '\\' { BackSlash }
-| '/' { Slash }
 | '?' { Interro }
-| '<' { LT }
-| '>' { GT }
 | ',' { Comma }
 | '.' { Dot }
 | ':' { Colon }
 | ';' { SemiColon }
 | '"' { DoubleQuote }
 | '\'' { Quote }
-| ['a'-'z'] ident_char *
-    { Ident(Lexing.lexeme lexbuf) }
-| ['A'-'Z' '_'] ident_char *
-    { Term(Lexing.lexeme lexbuf) }
 | '0'
     { Nat 0 }
+| '-' '0'
+    { MinusNat 0 }
 | ['1'-'9'] digit*
-    { Nat(int_of_string(Lexing.lexeme lexbuf)) }
+    { Nat (int_of_string (Lexing.lexeme lexbuf)) }
+| '-' ['1'-'9'] digit*
+    { MinusNat (- (int_of_string (Lexing.lexeme lexbuf))) }
+| ['A'-'Z' 'a'-'z' '_'] ident_char *
+    { Symbol (Lexing.lexeme lexbuf) }
+| special_char +
+    { Symbol (Lexing.lexeme lexbuf) }
 | '`' _ '`'
-    { Char((norm_string (Lexing.lexeme lexbuf)).[1]) }
+    { Char ((norm_string (Lexing.lexeme lexbuf)).[1]) }
 | '"' [^ '\\' '"']* ('\\' _ [^ '\\' '"']*)* '"'
-  { let s = Lexing.lexeme lexbuf in String(norm_string (String.sub s 1 (String.length s - 2))) }
+  { let s = Lexing.lexeme lexbuf in String (norm_string (String.sub s 1 (String.length s - 2))) }
 | '\'' [^ '\\' '\'']* ('\\' _ [^ '\\' '\'']*)* '\''
-  { let s = Lexing.lexeme lexbuf in Term(norm_string (String.sub s 1 (String.length s - 2))) }
+  { let s = Lexing.lexeme lexbuf in Symbol (norm_string (String.sub s 1 (String.length s - 2))) }
 | eof { raise Eof }
 OCAMLLEX=ocamllex
-OCAMLC=ocamlc -g
+OCAMLC=ocamlc
 OCAMLOPT=ocamlopt
 INCLUDES=            # all relevant -I options here
-OCAMLFLAGS= -pp "camlp4o pa_op.cmo" -thread $(INCLUDES)    # add other options for ocamlc here
+#OCAMLFLAGS= -pp "camlp4o pa_op.cmo" -thread $(INCLUDES)    # add other options for ocamlc here
+OCAMLFLAGS= -pp camlp4o -thread $(INCLUDES)    # add other options for ocamlc here
 
 .SUFFIXES: .mll .ml .mli .cmo .cmi
 
 # Make all
-all: common.cmo threads_common.cmo token.cmo lexer.cmo syntax.cmo lSet.cmo cis.cmo setset.cmo ext.cmo term.cmo cache.cmi cache.cmo logdag.cmi logdag.cmo
+all: common.cmo threads_common.cmo unicode.cmo tokens.cmo lexer.cmo syntax.cmo bintree.cmo lSet.cmo cis.cmi cis.cmo iterator.cmo intmap.cmo intset.cmo intrel.cmo intreln.cmo text_index.cmo setset.cmo term.cmo cache.cmi cache.cmo ext.cmo logdag.cmi logdag.cmo suffix_tree.cmo index.cmo persindex.cmo genid.cmo persintset.cmo stringset.cmo seq.cmo seqset.cmo
 	echo
 
 # archiving

File suffix_tree.ml

 (**
-   Suffix trees with incremental addition and removal of strings.
+   Suffix trees.
+
+   Suffix trees with incremental addition and removal of strings
    plus incremental maintenance of maximal factors.
+
+
+   Author: S-Aébastien Ferré <ferre@irisa.fr>.-b
+
+   License: LGPL
 *)
 
 (* for test *)
 (*
-#load "unix.cma";;
-#load "str.cma";;
-#load "nums.cma";;
-#load "common.cmo";;
 #load "cis.cmo";;
 #load "lSet.cmo";;
 *)
 
+(* copied from module Common *)
+
+let rec fold_while : ('a -> 'a option) -> 'a -> 'a =
+  fun f e ->
+    match f e with
+    | None -> e
+    | Some e' -> fold_while f e'
+
+let rec mapfind : ('a -> 'b option) -> 'a list -> 'b =
+  fun f -> function
+  | [] -> raise Not_found
+  | x::l -> match f x with
+      | None -> mapfind f l
+      | Some y -> y
+
+(* end of copy *)
+
 module type PARAM =
   sig
-(*    val is_visible : string -> bool *)
     val get_visible : string -> int * int
+	(** [get_visible s] returns the sizes of the prefix and suffix of [s]
+	   that can be removed from [s] without damage to its meaning. *)
   end
 
 module type T =
     let rec max_restrictions st node =
       let res1 = max_restrictions_aux st (LSet.empty ()) (path_restrictions st node) in
       let _, res2 =
-	Common.fold_while
+	fold_while
 	  (fun (res1, res2) ->
 	    match res1 with
 	    | [] -> None
       let factor = find_factor st str in
       match has_end st factor with
       | Some leafs ->
-	  Common.mapfind
+	  mapfind
 	    (fun leaf ->
 	      let (strid,pos) = suffix st leaf in
 	      if pos = 0 then Some strid else None) (* there should be only one *)
 let _ =
   ignore (add st "formal concept analysis");
   ignore (add st "logical concept analysis");
-  ignore (add st "conceptual graphs");;
+  ignore (add st "conceptual graphs");
+  tree st;;
 *)