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