src/nodeSet.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "utils.ml"
   3
   4
   5 module type S =
   6   sig
   7     type t
   8     type elt = Tree.node
   9     val empty : t
  10     val var : (int*State.t) -> t
  11     val close : ((int*State.t), t) Hashtbl.t -> t -> t
  12     val is_open : t -> bool
  13     val singleton : elt -> t
  14     val cons : elt -> t -> t
  15     val snoc : t -> elt -> t
  16     val concat : t -> t -> t
  17     val concat3 : t -> t -> t -> t
  18     val concat4 : t -> t -> t -> t -> t
  19     val conscat : elt -> t -> t -> t
  20     val conscat3 : elt -> t -> t -> t -> t
  21     val conscat4 : elt -> t -> t -> t -> t -> t
  22     val subtree_tags : Tree.t -> elt -> Tag.t -> t
  23     val subtree_elements : Tree.t -> elt -> t
  24     val iter : ( elt -> unit) -> t -> unit
  25     val fold : ( elt -> 'a -> 'a) -> t -> 'a -> 'a
  26     val length : t -> int
  27     val serialize : string -> Tree.t -> t -> unit
  28
  29   end
  30
  31 module Count : S with type t = int =
  32   struct
  33     type t = int
  34     type elt = Tree.node
  35
  36     let empty = 0
  37     let var _ = empty
  38     let is_open _ = false
  39     let close _ x = x
  40     let singleton _ = 1
  41     let cons _ x = x+1
  42     let snoc x _ = x+1
  43     let concat x y = x + y
  44     let concat3 x y z = x + y + z
  45     let concat4 x y z t = x + y + z + t
  46     let conscat _ x y = 1 + x + y
  47     let conscat3 _ x y z = 1 + x + y + z
  48     let conscat4 _ x y z t = 1 + x + y + z + t
  49     let subtree_tags tree node tag = Tree.subtree_tags tree node tag
  50     let subtree_elements tree node = Tree.subtree_elements tree node
  51     let iter _ _ = failwith "iter not implemented"
  52     let fold _ _ _ = failwith "fold not implemented"
  53     let map _ _ = failwith "map not implemented"
  54     let length x = x
  55     let serialize f _ x =
  56       let o = open_out f in
  57       output_string o "<xml_result>\n";
  58       output_string o (string_of_int x);
  59       output_string o "\n</xml_result>\n";
  60       close_out o
  61   end
  62
  63 type  clist =
  64   | Nil
  65   | Cons of Tree.node * clist
  66   | Concat of clist * clist
  67   | ConsCat of Tree.node * clist * clist
  68   | SubtreeTags of Tree.t * Tree.node * Tag.t
  69   | SubtreeElts of Tree.t * Tree.node
  70
  71
  72 type 'a mat = { mutable clist : clist;
  73                 mutable length : int }
  74
  75 module Mat : S with type t = Tree.node mat =
  76   struct
  77     type t = Tree.node mat
  78     type elt = Tree.node
  79     let is_open _ = false
  80     let empty = { clist = Nil; length = 0 }
  81     let singleton e = { clist = Cons(e, Nil) ; length = 1 }
  82     let cons e l = { clist = Cons(e, l.clist); length = l.length + 1 }
  83     let concat l1 l2 =
  84       let ll1 = l1.length in
  85       if ll1 == 0 then l2 else
  86         let ll2 = l2.length in if ll2 == 0 then l1 else
  87             { clist = Concat(l1.clist, l2.clist); length = ll1 + ll2 }
  88
  89     let snoc l e = concat l (singleton e)
  90     let concat3 l1 l2 l3 = concat l1 (concat l2 l3)
  91     let concat4 l1 l2 l3 l4 = concat (concat l1 l2) (concat l3 l4)
  92     let var _ = empty
  93     let close _ x = x
  94
  95
  96     let conscat e l1 l2 =
  97       let ll1 = l1.length in
  98       if ll1 == 0 then cons e l2 else
  99         let ll2 = l2.length in if ll2 == 0 then cons e l1 else
 100             { clist = ConsCat(e, l1.clist, l2.clist); length = 1 + ll1 + ll2 }
 101
 102 (*    let conscat e l1 l2 = cons e (concat l1 l2) *)
 103
 104     let conscat3 e l1 l2 l3 = conscat e l1 (concat l2 l3)
 105     let conscat4 e l1 l2 l3 l4 = conscat e l1 (concat l2 (concat l3 l4))
 106
 107     let subtree_tags tree node tag =
 108       let len = Tree.subtree_tags tree node tag in
 109       if len == 0 then empty
 110       else
 111         { clist = SubtreeTags(tree, node, tag);
 112           length = len }
 113
 114     let subtree_elements tree node =
 115       let len = Tree.subtree_elements tree node in
 116       if len == 0 then empty
 117       else
 118         { clist = SubtreeElts(tree, node);
 119           length = len }
 120
 121     let fst_tagged tree t tag =
 122       if Tree.tag tree t == tag then t
 123       else Tree.tagged_descendant tree t tag
 124
 125     let fst_element tree t =
 126       let tag = Tree.tag tree t in
 127       let t = if Ptset.Int.mem tag
 128           (Ptset.Int.remove Tag.document_node (Tree.element_tags tree))
 129         then t
 130         else Tree.first_element tree t
 131       in Tree.first_element tree t
 132
 133     let element_fold f tree t acc =
 134       let rec loop node acc =
 135         if node == Tree.nil then acc
 136         else
 137           let acc = f node acc in
 138           let acc' = loop (Tree.first_element tree node) acc in
 139             loop (Tree.next_element tree node) acc'
 140       in
 141         loop (fst_element tree t) acc
 142
 143     let element_iter f tree t =
 144       let rec loop node =
 145         if node != Tree.nil then begin
 146           f node;
 147           loop (Tree.first_element tree node);
 148           loop (Tree.next_element tree node)
 149         end
 150       in
 151       let t' = fst_element tree t in loop t'
 152
 153     let tag_fold f tree t tag acc =
 154       let rec loop close node acc =
 155         if node > Tree.nil && node < close then acc
 156         else
 157           let acc = f node acc in
 158           loop close (Tree.tagged_next tree node tag) acc
 159       in
 160       let t' = fst_tagged tree t tag in
 161         loop (Tree.closing tree t) t' acc
 162
 163     let tag_iter f tree t tag =
 164       let rec loop close node =
 165         if node > Tree.nil && node < close then begin
 166           f node;
 167           loop close (Tree.tagged_next tree node tag);
 168         end
 169       in
 170       let t' = fst_tagged tree t tag in
 171         loop (Tree.closing tree t) t'
 172
 173     let fold f l acc =
 174       let rec loop l acc =
 175         match l with
 176           | Nil -> acc
 177           | Cons(e, ll) -> loop ll (f e acc)
 178           | Concat(l1, l2) -> loop l2 (loop l1 acc)
 179           | ConsCat(e, l1, l2) -> loop l2 (loop l1 (f e acc))
 180           | SubtreeTags(tree, t, tag) -> tag_fold f tree t tag acc
 181           | SubtreeElts(tree, t) -> element_fold f tree t acc
 182       in
 183         loop l.clist acc
 184
 185     let iter f l =
 186       let rec loop l =
 187         match l with
 188           | Nil -> ()
 189           | Cons(e, l) -> f e; loop l
 190           | Concat(l1, l2) -> loop l1; loop l2
 191           | ConsCat(e, l1, l2) -> f e; loop l1; loop l2
 192           | SubtreeTags(tree, t, tag) -> tag_iter f tree t tag
 193           | SubtreeElts(tree, t) ->
 194               element_iter f tree t
 195       in
 196         loop l.clist
 197
 198     let length l = l.length
 199
 200     let serialize name v l =
 201       let fd, finish =
 202         if name = "-" then Unix.stdout, ignore
 203         else
 204           Unix.openfile name [ Unix.O_WRONLY; Unix.O_TRUNC; Unix.O_CREAT ] 0o666,
 205           Unix.close
 206       in
 207       ignore (Unix.write fd "<xml_result>\n" 0 13);
 208       if l.length > 0 then begin
 209         iter (fun node -> Tree.print_xml v node fd) l;
 210         Tree.flush v fd;
 211       end;
 212       ignore (Unix.write fd "</xml_result>\n" 0 14);
 213       finish fd
 214
 215   end
 216 let rec debug_clist =
 217   function
 218       Nil -> Printf.eprintf "Nil"
 219     | Cons(e, clist) ->
 220         Printf.eprintf "Cons(%i," (Obj.magic e);
 221         debug_clist clist;
 222         Printf.eprintf ")";
 223     | Concat(clist1, clist2) ->
 224             Printf.eprintf "Concat(";
 225         debug_clist clist1;
 226         Printf.eprintf ",";
 227             debug_clist clist2;
 228             Printf.eprintf ")";
 229     | ConsCat(_, clist1, clist2) ->
 230             Printf.eprintf "Concat(";
 231         debug_clist clist1;
 232         Printf.eprintf ",";
 233             debug_clist clist2;
 234             Printf.eprintf ")";
 235
 236     | SubtreeTags(tree, node, tag) ->
 237         Printf.eprintf "SubtreeTags(tree, %i, %s)"
 238           (Obj.magic node)
 239           (Tag.to_string tag);
 240     | SubtreeElts(tree, node) ->
 241         Printf.eprintf "SubtreeElts(tree, %i)"
 242           (Obj.magic node)
 243
 244 let debug l = debug_clist l.clist
 245
 246
 247
 248 module Partial(N : S) : S =
 249 struct
 250
 251   type elt = Tree.node
 252   type t = { env : ((int*State.t), t) Hashtbl.t;
 253              elem : list;
 254              opened : bool;
 255            }
 256   and list =
 257     | Var of (int * State.t)
 258     | Nil
 259     | Cons of elt * list
 260     | Concat of list * list
 261     | Lambda of t
 262
 263   let dummy = Hashtbl.create 0
 264   let empty = { env = dummy;
 265                 elem = Nil;
 266                 opened = false }
 267   let is_open t = t.opened
 268
 269
 270   let close h t =
 271     {empty with elem =
 272         Lambda { t with env = h; opened = false } }
 273
 274   let singleton i = { empty with elem = Cons(i, Nil) }
 275   let cons e t = { t with elem = Cons(e, t.elem) }
 276   let concat t1 t2 =
 277     { t1 with elem = Concat (t1.elem, t2.elem) }
 278
 279   let snoc t e = concat t (singleton e)
 280   let concat3 t1 t2 t3 = concat t1 (concat t2 t3)
 281   let concat4 t1 t2 t3 t4 = concat (concat t1 t2) (concat t3 t4)
 282   let conscat e t1 t2 = cons e (concat t1 t2)
 283   let conscat3 e t1 t2 t3 = cons e (concat3 t1 t2 t3)
 284   let conscat4 e t1 t2 t3 t4 = cons e (concat4 t1 t2 t3 t4)
 285   let subtree_tags _ = failwith "not implemented"
 286   let subtree_elements _ = failwith "not_implemented"
 287
 288   let iter f t =
 289     let rec loop t =
 290       loop_list t.env t.elem
 291     and loop_list h = function
 292       | Nil -> ()
 293       | Var i -> loop (Hashtbl.find h i)
 294       | Cons (e, l) -> f e; loop_list h l
 295       | Concat (l1, l2) -> loop_list h l1; loop_list h l2
 296       | Lambda t -> loop t
 297     in
 298     loop t
 299
 300   let fold f t acc =
 301     let rec loop t acc =
 302       loop_list t.env acc t.elem
 303     and loop_list h acc = function
 304       | Nil -> acc
 305       | Var i -> loop (try Hashtbl.find h i with Not_found -> let a,b = i in Printf.eprintf "%i,%i not found\n%!" a b; empty) acc
 306       | Cons (e, l) ->   loop_list h (f e acc) l
 307       | Concat (l1, l2) -> loop_list h (loop_list h acc l1) l2
 308       | Lambda t -> loop t acc
 309     in
 310     loop t acc
 311
 312
 313   let rec dump t =
 314     Hashtbl.iter (fun (i,j) t ->
 315       Format.eprintf "%i, %a ->" i State.print j;
 316       dump t;
 317       Format.eprintf "----------------\n%!";
 318     ) t.env;
 319     dump_list t.elem
 320   and dump_list  = function
 321     | Nil -> ()
 322     | Var (i,j) -> Format.eprintf "Var(%i, %a) " i State.print j;
 323     | Cons (e, l) -> Format.eprintf "%i " (Node.to_int e); dump_list l
 324     | Concat (l1, l2) -> dump_list l1 ; dump_list l2
 325     | Lambda t -> dump t
 326
 327
 328   let length t = fold (fun _ acc -> 1 + acc) t 0
 329
 330
 331   let var i =
 332     { empty with elem = Var i; opened = true }
 333
 334   let serialize _ = failwith "not implemented"
 335 end