(* $Id: tbl31.ml,v 1.13 2003/07/31 12:21:16 yori Exp $ *)
(* Copyright 2002, 2003 Yamagata Yoriyuki. distributed with LGPL *)

(* CRC-hash, algorithm comes from addnode.c/pathalias *)
(* 31-bits CRC-polynomial, by Andrew Appel*)
let poly = 0x48000000

let crc_tbl = Array.init 128 (fun i ->
  let rec loop j sum =
    if j < 0 then sum else
    if i land (1 lsl j) <> 0 then
      loop (j - 1) (sum lxor (poly lsr j))
    else
      loop (j - 1) sum in
  loop (7 - 1) 0)

let byte3 n = n lsr 24 land 127
let byte2 n = n lsr 16 land 255
let byte1 n = n lsr 8 land 255
let byte0 n = n land 255

let compare_uint n1 n2 =
  let sgn1 = (n1 lsr 24) - (n2 lsr 24) in
  if sgn1 = 0 then (n1 land 0xffffff) - (n2 land 0xffffff) else sgn1

let (lsl) x n =
  if n >= Sys.word_size then 0 else
  if n <= ~- Sys.word_size then 0 else
  if n < 0 then x lsr (~-n) else
  x lsl n

let byte st n =
  match st with
    0 -> byte0 n | 1 -> byte1 n | 2 -> byte2 n | 3 -> byte3 n
  | _ -> assert false

type 'a tbl = 'a array array array array
type 'a t = 'a tbl

type 'a tagged = Tag of 'a * int

let untag (Tag (a, _)) = a
let id (Tag (_, n)) = n

let get tbl n =
  let lev = Array.unsafe_get tbl (byte3 n) in
  let lev = Array.unsafe_get lev (byte2 n) in
  let lev = Array.unsafe_get lev (byte1 n) in
  Array.unsafe_get lev (byte0 n)

(* let get tbl n =
  Printf.printf "level 3 %d" (Array.length tbl); print_newline ();
  let lev = tbl.(byte3 n) in
  Printf.printf "level 2 %d" (Array.length tbl); print_newline ();
  let lev = lev.(byte2 n) in
  Printf.printf "level 1 %d" (Array.length tbl); print_newline ();
  let lev = lev.(byte1 n) in
  Printf.printf "level 0 %d" (Array.length tbl); print_newline ();
  lev.(byte0 n) *)

module type NodeType = sig 
  type elt
  type t
  val level : int
  val make : elt -> t tagged
  val of_map : int -> elt -> elt IMap.t -> t tagged
  val of_set : int -> elt -> ISet.t -> elt -> t tagged
end

module MakeNode (Sub : NodeType) = struct
  type elt = Sub.elt
  type node = Sub.t array
  type t = node

  let level = Sub.level + 1

  module NodeHash = struct
    type t = node tagged

    let equal x y =
      let a = untag x in
      let b = untag y in
      let rec loop i =
	if i < 0 then true else
	if a.(i) == b.(i) then loop (i - 1) else
	false in
      loop  (if level = 3 then 127 else 255)

    let hash = id
  end

  module NodePool = Weak.Make (NodeHash)
  let pool = NodePool.create 256

  let crc_hash v =
    let rec loop i sum =
      if i < 0 then sum else
      let a = id v.(i) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte3 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte2 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte1 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte0 a) land 0x7f) in
      loop (i - 1) sum in
    loop (if level = 3 then 127 else 255) 0

  let hashcons a =
    let n = crc_hash a in
    let b = Array.map untag a in
