Commit 8d1c7d8a authored by Pietro Abate's avatar Pietro Abate

[r2003-03-22 21:56:53 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-22 21:57:06+00:00
parent cfa78288
This diff is collapsed.
type 'a obj = { id : int; mutable v : 'a }
module type ARG =
sig
type 'a t
val dump: Format.formatter -> 'a t -> unit
type 'a t (* = True | False | Split of 'a obj * 'a t * 'a t * 'a t *)
val equal: 'a t -> 'a t -> bool
val hash: 'a t -> int
val compare: 'a t -> 'a t -> int
end
val equal : 'a t -> 'a t -> bool
val compare: 'a t -> 'a t -> int
val hash: 'a t -> int
module type S =
sig
type 'a elem
type 'a t
val iter: ('a -> unit) -> ('a t -> unit)
val dump: Format.formatter -> 'a t -> unit
val print :
(Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
val dump : Format.formatter -> 'a t -> unit
val equal : 'a t -> 'a t -> bool
val compare: 'a t -> 'a t -> int
val hash: 'a t -> int
val dnf : 'a t -> ('a list * 'a list) list
val get: 'a t -> ('a elem list * 'a elem list) list
val compute: empty:'b -> any:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:('a -> 'b) -> 'a t -> 'b
val empty : 'a t
val full : 'a t
val cup : 'a t -> 'a t -> 'a t
val cap : 'a t -> 'a t -> 'a t
val diff : 'a t -> 'a t -> 'a t
val atom : 'a elem -> 'a t
val empty : 'a t
val any : 'a t
val ( !! ) : 'a obj -> 'a t
val ( ++ ) : 'a t -> 'a t -> 'a t
val ( ** ) : 'a t -> 'a t -> 'a t
val ( // ) : 'a t -> 'a t -> 'a t
val iter: ('a elem-> unit) -> 'a t -> unit
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:('a elem -> 'b) -> 'a t -> 'b
val print: string -> (Format.formatter -> 'a elem -> unit) -> 'a t ->
(Format.formatter -> unit) list
end
module Make(X : ARG) : S with type 'a elem = 'a X.t
......@@ -463,7 +463,6 @@ let fun do_table (X_table -> String) _ -> raise "<table> nothandled";;
do_tbodies
*)
match load_xml "tst_html2latex.xml" with
| x & X_html -> print (do_html x)
| _ -> raise "Input file is not XHTML !";;
......
......@@ -3,6 +3,7 @@ type v = AtomPool.t
let value = AtomPool.value
let mk = AtomPool.mk
let vcompare = AtomPool.compare
let vhash = AtomPool.hash
module SList = SortedList.Make_transp(SortedList.Lift(AtomPool))
type t = Finite of unit SList.t | Cofinite of unit SList.t
......
......@@ -3,6 +3,7 @@ val value: v -> string
val mk: string -> v
val print_v: Format.formatter -> v -> unit
val vcompare: v -> v -> int
val vhash: v -> int
type t
......
......@@ -26,6 +26,8 @@ let print_v_in_string ppf c =
let vcompare (v1:int) v2 =
if v1 = v2 then 0 else if v1 < v2 then -1 else 1
let vhash i = i
type t = (v * v) list
......
......@@ -6,6 +6,7 @@ val to_char: v -> char
val print_v : Format.formatter -> v -> unit
val print_v_in_string : Format.formatter -> v -> unit
val vcompare: v -> v -> int
val vhash: v -> int
type t (* = (Unichar.t * Unichar.t) list *)
val equal : t -> t -> bool
......
......@@ -3,6 +3,7 @@ open Big_int
type v = big_int
let print_v ppf i = Format.fprintf ppf "%s" (string_of_big_int i)
let vcompare = compare_big_int
let vhash = num_digits_big_int (* improve this *)
let mk = big_int_of_string
let vadd = add_big_int
let vmult = mult_big_int
......@@ -37,9 +38,6 @@ let rec equal l1 l2 =
| ([], []) -> true
| _ -> false
let vhash = num_digits_big_int
(* improve this *)
let rec hash accu = function
| Bounded (a,b) :: rem ->
hash (1 + 2 * (vhash a) + 3 * (vhash b) + 17 * accu) rem
......
......@@ -3,6 +3,8 @@ val print_v : Format.formatter -> v -> unit
val mk: string -> v
val vcompare: v -> v -> int
val vhash: v -> int
val vadd: v -> v -> v
val vmult: v -> v -> v
val vsub: v -> v -> v
......
This diff is collapsed.
......@@ -83,6 +83,7 @@ sig
val assoc_present: 'a elem -> ('a,'b) map -> 'b
val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
val hash: ('b -> int) -> ('a,'b) map -> int
end
end
......@@ -382,6 +383,9 @@ module Map = struct
| [],_ -> -1
| _,[] -> 1
let rec hash f = function
| [] -> 1
| (x,y)::l -> X.hash x + 17 * (f y) + 257 * (hash f l)
end
end
......
......@@ -79,6 +79,7 @@ sig
val assoc: 'a elem -> ('a,'b) map -> 'b
val assoc_present: 'a elem -> ('a,'b) map -> 'b
val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
val hash: ('b -> int) -> ('a,'b) map -> int
end
end
......
......@@ -16,9 +16,6 @@ open Ident
*)
let map_sort f l =
SortedList.from_list (List.map f l)
module HashedString =
struct
type t = string
......@@ -32,13 +29,30 @@ type const =
| Atom of Atoms.v
| Char of Chars.v
let compare_const c1 c2 =
match (c1,c2) with
| Integer x, Integer y -> Intervals.vcompare x y
| Integer _, _ -> -1
| _, Integer _ -> 1
| Atom x, Atom y -> Atoms.vcompare x y
| Atom _, _ -> -1
| _, Atom _ -> 1
| Char x, Char y -> Chars.vcompare x y
let hash_const = function
| Integer x -> Intervals.vhash x
| Atom x -> Atoms.vhash x
| Char x -> Chars.vhash x
type pair_kind = [ `Normal | `XML ]
type 'a node0 = { id : int; mutable descr : 'a }
module NodePair = struct
type 'a t = 'a node0 * 'a node0
let compare (x1,y1) (x2,y2) =
let dump ppf (x,y) =
Format.fprintf ppf "(%i,%i)" x.id y.id
let compare (y1,x1) (y2,x2) =
if x1.id < x2.id then -1
else if x1.id > x2.id then 1
else y1.id - y2.id
......@@ -49,6 +63,8 @@ end
module RecArg = struct
type 'a t = bool * 'a node0 label_map
let dump ppf (o,r) = ()
let rec compare_rec r1 r2 =
if r1 == r2 then 0
else match (r1,r2) with
......@@ -83,8 +99,8 @@ module RecArg = struct
let hash (o,r) = hash_rec (if o then 2 else 1) (LabelMap.get r)
end
module BoolPair = Boolean.Make(NodePair)
module BoolRec = Boolean.Make(RecArg)
module BoolPair = Bool.Make(NodePair)
module BoolRec = Bool.Make(RecArg)
type descr = {
atoms : Atoms.t;
......@@ -173,103 +189,6 @@ let diff x y =
}
let rec compare_rec r1 r2 =
if r1 == r2 then 0
else match (r1,r2) with
| (l1,x1)::r1,(l2,x2)::r2 ->
if ((l1:int) < l2) then -1
else if (l1 > l2) then 1
else if x1.id < x2.id then -1
else if x1.id > x2.id then 1
else compare_rec r1 r2
| ([],_) -> -1
| _ -> 1
let rec compare_rec_list l1 l2 =
if l1 == l2 then 0
else match (l1,l2) with
| (o1,r1)::l1, (o2,r2)::l2 ->
if o2 && not o1 then -1
else if o1 && not o2 then 1
else let c = compare_rec r1 r2 in if c <> 0 then c
else compare_rec_list l1 l2
| ([],_) -> -1
| _ -> 1
let rec compare_rec_bool l1 l2 =
if l1 == l2 then 0
else match (l1,l2) with
| (p1,n1)::l1, (p2,n2)::l2 ->
let c = compare_rec_list p1 p2 in if c <> 0 then c
else let c = compare_rec_list n1 n2 in if c <> 0 then c
else compare_rec_bool l1 l2
| ([],_) -> -1
| _ -> 1
let rec compare_times_list l1 l2 =
if l1 == l2 then 0
else match (l1,l2) with
| (x1,y1)::l1, (x2,y2)::l2 ->
if (x1.id < x2.id) then -1
else if (x1.id > x2.id) then 1
else if (y1.id < y2.id) then -1
else if (y1.id > y2.id) then 1
else compare_times_list l1 l2
| ([],_) -> -1
| _ -> 1
let rec compare_times_bool l1 l2 =
if l1 == l2 then 0
else match (l1,l2) with
| (p1,n1)::l1, (p2,n2)::l2 ->
let c = compare_times_list p1 p2 in if c <> 0 then c
else let c = compare_times_list n1 n2 in if c <> 0 then c
else compare_times_bool l1 l2
| ([],_) -> -1
| _ -> 1
let rec equal_rec r1 r2 =
(r1 == r2) ||
match (r1,r2) with
| (l1,x1)::r1,(l2,x2)::r2 ->
(x1.id = x2.id) && (l1 == l2) && (equal_rec r1 r2)
| _ -> false
let rec equal_rec_list l1 l2 =
(l1 == l2) ||
match (l1,l2) with
| (o1,r1)::l1, (o2,r2)::l2 ->
(o1 == o2) &&
(equal_rec r1 r2) && (equal_rec_list l1 l2)
| _ -> false
let rec equal_rec_bool l1 l2 =
(l1 == l2) ||
match (l1,l2) with
| (p1,n1)::l1, (p2,n2)::l2 ->
(equal_rec_list p1 p2) &&
(equal_rec_list n1 n2) &&
(equal_rec_bool l1 l2)
| _ -> false
let rec equal_times_list l1 l2 =
(l1 == l2) ||
match (l1,l2) with
| (x1,y1)::l1, (x2,y2)::l2 ->
(x1.id = x2.id) &&
(y1.id = y2.id) &&
(equal_times_list l1 l2)
| _ -> false
let rec equal_times_bool l1 l2 =
(l1 == l2) ||
match (l1,l2) with
| (p1,n1)::l1, (p2,n2)::l2 ->
(equal_times_list p1 p2) &&
(equal_times_list n1 n2) &&
(equal_times_bool l1 l2)
| _ -> false
let equal_descr a b =
(Atoms.equal a.atoms b.atoms) &&
(Chars.equal a.chars b.chars) &&
......@@ -293,40 +212,6 @@ let compare_descr a b =
else if b.absent && not a.absent then 1
else 0
(*
let compare_descr a b =
let c = compare_descr a b in
assert (c = compare a b);
c
*)
let rec hash_times_list accu = function
| (x,y)::l ->
hash_times_list (accu * 257 + x.id * 17 + y.id) l
| [] -> accu + 17
let rec hash_times_bool accu = function
| (p,n)::l ->
hash_times_bool (hash_times_list (hash_times_list accu p) n) l
| [] -> accu + 3
let rec hash_rec accu = function
| (l,x)::rem ->
hash_rec (257 * accu + 17 * (LabelPool.hash l) + x.id) rem
| [] -> accu + 5
let rec hash_rec_list accu = function
| (o,r)::l ->
hash_rec_list (hash_rec (if o then accu*3 else accu) r) l
| [] -> accu + 17
let rec hash_rec_bool accu = function
| (p,n)::l ->
hash_rec_bool (hash_rec_list (hash_rec_list accu p) n) l
| [] -> accu + 3
let hash_descr a =
let accu = Chars.hash 1 a.chars in
let accu = Intervals.hash accu a.ints in
......@@ -339,14 +224,24 @@ let hash_descr a =
accu
module DescrHash =
Hashtbl.Make(
struct
type t = descr
let hash = hash_descr
let equal = equal_descr
end
)
module Descr =
struct
type t = descr
let hash = hash_descr
let equal = equal_descr
let compare = compare_descr
end
module DescrHash = Hashtbl.Make(Descr)
module DescrMap = Map.Make(Descr)
module Descr1 =
struct
type 'a t = descr
let hash = hash_descr
let equal = equal_descr
let compare = compare_descr
end
module DescrSList = SortedList.Make(Descr1)
let hash_cons = DescrHash.create 17000
......@@ -420,14 +315,6 @@ let get_record r =
List.map line (BoolRec.get r)
module DescrMap = Map.Make(struct type t = descr let compare = compare end)
let check d =
BoolPair.check d.times;
BoolPair.check d.xml;
BoolPair.check d.arrow;
BoolRec.check d.record;
()
......@@ -1400,11 +1287,6 @@ let rec rec_normalize d =
BoolPair.empty (Product.normal ~kind:`XML d)
in
let record = d.record
(*
map_sort
(fun f -> map_sort (fun (l,(o,d)) -> (l,o,rec_normalize d)) f, [])
(Record.get d)
*)
in
define n { d with times = times; xml = xml; record = record };
n
......@@ -1428,6 +1310,7 @@ struct
(try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)
let check_strenghten t s =
(*
let left = match (BoolPair.get t.arrow) with [ (p,[]) ] -> p | _ -> assert false in
let rec aux = function
| [] -> raise Not_found
......@@ -1438,6 +1321,8 @@ struct
else aux rem
in
aux (BoolPair.get s.arrow)
*)
if subtype t s then t else raise Not_found
let check_simple_iface left s1 s2 =
let rec aux accu1 accu2 = function
......@@ -1546,38 +1431,3 @@ let print_stat ppf =
*)
()
(*
let rec print_normal_record ppf = function
| Success -> Format.fprintf ppf "Yes"
| Fail -> Format.fprintf ppf "No"
| FirstLabel (l,present,absent) ->
Format.fprintf ppf "%s?@[<v>@\n" (label_name l);
List.iter
(fun (t,n) ->
Format.fprintf ppf "(%a)=>@[%a@]@\n"
Print.print_descr t
print_normal_record n
) present;
if absent <> Fail then
Format.fprintf ppf "(absent)=>@[%a@]@\n" print_normal_record absent;
Format.fprintf ppf "@]"
*)
(*
let pr s = Types.Print.print Format.std_formatter (Syntax.make_type (Syntax.parse s));;
let pr' s = Types.Print.print Format.std_formatter
(Types.normalize (Syntax.make_type (Syntax.parse s)));;
BUG:
pr "'a | 'b where 'a = ('a , 'a) and 'b= ('b , 'b)";;
*)
(*
let nr s =
let t = Types.descr (Syntax.make_type (Syntax.parse s)) in
let n = Types.normal_record' t.Types.record in
Types.print_normal_record Format.std_formatter n;;
*)
......@@ -4,6 +4,9 @@ type const = | Integer of Intervals.v
| Atom of Atoms.v
| Char of Chars.v
val compare_const: const -> const -> int
val hash_const: const -> int
(** Algebra **)
type node
......@@ -20,8 +23,10 @@ val descr: node -> descr
val equal_descr: descr -> descr -> bool
val hash_descr: descr -> int
val compare_descr: descr -> descr -> int
module DescrHash: Hashtbl.S with type key = descr
module DescrSList: SortedList.S with type 'a elem = descr
module DescrMap: Map.S with type key = descr
(* Note: it seems that even for non-functional data, DescrMap
......@@ -203,5 +208,4 @@ sig
val print_descr: Format.formatter -> descr -> unit
end
val check: descr -> unit
val print_stat: Format.formatter -> unit
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment