hlist.ml

   1 INCLUDE "utils.ml"
   2 module type S = sig
   3   type elt
   4   type 'a node = Nil | Cons of elt * 'a
   5   type t
   6   val hash : t -> int
   7   val uid : t -> int
   8   val equal : t -> t -> bool
   9   val nil : t
  10   val node : t -> t node
  11   val cons : elt -> t -> t
  12   val hd : t -> elt
  13   val tl : t -> t
  14   val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
  15   val map : (elt -> elt) -> t -> t
  16   val iter : (elt -> 'a) -> t -> unit
  17   val rev : t -> t
  18   val rev_map : (elt -> elt) -> t -> t
  19 end
  20
  21 module Make ( H : Hcons.S ) : S with type elt = H.t =
  22 struct
  23   type elt = H.t
  24   type 'a node = Nil | Cons of elt * 'a
  25   module rec HNode : Hcons.S with type data = Node.t = Hcons.Make (Node)
  26   and Node : Hashtbl.HashedType  with type t = HNode.t node =
  27   struct
  28     type t =  HNode.t node
  29     let equal x y =
  30       match x,y with
  31         | Nil,Nil -> true
  32         | Cons (a,aa), Cons(b,bb) -> (H.equal a b) && (HNode.equal aa bb)
  33         | _ -> false
  34     let hash = function
  35       | Nil -> 0
  36       | Cons(a,aa) -> HASHINT3(PRIME3,H.uid a, HNode.uid aa)
  37   end
  38  ;;
  39
  40   type t = HNode.t
  41   let node = HNode.node
  42   let hash = HNode.hash
  43   let equal = HNode.equal
  44   let uid = HNode.uid
  45   let nil = HNode.make Nil
  46   let cons a b = HNode.make (Cons(a,b))
  47   let hd a =
  48     match HNode.node a with
  49       | Nil -> failwith "hd"
  50       | Cons(a,_) -> a
  51
  52   let tl a =
  53     match HNode.node a with
  54       | Nil -> failwith "tl"
  55       | Cons(_,a) -> a
  56
  57
  58   let fold f l acc =
  59     let rec loop acc l = match HNode.node l with
  60       | Nil -> acc
  61       | Cons(a,aa) -> loop (f a acc) aa
  62     in
  63       loop acc l
  64
  65   let map f l  =
  66     let rec loop l = match HNode.node l with
  67       | Nil -> nil
  68       | Cons(a,aa) -> cons (f a) (loop aa)
  69     in
  70       loop l
  71
  72   let iter f l =
  73     let rec loop l = match HNode.node l with
  74       | Nil -> ()
  75       | Cons(a,aa) ->  (f a);(loop aa)
  76     in
  77       loop l
  78
  79   let rev l = fold cons l nil
  80   let rev_map f l = fold (fun x acc -> cons (f x) acc) l nil
  81
  82 end