(*    prerr_int (Array.length b); prerr_newline(); *)
    let x = Tag (b, n) in
    try NodePool.find pool x with Not_found ->
      NodePool.add pool x;
      x

  let make_raw def = 
    Array.make (if level = 3 then 128 else 256) (Sub.make def)
      
  let make def = hashcons (make_raw def)

  let of_map n0 def m =
    let a = make_raw def in begin
      if IMap.is_empty m then () else
      let l = AvlTree.left_branch m in
      let r = AvlTree.right_branch m in
      if IMap.is_empty l && IMap.is_empty r then
	let k1, k2, v = AvlTree.root m in
	let i1 = (k1 - n0) lsr (8 * level) in
	let n1 = n0 lor (i1 lsl (8 * level)) in
	let n2 = n1 lor (1 lsl (8 * level) - 1) in
	a.(i1) <- Sub.of_map n1 def (IMap.until n2 (IMap.from n1 m));
	let i2 = (k2 - n0) lsr (8 * level) in
	if i1 <> i2 then
	  let n1 = n0 lor (i2 lsl (8 * level)) in
	  let n2 = n1 lor (1 lsl (8 * level) - 1) in
	  a.(i2) <- Sub.of_map n1 def (IMap.until n2 (IMap.from n1 m));
	  let b = Sub.make v in
	  for i = i1 + 1 to i2 - 1 do a.(i) <- b done;
	else ()
      else
	for i = 0 to if level = 3 then 127 else 255 do
	  let n1 = n0 lor (i lsl (8 * level)) in
	  let n2 = n1 lor (1 lsl (8 * level) - 1) in
	  let m' = IMap.until n2 (IMap.from n1 m) in
	  if IMap.is_empty m' then () else
	  a.(i) <- Sub.of_map n1 def m'
	done
    end;
    hashcons a

  let of_set n0 def s v =
    let a = make_raw def in
    for i = 0 to if level = 3 then 127 else 255 do
      let n1 = n0 lor (i lsl (8 * level)) in
      let n2 = n1 lor (1 lsl (8 * level) - 1) in
      let s' = ISet.until n2 (ISet.from n1 s) in
      if ISet.is_empty s' then () else
      a.(i) <- Sub.of_set n1 def s' v
    done;
    hashcons a
end

module MakeTbl (Lev0 : NodeType) = struct
  module Lev1 = MakeNode (Lev0)
  module Lev2 = MakeNode (Lev1)
  module Lev3 = MakeNode (Lev2)
  include Lev3

  let get = get

  let of_map def m = untag (Lev3.of_map 0 def m)
end

module ArrayLeaf (H : Hashtbl.HashedType) = struct
  type elt = H.t
  type t = elt array
  type node = t
  let level = 0

  module NodeHash = struct
    type t = node tagged

    let equal x y =
      let a = untag x in
      let b = untag y in
      let rec loop i =
	if i >= 255 then true else
	if H.equal a.(i) b.(i) then loop (i + 1) else
	false in
      loop 0

    let hash = id
  end

  module Pool = Weak.Make (NodeHash)

  let pool = Pool.create 256

  let crc_hash v =
    let rec loop i sum =
      if i < 0 then sum else
      let a = H.hash v.(i) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte3 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte2 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte1 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte0 a) land 0x7f) in
      loop (i - 1) sum in
    loop 255 0

  let hashcons a =
    let n = crc_hash a in
    let x = Tag (a, n) in
    try Pool.find pool x with Not_found -> 
      Pool.add pool x;
      x

  let make_raw def = Array.make 256 def
  let make def = hashcons (make_raw def)

  let of_map n0 def m =
    let a = make_raw def in
    IMap.iter_range (fun n1 n2 v ->
(*       Printf.eprintf "Tl31.ArrayLeaf.of_map : %x %x - %x: %s\n" n0 n1 n2 *)
(* 	(String.escaped (Obj.magic v)); *)
      for i = n1 - n0 to n2 - n0 do a.(i) <- v done)
      m;
    hashcons a

  let of_set n0 def s v =
    let a = make_raw def in
    ISet.iter_range (fun n1 n2 ->
      for i = n1 - n0 to n2 - n0 do a.(i) <- v done)
      s;
    hashcons a
