custom.ml 5.15 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
module type T = sig
  type t

  (* Debugging *)
  val dump: Format.formatter -> t -> unit
  val check: t -> unit (* Check internal invariants *)

  (* Data structures *)
  val equal: t -> t -> bool
  val hash: t -> int
  val compare:t -> t -> int
end

module Dummy = struct
15 16 17 18 19
  let dump ppf _ = failwith "dump not implemented"
  let check _ = failwith "check not implemented"
  let equal t1 t2 = failwith "equal not implemented"
  let hash t = failwith "hash not implemented"
  let compare t1 t2 = failwith "compare not implemented"
20 21 22 23 24 25 26 27 28 29 30 31 32
end

let dump_list ?(sep="; ") f ppf l =
  Format.pp_print_string ppf "[ ";
  (match l with 
     | [] -> ()
     | [hd] -> f ppf hd
     | hd::tl -> 
	 f ppf hd; 
	 List.iter (fun x -> Format.pp_print_string ppf sep; f ppf x) tl
  );
  Format.pp_print_string ppf " ]"

33 34
let dump_array ?(sep="; ") f ppf a = dump_list ~sep f ppf (Array.to_list a)

35 36 37 38
module String : T with type t = string = struct
  type t = string
  let dump = Format.pp_print_string
  let check s = ()
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53

  let rec compare_string_aux s1 s2 l =
    if (l == 0) then 0 
    else
      let l = pred l in
      let c1 = Char.code (String.unsafe_get s1 l)
      and c2 = Char.code (String.unsafe_get s2 l) in
      if c1 != c2 then c2 - c1 else compare_string_aux s1 s2 l

  let compare s1 s2 =
    let l1 = String.length s1 and l2 = String.length s2 in
    if l1 != l2 then l2 - l1 else compare_string_aux s1 s2 l1


  let equal x y = compare x y = 0
54

55 56 57 58 59 60 61 62 63 64
  (* From btype.ml *)
  let hash s =
    let accu = ref 0 in
    for i = 0 to String.length s - 1 do
      accu := 223 * !accu + Char.code s.[i]
    done;
    (* reduce to 31 bits *)
    accu := !accu land (1 lsl 31 - 1);
    (* make it signed for 64 bits architectures *)
    if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
end

module Int : T with type t = int = struct
  type t = int
  let dump = Format.pp_print_int
  let check s = ()
  let equal : t -> t -> bool = (=)
  let compare : t -> t -> int = Pervasives.compare
  let hash x = x
end

module Bool : T with type t = bool = struct
  type t = bool
  let dump = Format.pp_print_bool
  let check s = ()
  let equal : t -> t -> bool = (=)
  let compare : t -> t -> int = Pervasives.compare
  let hash x = if x then 1 else 0
end

85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
module Array(X : T) = struct
  module Elem = X
  type t = X.t array
  let dump = dump_array X.dump
  let check a = Array.iter X.check a

  let rec compare_elems a1 a2 i l =
    if (i = l) then 0
    else
      let c = X.compare a1.(i) a2.(i) in
      if c <> 0 then c else compare_elems a1 a2 (succ i) l

  let compare a1 a2 =
    let l1 = Array.length a1 and l2 = Array.length a2 in
    let c = Pervasives.compare l1 l2 in if c <> 0 then c
    else compare_elems a1 a2 0 l1

  let equal a1 a2 = compare a1 a2 == 0

  let hash a =
    let h = ref (Array.length a) in
    Array.iter (fun x -> h := 17 * !h + X.hash x) a;
    !h
end

110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
module List(X : T) = struct
  module Elem = X
  type t = X.t list
  let dump = dump_list X.dump
  let check l = List.iter X.check l

  let rec equal l1 l2 =
    (l1 == l2) ||
    match (l1,l2) with
      | x1::l1, x2::l2 -> (X.equal x1 x2) && (equal l1 l2)
      | _ -> false

  let rec hash accu = function
    | [] -> 1 + accu
    | x::l -> hash (17 * accu + X.hash x) l

  let hash l = hash 1 l

  let rec compare l1 l2 =
    if l1 == l2 then 0 
    else match (l1,l2) with
      | x1::l1, x2::l2 -> 
	  let c = X.compare x1 x2 in if c <> 0 then c 
	  else compare l1 l2
      | [],_ -> -1
      | _ -> 1
end

module Pair(X : T)(Y : T) = struct
  type t = X.t * Y.t
  let dump ppf (x,y) = Format.fprintf ppf "(%a,%a)" X.dump x Y.dump y
  let check (x,y) = X.check x; Y.check y
  let compare (x1,y1) (x2,y2) =
    let c = X.compare x1 x2 in if c <> 0 then c
    else Y.compare y1 y2
  let equal (x1,y1) (x2,y2) = (X.equal x1 x2) && (Y.equal y1 y2)
146
  let hash (x,y) = X.hash x + 65599 * Y.hash y
147
end
148

149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
type ('a,'b) choice = Left of 'a | Right of 'b

module Sum(X : T)(Y : T) = struct
  type t = (X.t,Y.t) choice
  let equal t1 t2 =
    match t1,t2 with
      | Left t1, Left t2 -> X.equal t1 t2
      | Right t1, Right t2 -> Y.equal t1 t2
      | _ -> false
  let hash = function
    | Left t1 -> 1 + 3 * X.hash t1
    | Right t2 -> 2 + 3 * Y.hash t2
  let compare t1 t2 =
    match t1,t2 with
      | Left t1, Left t2 -> X.compare t1 t2 
      | Right t1, Right t2 -> Y.compare t1 t2
      | Left _, Right _ -> -1
      | Right _, Left _ -> 1
  let check t = ()
  let dump ppf = function
    | Left t -> Format.fprintf ppf "L%a" X.dump t
    | Right t -> Format.fprintf ppf "R%a" Y.dump t
171 172
end

173 174
type var = [ `Var of String.t ] 
type 'a pairvar = [ `Atm of 'a | var ]
175 176 177

module Var (X : T) = struct
  type t = X.t pairvar
178 179
  let hash = function `Atm t -> X.hash t | `Var s -> (* String.hash s *) Hashtbl.hash (`Var s)
  let check = function `Atm t -> X.check t | `Var _ -> ()
180 181
  let compare t1 t2 =
    match t1,t2 with
182
    |`Atm x, `Atm y -> X.compare x y
183 184 185
    |`Var x, `Var y when x = y -> 0
    (* HACK fix BoolVar.get to get variables in the correct order *)
    |`Var x, `Var y -> if String.compare x y = -1 then 1 else -1
186 187
    |`Var _, `Atm _ -> -1
    |`Atm _, `Var _ -> 1
188 189 190

  let equal t1 t2 = (compare t1 t2) = 0
  let dump ppf = function 
191 192
    |`Atm x -> X.dump ppf x
    |`Var x -> String.dump ppf x
193
end