src/nodeSet.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "utils.ml"
   3
   4 module type S =
   5   sig
   6     type t
   7     type elt = Tree.node
   8     val empty : t
   9     val singleton : elt -> t
  10     val cons : elt -> t -> t
  11     val snoc : t -> elt -> t
  12     val concat : t -> t -> t
  13     val concat3 : t -> t -> t -> t
  14     val concat4 : t -> t -> t -> t -> t
  15     val conscat : elt -> t -> t -> t
  16     val conscat3 : elt -> t -> t -> t -> t
  17     val conscat4 : elt -> t -> t -> t -> t -> t
  18     val subtree_tags : Tree.t -> elt -> Tag.t -> t
  19     val subtree_elements : Tree.t -> elt -> t
  20     val iter : ( elt -> unit) -> t -> unit
  21     val fold : ( elt -> 'a -> 'a) -> t -> 'a -> 'a
  22     val length : t -> int
  23     val serialize : string -> Tree.t -> t -> unit
  24   end
  25
  26 module Count : S with type t = int =
  27   struct
  28     type t = int
  29     type elt = Tree.node
  30
  31     let empty = 0
  32     let singleton _ = 1
  33     let cons _ x = x+1
  34     let snoc x _ = x+1
  35     let concat x y = x + y
  36     let concat3 x y z = x + y + z
  37     let concat4 x y z t = x + y + z + t
  38     let conscat _ x y = 1 + x + y
  39     let conscat3 _ x y z = 1 + x + y + z
  40     let conscat4 _ x y z t = 1 + x + y + z + t
  41     let subtree_tags tree node tag = Tree.subtree_tags tree node tag
  42     let subtree_elements tree node = Tree.subtree_elements tree node
  43     let iter _ _ = failwith "iter not implemented"
  44     let fold _ _ _ = failwith "fold not implemented"
  45     let map _ _ = failwith "map not implemented"
  46     let length x = x
  47     let serialize _ _ _ = ()
  48   end
  49
  50 type  clist =
  51   | Nil
  52   | Cons of Tree.node * clist
  53   | Concat of clist * clist
  54   | ConsCat of Tree.node * clist * clist
  55   | SubtreeTags of Tree.t * Tree.node * Tag.t
  56   | SubtreeElts of Tree.t * Tree.node
  57
  58
  59 type 'a mat = { mutable clist : clist;
  60                 mutable length : int }
  61
  62 module Mat : S with type t = Tree.node mat =
  63   struct
  64     type t = Tree.node mat
  65     type elt = Tree.node
  66
  67     let empty = { clist = Nil; length = 0 }
  68     let singleton e = { clist = Cons(e, Nil) ; length = 1 }
  69     let cons e l = { clist = Cons(e, l.clist); length = l.length + 1 }
  70     let concat l1 l2 =
  71       let ll1 = l1.length in
  72       if ll1 == 0 then l2 else
  73         let ll2 = l2.length in if ll2 == 0 then l1 else
  74             { clist = Concat(l1.clist, l2.clist); length = ll1 + ll2 }
  75
  76     let snoc l e = concat l (singleton e)
  77 (*
  78     let _total = ref 0
  79     let _empty = ref 0
  80     let () = at_exit (fun () -> Printf.eprintf "Dummy concatenations: %i/%i\n%!" !_empty !_total)
  81
  82     let concat l1 l2 =
  83       let l = concat l1 l2 in
  84       if l.length == 0 then incr _empty;
  85       incr _total;
  86       l
  87 *)
  88     let concat3 l1 l2 l3 = concat l1 (concat l2 l3)
  89     let concat4 l1 l2 l3 l4 = concat (concat l1 l2) (concat l3 l4)
  90
  91
  92     let conscat e l1 l2 =
  93       let ll1 = l1.length in
  94       if ll1 == 0 then cons e l2 else
  95         let ll2 = l2.length in if ll2 == 0 then cons e l1 else
  96             { clist = ConsCat(e, l1.clist, l2.clist); length = 1 + ll1 + ll2 }
  97
  98 (*    let conscat e l1 l2 = cons e (concat l1 l2) *)
  99
 100     let conscat3 e l1 l2 l3 = conscat e l1 (concat l2 l3)
 101     let conscat4 e l1 l2 l3 l4 = conscat e l1 (concat l2 (concat l3 l4))
 102
 103     let subtree_tags tree node tag =
 104       { clist = SubtreeTags(tree, node, tag);
 105         length = Tree.subtree_tags tree node tag }
 106     let subtree_elements tree node =
 107       { clist = SubtreeElts(tree, node);
 108         length = Tree.subtree_elements tree node }
 109
 110     let fst_tagged tree t tag =
 111       if Tree.tag tree t == tag then t
 112       else Tree.tagged_descendant tree t tag
 113
 114     let fst_element tree t =
 115       let tag = Tree.tag tree t in
 116       let t = if Ptset.Int.mem tag
 117           (Ptset.Int.remove Tag.document_node (Tree.element_tags tree))
 118         then t
 119         else Tree.first_element tree t
 120       in Tree.first_element tree t
 121
 122     let element_fold f tree t acc =
 123       let rec loop node acc =
 124         if node == Tree.nil then acc
 125         else
 126           let acc = f node acc in
 127           let acc' = loop (Tree.first_element tree node) acc in
 128             loop (Tree.next_element tree node) acc'
 129       in
 130         loop (fst_element tree t) acc
 131
 132     let element_iter f tree t =
 133       let rec loop node =
 134         if node != Tree.nil then begin
 135           f node;
 136           loop (Tree.first_element tree node);
 137           loop (Tree.next_element tree node)
 138         end
 139       in
 140       let t' = fst_element tree t in loop t'
 141
 142     let tag_fold f tree t tag acc =
 143       let rec loop close node acc =
 144         if node == Tree.nil then acc
 145         else
 146           let acc = f node acc in
 147           let acc' = loop close (Tree.tagged_descendant tree node tag) acc in
 148             loop close (Tree.tagged_following_before tree node tag close) acc'
 149       in
 150       let t = fst_tagged tree t tag in
 151         loop (Tree.closing tree t) t acc
 152
 153     let tag_iter f tree t tag =
 154       let rec loop close node =
 155         if node != Tree.nil then begin
 156           f node;
 157           loop close (Tree.tagged_descendant tree node tag);
 158           loop close (Tree.tagged_following_before tree node tag close);
 159         end
 160       in
 161       let t' = fst_tagged tree t tag in
 162         loop (Tree.closing tree t) t'
 163
 164     let fold f l acc =
 165       let rec loop l acc =
 166         match l with
 167           | Nil -> acc
 168           | Cons(e, ll) -> loop ll (f e acc)
 169           | Concat(l1, l2) -> loop l2 (loop l1 acc)
 170           | ConsCat(e, l1, l2) -> loop l2 (loop l1 (f e acc))
 171           | SubtreeTags(tree, t, tag) -> tag_fold f tree t tag acc
 172           | SubtreeElts(tree, t) -> element_fold f tree t acc
 173       in
 174         loop l.clist acc
 175
 176     let iter f l =
 177       let rec loop l =
 178         match l with
 179           | Nil -> ()
 180           | Cons(e, l) -> f e; loop l
 181           | Concat(l1, l2) -> loop l1; loop l2
 182           | ConsCat(e, l1, l2) -> f e; loop l1; loop l2
 183           | SubtreeTags(tree, t, tag) -> tag_iter f tree t tag
 184           | SubtreeElts(tree, t) ->
 185               element_iter f tree t
 186       in
 187         loop l.clist
 188
 189     let length l = l.length
 190
 191     let serialize name v l =
 192       let fd, finish =
 193         if name = "-" then Unix.stdout, ignore
 194         else
 195           Unix.openfile name [ Unix.O_WRONLY; Unix.O_TRUNC; Unix.O_CREAT ] 0o666,
 196           Unix.close
 197       in
 198       iter (fun node -> Tree.print_xml v node fd) l;
 199       Tree.flush v fd;
 200       finish fd
 201
 202   end
 203 let rec debug_clist =
 204   function
 205       Nil -> Printf.eprintf "Nil"
 206     | Cons(e, clist) ->
 207         Printf.eprintf "Cons(%i," (Obj.magic e);
 208         debug_clist clist;
 209         Printf.eprintf ")";
 210     | Concat(clist1, clist2) ->
 211             Printf.eprintf "Concat(";
 212         debug_clist clist1;
 213         Printf.eprintf ",";
 214             debug_clist clist2;
 215             Printf.eprintf ")";
 216     | ConsCat(_, clist1, clist2) ->
 217             Printf.eprintf "Concat(";
 218         debug_clist clist1;
 219         Printf.eprintf ",";
 220             debug_clist clist2;
 221             Printf.eprintf ")";
 222
 223     | SubtreeTags(tree, node, tag) ->
 224         Printf.eprintf "SubtreeTags(tree, %i, %s)"
 225           (Obj.magic node)
 226           (Tag.to_string tag);
 227     | SubtreeElts(tree, node) ->
 228         Printf.eprintf "SubtreeElts(tree, %i)"
 229           (Obj.magic node)
 230
 231 let debug l = debug_clist l.clist