end

module type Type = sig
  type elt
  type t = elt tbl
  val get : elt tbl -> int -> elt
  val of_map : elt -> elt IMap.t -> elt tbl
end

module Make (H : Hashtbl.HashedType) = MakeTbl(ArrayLeaf(H))

module StringContentsHash = struct
  type t = string tagged

  let equal x1 x2 =
    let s1 = untag x1 in
    let s2 = untag x2 in
    if String.length s1 <> String.length s2 then false else
    let rec loop i =
      if i < 0 then true else
      if s1.[i] <> s2.[i] then false else
      loop (i - 1) in
    loop (String.length s1 - 1)

  let hash = id

end

let string_hash v =
  let rec loop i sum =
    if i < 0 then sum else
    let a = Char.code v.[i] in
    let sum = sum lsr 7 lxor crc_tbl.(sum lxor a land 0x7f) in
    loop (i - 1) sum in
  loop (String.length v - 5) 0

module BoolLeaf = struct
  type elt = bool
  type t = string
  let level = 0

  module Pool = Weak.Make (StringContentsHash)
  let pool = Pool.create 256

  let hashcons s = 
    let n = string_hash s in
    let x = Tag (s, n) in
    try Pool.find pool x with Not_found -> 
      Pool.add pool x;
      x

  let make_raw def = String.make 32 (if def then '\255' else '\000')

  let make def = hashcons (make_raw def)

  let boolget s k =
    let i = Char.code (String.unsafe_get s (k / 8)) in
    i lsr (k mod 8) land 1 <> 0

  let boolset s k b =
    let j = Char.code s.[k / 8] in
    let j' = if b then j lor (1 lsl (k mod 8)) else j in 
    s.[k / 8] <- Char.chr j'

  let of_map n0 def m =
    let a = make_raw def in
    IMap.iter_range (fun n1 n2 v ->
      for i = n1 - n0 to n2 - n0 do boolset a i v done)
      m;
    hashcons a

  let of_set n0 def s v =
    let a = make_raw def in
    ISet.iter_range (fun n1 n2 ->
      for i = n1 - n0 to n2 - n0 do boolset a i v done)
      s;
    hashcons a
end

module Bool = struct
  module BoolTbl = MakeTbl (BoolLeaf)
  include BoolTbl

  let of_set s = untag (BoolTbl.of_set 0 false s true)

  let get tbl n =
    let lev = Array.unsafe_get tbl (byte3 n) in
    let lev = Array.unsafe_get lev (byte2 n) in
    let lev = Array.unsafe_get lev (byte1 n) in
    let k = byte0 n in
    let i = Char.code (String.unsafe_get lev (k / 8)) in
    i lsr (k mod 8) land 1 <> 0
end

module CharLeaf = struct
  type elt = char
  type t = string
  let level = 0

  module Pool = Weak.Make (StringContentsHash)
  let pool = Pool.create 256

  let hashcons s = 
    let n = string_hash s in
    let x = Tag (s, n) in
    try Pool.find pool x with Not_found -> 
      Pool.add pool x;
      x

  let make_raw c = String.make 256 c
  let make c = hashcons (make_raw c)

  let of_map n0 def m =
    let a = make_raw def in
    IMap.iter_range (fun n1 n2 v ->
      for i = n1 - n0 to n2 - n0 do a.[i] <- v done)
      m;
    hashcons a

  let of_set n0 def s v =
    let a = make_raw def in
    ISet.iter_range (fun n1 n2 ->
      for i = n1 - n0 to n2 - n0 do a.[i] <- v done)
      s;
    hashcons a
end

module Char = struct
  module CharTbl = MakeTbl (CharLeaf)
  include CharTbl

  let get tbl n =
    let lev = Array.unsafe_get tbl (byte3 n) in
    let lev = Array.unsafe_get lev (byte2 n) in
    let lev = Array.unsafe_get lev (byte1 n) in
    String.unsafe_get lev (byte0 n)
end

module BitsContentsHash = struct
  type t = Bitsvect.t tagged

  let equal x1 x2 = 
    let a1 = untag x1 in
    let a2 = untag x2 in
    let rec loop i =
      if i < 0 then true else
      if Bitsvect.get a1 i = Bitsvect.get a2 i then loop (i - 1) else false in
    loop 255

  let hash = id 
end

module BitsLeaf = struct
  type elt = int
  type t = Bitsvect.t
  let level = 0

  module Pool = Weak.Make (BitsContentsHash)
  let pool = Pool.create 256

  let hash v =
    let rec loop i sum =
      if i < 0 then sum else
      let a = Bitsvect.get v i in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor a land 0x7f) in
      loop (i - 1) sum in
    loop (Bitsvect.length v - 5) 0

  let hashcons a = 
    let n = hash a in
    let x = Tag (a, n) in
    try Pool.find pool x with Not_found -> 
      Pool.add pool x;
      x

  let make_raw = Bitsvect.make 256
  let make def = hashcons (make_raw def)

  let of_map n0 def m =
    let a = make_raw def in
    IMap.iter_range (fun n1 n2 v ->
      for i = n1 - n0 to n2 - n0 do Bitsvect.set a i v done)
      m;
    hashcons a

  let of_set n0 def s v =
    let a = make_raw def in
    ISet.iter_range (fun n1 n2 ->
      for i = n1 - n0 to n2 - n0 do Bitsvect.set a i v done)
      s;
    hashcons a
end

module Bits = struct
  include MakeTbl (BitsLeaf)
  let get tbl n =
    let lev = Array.unsafe_get tbl (byte3 n) in
    let lev = Array.unsafe_get lev (byte2 n) in
    let lev = Array.unsafe_get lev (byte1 n) in
    Bitsvect.unsafe_get lev (byte0 n)
end

module BytesContentsHash = struct
  type t = Bytesvect.t tagged

  let equal x1 x2 = 
    let a1 = untag x1 in
    let a2 = untag x2 in
    let rec loop i =
      if i < 0 then true else
      if Bytesvect.get a1 i = Bytesvect.get a2 i then 
	loop (i - 1) 
      else false in
    loop 255

  let hash = id
end

module BytesLeaf = struct
  type elt = int
  type t = Bytesvect.t
  let level = 0

  module Pool = Weak.Make (BytesContentsHash)
  let pool = Pool.create 256

  let hash v =
    let rec loop i sum =
      if i < 0 then sum else
      let a = Bytesvect.get v i in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte3 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte2 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte1 a) land 0x7f) in
      let sum = sum lsr 7 lxor crc_tbl.(sum lxor (byte0 a) land 0x7f) in
      loop (i - 1) sum in
    loop 255 0

  let hashcons a = 
    let n = hash a in
    let x = Tag (a, n) in
    try Pool.find pool x with Not_found -> 
      Pool.add pool x;
      x

  let make_raw = Bytesvect.make 256
  let make def = hashcons (make_raw def)

  let of_map n0 def m =
    let a = make_raw def in
    IMap.iter_range (fun n1 n2 v ->
      for i = n1 - n0 to n2 - n0 do Bytesvect.set a i v done)
      m;
    hashcons a

  let of_set n0 def s v =
    let a = make_raw def in
    ISet.iter_range (fun n1 n2 ->
      for i = n1 - n0 to n2 - n0 do Bytesvect.set a i v done)
      s;
    hashcons a
end

module Bytes = struct
  include MakeTbl (BytesLeaf)
  let get tbl n =
    let lev = Array.unsafe_get tbl (byte3 n) in
    let lev = Array.unsafe_get lev (byte2 n) in
    let lev = Array.unsafe_get lev (byte1 n) in
    Bytesvect.unsafe_get lev (byte0 n)
end