~ubuntu-branches/ubuntu/precise/ocaml-batteries/precise

« back to all changes in this revision

Viewing changes to src/core/extlib/vect.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stefano Zacchiroli
  • Date: 2010-03-06 16:03:38 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20100306160338-spvwiv3uc4jr28hw
Tags: 1.1.0-1
* New upstream release
  - major changes, "diet" version of the library
  - fix old FTBFS error, due to major code changes (Closes: #569455)
* Revamp packaging
  - adapt to new stuff shipped by upstream
  - switch from CDBS to dh
  - adapt dependencies (generally: reduce them)
* debian/patches/
  - remove old debian/patches/{debian-specific-installation-paths,
    debian-specific-info-on-doc-availability} as obsolete
  - new patch 0001-install-fix-for-bytecode-only-build: avoid
    installing *.a files with bytecode only compilation
* debian/libbatteries-ocaml-dev.links: remove file, shortend
  /usr/bin/ocaml-batteries to the top-level no longer exists
* remove debian/README.Debian (previous content is now obsolete)
* bump Standards-Version to 3.8.4 (no changes needed)
* debian/watch: update to match new upstream version convention
* debian/libbatteries-ocaml-{dev,doc}.{docs,examples}: ship only doc
  file from the root dir, other stuff is currently out of date
  (Closes: #514265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
1
 
(* 
2
 
 * Vect - Extensible arrays based on ropes
3
 
 * Copyright (C) 2007 Mauricio Fernandez <mfp@acm.org>
4
 
 *               2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans
5
 
 * 
6
 
 * This library is free software; you can redistribute it and/or
7
 
 * modify it under the terms of the GNU Lesser General Public
8
 
 * License as published by the Free Software Foundation; either
9
 
 * version 2.1 of the License, or (at your option) any later version,
10
 
 * with the special exception on linking described in file LICENSE.
11
 
 *
12
 
 * This library is distributed in the hope that it will be useful,
13
 
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14
 
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15
 
 * Lesser General Public License for more details.
16
 
 *
17
 
 * You should have received a copy of the GNU Lesser General Public
18
 
 * License along with this library; if not, write to the Free Software
19
 
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
20
 
 *)
21
 
 
22
 
TYPE_CONV_PATH "" (*For Sexplib, Bin-prot...*)
23
 
 
24
 
open ExtArray
25
 
 
26
 
type 'a t =
27
 
    Empty
28
 
  | Concat of 'a t * int * 'a t * int * int
29
 
  | Leaf   of 'a array
30
 
 
31
 
type 'a forest_element = { mutable c : 'a t; mutable len : int }
32
 
 
33
 
let str_append = Array.append
34
 
let empty_str = [||]
35
 
let string_of_string_list = Array.concat
36
 
 
37
 
let singleton x = Leaf [|x|]
38
 
 
39
 
 
40
 
 
41
 
module STRING = ExtArray.Array
42
 
 
43
 
(* 48 limits max rope size to 236.10^9 elements on 64 bit,
44
 
 * ~ 734.10^6 on 32bit (length fields overflow after that) *)
45
 
let max_height = 48
46
 
 
47
 
(* actual size will be that plus 1 word header;
48
 
 * the code assumes it's an even num.
49
 
 * 32 gives up to 50% overhead in the worst case (all leaf nodes near
50
 
 * half-filled; 8 words for bookkeeping, 16 words worth of data per leaf node *)
51
 
let leaf_size = 16
52
 
 
53
 
 
54
 
 
55
 
exception Out_of_bounds
56
 
 
57
 
let empty = Empty
58
 
 
59
 
(* by construction, there cannot be Empty or Leaf "" leaves *)
60
 
let is_empty = function Empty -> true | _ -> false
61
 
 
62
 
let height = function
63
 
    Empty | Leaf _ -> 0
64
 
  | Concat(_,_,_,_,h) -> h
65
 
 
66
 
let rec length = function
67
 
    Empty -> 0
68
 
  | Leaf s -> STRING.length s
69
 
  | Concat(_,cl,_,cr,_) -> cl + cr
70
 
 
71
 
let make_concat l r =
72
 
  let hl = height l and hr = height r in
73
 
  let cl = length l and cr = length r in
74
 
    Concat(l, cl, r, cr, if hl >= hr then hl + 1 else hr + 1)
75
 
 
76
 
let min_len =
77
 
  let fib_tbl = Array.make max_height 0 in
78
 
  let rec fib n = match fib_tbl.(n) with
79
 
      0 ->
80
 
        let last = fib (n - 1) and prev = fib (n - 2) in
81
 
        let r = last + prev in
82
 
        let r = if r > last then r else last in (* check overflow *)
83
 
          fib_tbl.(n) <- r; r
84
 
    | n -> n
85
 
  in
86
 
    fib_tbl.(0) <- leaf_size + 1; fib_tbl.(1) <- 3 * leaf_size / 2 + 1;
87
 
    Array.init max_height (fun i -> if i = 0 then 1 else fib (i - 1))
88
 
 
89
 
let max_length = min_len.(Array.length min_len - 1)
90
 
 
91
 
let concat_fast l r = match l with
92
 
    Empty -> r
93
 
  | Leaf _ | Concat(_,_,_,_,_) ->
94
 
      match r with
95
 
          Empty -> l
96
 
        | Leaf _ | Concat(_,_,_,_,_) -> make_concat l r
97
 
 
98
 
(* based on Hans-J. Boehm's *)
99
 
let add_forest forest rope len =
100
 
  let i = ref 0 in
101
 
  let sum = ref empty in
102
 
    while len > min_len.(!i+1) do
103
 
      if forest.(!i).c <> Empty then begin
104
 
        sum := concat_fast forest.(!i).c !sum;
105
 
        forest.(!i).c <- Empty
106
 
      end;
107
 
      incr i
108
 
    done;
109
 
    sum := concat_fast !sum rope;
110
 
    let sum_len = ref (length !sum) in
111
 
      while !sum_len >= min_len.(!i) do
112
 
        if forest.(!i).c <> Empty then begin
113
 
          sum := concat_fast forest.(!i).c !sum;
114
 
          sum_len := !sum_len + forest.(!i).len;
115
 
          forest.(!i).c <- Empty;
116
 
        end;
117
 
        incr i
118
 
      done;
119
 
      decr i;
120
 
      forest.(!i).c <- !sum;
121
 
      forest.(!i).len <- !sum_len
122
 
 
123
 
let concat_forest forest =
124
 
  Array.fold_left (fun s x -> concat_fast x.c s) Empty forest
125
 
 
126
 
let rec balance_insert rope len forest = match rope with
127
 
    Empty -> ()
128
 
  | Leaf _ -> add_forest forest rope len
129
 
  | Concat(l,cl,r,cr,h) when h >= max_height || len < min_len.(h) ->
130
 
      balance_insert l cl forest;
131
 
      balance_insert r cr forest
132
 
  | x -> add_forest forest x len (* function or balanced *)
133
 
 
134
 
let balance r =
135
 
  match r with
136
 
      Empty -> Empty
137
 
    | Leaf _ -> r
138
 
    | _ ->
139
 
        let forest = Array.init max_height (fun _ -> {c = Empty; len = 0}) in
140
 
          balance_insert r (length r) forest;
141
 
          concat_forest forest
142
 
 
143
 
let bal_if_needed l r =
144
 
  let r = make_concat l r in
145
 
    if height r < max_height then r else balance r
146
 
 
147
 
let concat_str l = function
148
 
    Empty | Concat(_,_,_,_,_) -> invalid_arg "concat_str"
149
 
  | Leaf rs as r ->
150
 
      let lenr = STRING.length rs in
151
 
        match l with
152
 
          | Empty -> r
153
 
          | Leaf ls ->
154
 
              let slen = lenr + STRING.length ls in
155
 
                if slen <= leaf_size then Leaf (str_append ls rs)
156
 
                else make_concat l r (* height = 1 *)
157
 
          | Concat(ll, cll, Leaf lrs, clr, h) ->
158
 
              let slen = clr + lenr in
159
 
                if clr + lenr <= leaf_size then
160
 
                  Concat(ll, cll, Leaf (str_append lrs rs), slen, h)
161
 
                else
162
 
                  bal_if_needed l r
163
 
          | _ -> bal_if_needed l r
164
 
 
165
 
let append_char c r = concat_str r (Leaf (STRING.make 1 c))
166
 
 
167
 
let concat l = function
168
 
    Empty -> l
169
 
  | Leaf _ as r -> concat_str l r
170
 
  | Concat(Leaf rls,rlc,rr,rc,h) as r ->
171
 
      (match l with
172
 
          Empty -> r
173
 
        | Concat(_,_,_,_,_) -> bal_if_needed l r
174
 
        | Leaf ls ->
175
 
            let slen = rlc + STRING.length ls in
176
 
              if slen <= leaf_size then
177
 
                Concat(Leaf(str_append ls rls), slen, rr, rc, h)
178
 
              else
179
 
                bal_if_needed l r)
180
 
  | r -> (match l with Empty -> r | _ -> bal_if_needed l r)
181
 
 
182
 
let prepend_char c r = concat (Leaf (STRING.make 1 c)) r
183
 
 
184
 
let get v i = 
185
 
  let rec aux i = function
186
 
    Empty -> raise Out_of_bounds
187
 
  | Leaf s ->
188
 
      if i >= 0 && i < STRING.length s then STRING.unsafe_get s i
189
 
      else raise Out_of_bounds
190
 
  | Concat (l, cl, r, cr, _) ->
191
 
      if i < cl then aux i l
192
 
      else aux (i - cl) r
193
 
  in aux i v
194
 
 
195
 
let set (v:'a t) (i: int) (x:'a) = 
196
 
  let rec aux i = function
197
 
    Empty -> raise Out_of_bounds
198
 
  | Leaf s ->
199
 
      if i >= 0 && i < STRING.length s then
200
 
        let s = STRING.copy s in
201
 
          STRING.unsafe_set s i x;
202
 
          Leaf s
203
 
      else raise Out_of_bounds
204
 
  | Concat(l, cl, r, cr, _) ->
205
 
      if i < cl then concat (aux i l) r
206
 
      else concat l (aux (i - cl) r)
207
 
  in aux i v
208
 
 
209
 
let at = get
210
 
 
211
 
let of_string = function
212
 
    s when STRING.length s = 0 -> Empty
213
 
  | s ->
214
 
      let min (x:int) (y:int) = if x <= y then x else y in
215
 
      let rec loop r s len i =
216
 
        if i < len then (* len - i > 0, thus Leaf "" can't happen *)
217
 
          loop (concat r (Leaf (STRING.sub s i (min (len - i) leaf_size))))
218
 
            s len (i + leaf_size)
219
 
        else
220
 
          r
221
 
      in loop Empty s (STRING.length s) 0
222
 
 
223
 
let rec make len c =
224
 
  let rec concatloop len i r =
225
 
    if i <= len then
226
 
      concatloop len (i * 2) (concat r r)
227
 
    else r
228
 
  in
229
 
    if len = 0 then Empty
230
 
    else if len <= leaf_size then Leaf (STRING.make len c)
231
 
    else
232
 
      let rope = concatloop len 2 (of_string (STRING.make 1 c)) in
233
 
        concat rope (make (len - length rope) c)
234
 
 
235
 
let rec sub start len = function
236
 
    Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds else Empty
237
 
  | Leaf s ->
238
 
      if len > 0 then (* Leaf "" cannot happen *)
239
 
        (try Leaf (STRING.sub s start len) with _ -> raise Out_of_bounds)
240
 
      else if len < 0 || start < 0 || start > STRING.length s then
241
 
        raise Out_of_bounds
242
 
      else Empty
243
 
  | Concat(l,cl,r,cr,_) ->
244
 
      if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds;
245
 
      let left =
246
 
        if start = 0 then
247
 
          if len >= cl then
248
 
            l
249
 
          else sub 0 len l
250
 
        else if start > cl then Empty
251
 
        else if start + len >= cl then
252
 
          sub start (cl - start) l
253
 
        else sub start len l in
254
 
      let right =
255
 
        if start <= cl then
256
 
          let upto = start + len in
257
 
            if upto = cl + cr then r
258
 
            else if upto < cl then Empty
259
 
            else sub 0 (upto - cl) r
260
 
        else sub (start - cl) len r
261
 
      in
262
 
        concat left right
263
 
 
264
 
let insert start rope r =
265
 
  concat (concat (sub 0 start r) rope) (sub start (length r - start) r)
266
 
 
267
 
let remove start len r =
268
 
  concat (sub 0 start r) (sub (start + len) (length r - start - len) r)
269
 
 
270
 
let to_string r =
271
 
  let rec strings l = function
272
 
      Empty -> l
273
 
    | Leaf s -> s :: l
274
 
    | Concat(left,_,right,_,_) -> strings (strings l right) left
275
 
  in
276
 
    string_of_string_list (strings [] r)
277
 
 
278
 
let rec iter f = function
279
 
    Empty -> ()
280
 
  | Leaf s -> STRING.iter f s
281
 
  | Concat(l,_,r,_,_) -> iter f l; iter f r
282
 
 
283
 
let enum e =
284
 
  let rec aux = function
285
 
    | Empty                 -> Enum.empty ()
286
 
    | Leaf s                -> STRING.enum s
287
 
    | Concat(l, _, r, _, _) -> Enum.append (Enum.delay (fun () -> aux l))
288
 
                                           (Enum.delay (fun () -> aux r))
289
 
  in aux e
290
 
 
291
 
let backwards e =
292
 
  let rec aux = function
293
 
    | Empty                 -> Enum.empty ()
294
 
    | Leaf s                -> STRING.backwards s
295
 
    | Concat(l, _, r, _, _) -> Enum.append (Enum.delay (fun () -> aux r))
296
 
                                           (Enum.delay (fun () -> aux l))
297
 
  in aux e
298
 
 
299
 
let of_enum e =
300
 
  Enum.fold (fun acc x -> append_char x acc) empty e
301
 
 
302
 
let of_backwards e =
303
 
  Enum.fold (fun acc x -> prepend_char x acc) empty e
304
 
 
305
 
let iteri f r =
306
 
  let rec aux f i = function
307
 
    Empty -> ()
308
 
  | Leaf s ->
309
 
      for j = 0 to STRING.length s - 1 do
310
 
        f (i + j) (STRING.unsafe_get s j)
311
 
      done
312
 
  | Concat(l,cl,r,_,_) -> aux f i l; aux f (i + cl) r
313
 
  in
314
 
    aux f 0 r
315
 
 
316
 
let rec rangeiter f start len = function
317
 
    Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds
318
 
  | Leaf s ->
319
 
      let n = start + len in
320
 
      let lens = STRING.length s in
321
 
      if start >= 0 && len >= 0 && n <= lens then
322
 
        for i = start to n - 1 do
323
 
          f (STRING.unsafe_get s i)
324
 
        done
325
 
      else raise Out_of_bounds
326
 
  | Concat(l,cl,r,cr,_) ->
327
 
      if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds;
328
 
      if start < cl then begin
329
 
        let upto = start + len in
330
 
          if upto <= cl then
331
 
            rangeiter f start len l
332
 
          else begin
333
 
            rangeiter f start (cl - start) l;
334
 
            rangeiter f 0 (upto - cl) r
335
 
          end
336
 
      end else begin
337
 
        rangeiter f (start - cl) len r
338
 
      end
339
 
 
340
 
let rec fold f a = function
341
 
    Empty -> a
342
 
  | Leaf s ->
343
 
      let acc = ref a in
344
 
        for i = 0 to STRING.length s - 1 do
345
 
          acc := f !acc (STRING.unsafe_get s i)
346
 
        done;
347
 
        !acc
348
 
  | Concat(l,_,r,_,_) -> fold f (fold f a l) r
349
 
 
350
 
let fold_left = fold
351
 
let fold_right (f:'a -> 'b -> 'b) (v:'a t) (acc:'b)  : 'b =
352
 
  let rec aux (acc:'b) = function
353
 
    | Empty  -> acc
354
 
    | Leaf s -> STRING.fold_right f s acc
355
 
    | Concat(l, _, r, _, _) -> aux (aux acc r) l
356
 
  in aux acc v
357
 
 
358
 
let of_array = of_string
359
 
let to_array = to_string
360
 
let append = append_char
361
 
let prepend = prepend_char
362
 
 
363
 
let sexp_of_t sexp_of_a t =
364
 
  Sexplib.Conv.sexp_of_array sexp_of_a (to_array t)
365
 
let t_of_sexp a_of_sexp s =
366
 
  of_array (Sexplib.Conv.array_of_sexp a_of_sexp s)
367
 
 
368
 
 
369
 
let rec map f = function
370
 
    Empty -> Empty
371
 
  | Leaf a -> Leaf (Array.map f a)
372
 
  | Concat(l,cl,r,cr,h) -> Concat(map f l, cl, map f r, cr, h)
373
 
 
374
 
let mapi f v =
375
 
  let off = ref 0 in
376
 
    map (fun x -> f (Ref.post_incr off) x) v
377
 
 
378
 
let exists f v =
379
 
  Return.label (fun label ->
380
 
  let rec aux = function
381
 
    | Empty                  -> ()
382
 
    | Leaf a                 -> if Array.exists f a then Return.return label true else ()
383
 
    | Concat (l, _, r, _, _) -> aux l; aux r
384
 
  in aux v; false)
385
 
 
386
 
let for_all f v = 
387
 
  Return.label (fun label ->
388
 
  let rec aux = function
389
 
    | Empty                  -> ()
390
 
    | Leaf a                 -> if not (Array.for_all f a) then Return.return label false else ()
391
 
    | Concat (l, _, r, _, _) -> aux l; aux r
392
 
  in aux v; true)
393
 
 
394
 
let find f v =
395
 
  Return.label (fun label ->
396
 
  let rec aux = function
397
 
    | Empty  -> ()
398
 
    | Leaf a -> (try Return.return label (Array.find f a) with Not_found -> ())
399
 
    | Concat (l, _, r, _, _) -> aux l; aux r
400
 
  in aux v; raise Not_found)
401
 
 
402
 
let findi f v = (*We rely on the order of exploration of the tree by [find]*)
403
 
  let off = ref 0 in
404
 
  let _   = find (fun x -> let result = f x in incr off; result) v in
405
 
    !off
406
 
 
407
 
let partition p v =
408
 
  fold_left (fun (yes, no) x -> if p x then (append x yes,no) else (yes,append x no)) (empty,empty) v
409
 
 
410
 
let find_all p v =
411
 
  fold_left (fun acc x -> if p x then append x acc else acc) empty v
412
 
 
413
 
let mem m v = try let _ = find ( ( = ) m ) v in true with Not_found -> false
414
 
 
415
 
let memq m v = try let _ = find ( ( == ) m ) v in true with Not_found -> false
416
 
 
417
 
 
418
 
 
419
 
let to_list r =
420
 
  let rec aux acc = function
421
 
      Empty -> acc
422
 
    | Leaf a -> Array.fold_right (fun x l -> x :: l) a acc
423
 
    | Concat(l,_,r,_,_) -> aux (aux acc r) l
424
 
  in
425
 
    aux [] r
426
 
 
427
 
let filter f =
428
 
  fold (fun s x -> if f x then append x s else s) Empty
429
 
 
430
 
let filter_map f =
431
 
  fold (fun acc x -> match f x with
432
 
          | None   -> acc
433
 
          | Some v -> append v acc) Empty
434
 
 
435
 
let destructive_set v i x = 
436
 
  let rec aux i = function
437
 
    Empty  -> raise Out_of_bounds
438
 
  | Leaf s ->
439
 
      if i >= 0 && i < STRING.length s then
440
 
        STRING.unsafe_set s i x
441
 
      else raise Out_of_bounds
442
 
  | Concat(l, cl, r, cr, _) ->
443
 
      if i < cl then aux i l
444
 
      else aux (i - cl) r
445
 
  in aux i v
446
 
 
447
 
let of_list l = of_array (Array.of_list l)
448
 
 
449
 
let init n f =
450
 
  if n < 0 || n > max_length then raise (Invalid_argument "Vect.init")
451
 
  else
452
 
  (*Create as many arrays as we need to store all the data*)
453
 
  let rec aux off acc =
454
 
    if off >= n then acc
455
 
    else 
456
 
      let len = min leaf_size (n - off) in
457
 
      let arr = Array.init len (fun i -> f ( off + i ) ) in
458
 
      aux (off + len) (arr::acc)
459
 
  in 
460
 
  let base = aux 0 []
461
 
  in(*And then concatenate them*)
462
 
    List.fold_left (fun (acc:'a t) (array:'a array) -> concat (of_array array) acc) (empty:'a t) (base:'a array list)
463
 
 
464
 
let print ?(first="[|") ?(last="|]") ?(sep="; ") print_a out t =
465
 
  Enum.print ~first ~last ~sep print_a out (enum t)
466
 
 
467
 
(* Functorial interface *)
468
 
 
469
 
module type RANDOMACCESS =
470
 
sig
471
 
  type 'a t
472
 
  val empty : 'a t
473
 
  val get : 'a t -> int -> 'a
474
 
  val unsafe_get : 'a t -> int -> 'a
475
 
  val set : 'a t -> int -> 'a -> unit
476
 
  val unsafe_set : 'a t -> int -> 'a -> unit
477
 
  val append : 'a t -> 'a t -> 'a t
478
 
  val concat : 'a t list -> 'a t
479
 
  val length : 'a t -> int
480
 
  val copy : 'a t -> 'a t
481
 
  val sub : 'a t -> int -> int -> 'a t
482
 
  val make : int -> 'a -> 'a t
483
 
  val iter : ('a -> unit) -> 'a t -> unit
484
 
  val map : ('a -> 'b) -> 'a t -> 'b t
485
 
  val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
486
 
  val enum : 'a t -> 'a Enum.t
487
 
  val backwards : 'a t -> 'a Enum.t
488
 
  val of_enum : 'a Enum.t -> 'a t
489
 
  val of_backwards : 'a Enum.t -> 'a t
490
 
end
491
 
 
492
 
module Make(RANDOMACCESS : RANDOMACCESS)
493
 
           (PARAM : sig
494
 
               val max_height : int
495
 
               val leaf_size : int
496
 
            end)=
497
 
struct
498
 
  type 'a t =
499
 
      Empty
500
 
    | Concat of 'a t * int * 'a t * int * int
501
 
    | Leaf of 'a RANDOMACCESS.t
502
 
 
503
 
  type 'a forest_element = { mutable c : 'a t; mutable len : int }
504
 
 
505
 
  let str_append = RANDOMACCESS.append
506
 
  let empty_str = RANDOMACCESS.empty
507
 
  let string_of_string_list = RANDOMACCESS.concat
508
 
 
509
 
  let singleton x = Leaf (RANDOMACCESS.make 1 x)
510
 
 
511
 
  module STRING = RANDOMACCESS
512
 
 
513
 
  let max_height = PARAM.max_height
514
 
  let leaf_size = PARAM.leaf_size
515
 
 
516
 
  
517
 
  
518
 
  exception Out_of_bounds
519
 
  
520
 
  let empty = Empty
521
 
  
522
 
  (* by construction, there cannot be Empty or Leaf "" leaves *)
523
 
  let is_empty = function Empty -> true | _ -> false
524
 
  
525
 
  let height = function
526
 
      Empty | Leaf _ -> 0
527
 
    | Concat(_,_,_,_,h) -> h
528
 
  
529
 
  let rec length = function
530
 
      Empty -> 0
531
 
    | Leaf s -> STRING.length s
532
 
    | Concat(_,cl,_,cr,_) -> cl + cr
533
 
  
534
 
  let make_concat l r =
535
 
    let hl = height l and hr = height r in
536
 
    let cl = length l and cr = length r in
537
 
      Concat(l, cl, r, cr, if hl >= hr then hl + 1 else hr + 1)
538
 
  
539
 
  let min_len =
540
 
    let fib_tbl = Array.make max_height 0 in
541
 
    let rec fib n = match fib_tbl.(n) with
542
 
        0 ->
543
 
          let last = fib (n - 1) and prev = fib (n - 2) in
544
 
          let r = last + prev in
545
 
          let r = if r > last then r else last in (* check overflow *)
546
 
            fib_tbl.(n) <- r; r
547
 
      | n -> n
548
 
    in
549
 
      fib_tbl.(0) <- leaf_size + 1; fib_tbl.(1) <- 3 * leaf_size / 2 + 1;
550
 
      Array.init max_height (fun i -> if i = 0 then 1 else fib (i - 1))
551
 
  
552
 
  let max_length = min_len.(Array.length min_len - 1)
553
 
  
554
 
  let concat_fast l r = match l with
555
 
      Empty -> r
556
 
    | Leaf _ | Concat(_,_,_,_,_) ->
557
 
        match r with
558
 
            Empty -> l
559
 
          | Leaf _ | Concat(_,_,_,_,_) -> make_concat l r
560
 
  
561
 
  (* based on Hans-J. Boehm's *)
562
 
  let add_forest forest rope len =
563
 
    let i = ref 0 in
564
 
    let sum = ref empty in
565
 
      while len > min_len.(!i+1) do
566
 
        if forest.(!i).c <> Empty then begin
567
 
          sum := concat_fast forest.(!i).c !sum;
568
 
          forest.(!i).c <- Empty
569
 
        end;
570
 
        incr i
571
 
      done;
572
 
      sum := concat_fast !sum rope;
573
 
      let sum_len = ref (length !sum) in
574
 
        while !sum_len >= min_len.(!i) do
575
 
          if forest.(!i).c <> Empty then begin
576
 
            sum := concat_fast forest.(!i).c !sum;
577
 
            sum_len := !sum_len + forest.(!i).len;
578
 
            forest.(!i).c <- Empty;
579
 
          end;
580
 
          incr i
581
 
        done;
582
 
        decr i;
583
 
        forest.(!i).c <- !sum;
584
 
        forest.(!i).len <- !sum_len
585
 
  
586
 
  let concat_forest forest =
587
 
    Array.fold_left (fun s x -> concat_fast x.c s) Empty forest
588
 
  
589
 
  let rec balance_insert rope len forest = match rope with
590
 
      Empty -> ()
591
 
    | Leaf _ -> add_forest forest rope len
592
 
    | Concat(l,cl,r,cr,h) when h >= max_height || len < min_len.(h) ->
593
 
        balance_insert l cl forest;
594
 
        balance_insert r cr forest
595
 
    | x -> add_forest forest x len (* function or balanced *)
596
 
  
597
 
  let balance r =
598
 
    match r with
599
 
        Empty -> Empty
600
 
      | Leaf _ -> r
601
 
      | _ ->
602
 
          let forest = Array.init max_height (fun _ -> {c = Empty; len = 0}) in
603
 
            balance_insert r (length r) forest;
604
 
            concat_forest forest
605
 
  
606
 
  let bal_if_needed l r =
607
 
    let r = make_concat l r in
608
 
      if height r < max_height then r else balance r
609
 
  
610
 
  let concat_str l = function
611
 
      Empty | Concat(_,_,_,_,_) -> invalid_arg "concat_str"
612
 
    | Leaf rs as r ->
613
 
        let lenr = STRING.length rs in
614
 
          match l with
615
 
            | Empty -> r
616
 
            | Leaf ls ->
617
 
                let slen = lenr + STRING.length ls in
618
 
                  if slen <= leaf_size then Leaf (str_append ls rs)
619
 
                  else make_concat l r (* height = 1 *)
620
 
            | Concat(ll, cll, Leaf lrs, clr, h) ->
621
 
                let slen = clr + lenr in
622
 
                  if clr + lenr <= leaf_size then
623
 
                    Concat(ll, cll, Leaf (str_append lrs rs), slen, h)
624
 
                  else
625
 
                    bal_if_needed l r
626
 
            | _ -> bal_if_needed l r
627
 
  
628
 
  let append_char c r = concat_str r (Leaf (STRING.make 1 c))
629
 
  
630
 
  let concat l = function
631
 
      Empty -> l
632
 
    | Leaf _ as r -> concat_str l r
633
 
    | Concat(Leaf rls,rlc,rr,rc,h) as r ->
634
 
        (match l with
635
 
            Empty -> r
636
 
          | Concat(_,_,_,_,_) -> bal_if_needed l r
637
 
          | Leaf ls ->
638
 
              let slen = rlc + STRING.length ls in
639
 
                if slen <= leaf_size then
640
 
                  Concat(Leaf(str_append ls rls), slen, rr, rc, h)
641
 
                else
642
 
                  bal_if_needed l r)
643
 
    | r -> (match l with Empty -> r | _ -> bal_if_needed l r)
644
 
  
645
 
  let prepend_char c r = concat (Leaf (STRING.make 1 c)) r
646
 
  
647
 
  let rec get i = function
648
 
      Empty -> raise Out_of_bounds
649
 
    | Leaf s ->
650
 
        if i >= 0 && i < STRING.length s then STRING.unsafe_get s i
651
 
        else raise Out_of_bounds
652
 
    | Concat (l, cl, r, cr, _) ->
653
 
        if i < cl then get i l
654
 
        else get (i - cl) r
655
 
  
656
 
  let set (v:'a t) i (x:'a) = 
657
 
    let rec aux i : 'a t -> 'a t= function
658
 
      Empty  -> raise Out_of_bounds
659
 
    | Leaf s ->
660
 
        if i >= 0 && i < STRING.length s then
661
 
          let s = STRING.copy s in
662
 
            STRING.unsafe_set s i x;
663
 
            Leaf s
664
 
        else raise Out_of_bounds
665
 
    | Concat(l, cl, r, cr, _) ->
666
 
        if i < cl then concat (aux i v) r
667
 
        else concat l (aux (i - cl) v)
668
 
    in aux i v
669
 
  
670
 
  let of_string = function
671
 
      s when STRING.length s = 0 -> Empty
672
 
    | s ->
673
 
        let min (x:int) (y:int) = if x <= y then x else y in
674
 
        let rec loop r s len i =
675
 
          if i < len then (* len - i > 0, thus Leaf "" can't happen *)
676
 
            loop (concat r (Leaf (STRING.sub s i (min (len - i) leaf_size))))
677
 
              s len (i + leaf_size)
678
 
          else
679
 
            r
680
 
        in loop Empty s (STRING.length s) 0
681
 
  
682
 
  let rec make len c =
683
 
    let rec concatloop len i r =
684
 
      if i <= len then
685
 
        concatloop len (i * 2) (concat r r)
686
 
      else r
687
 
    in
688
 
      if len = 0 then Empty
689
 
      else if len <= leaf_size then Leaf (STRING.make len c)
690
 
      else
691
 
        let rope = concatloop len 2 (of_string (STRING.make 1 c)) in
692
 
          concat rope (make (len - length rope) c)
693
 
  
694
 
  let rec sub start len = function
695
 
      Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds else Empty
696
 
    | Leaf s ->
697
 
        if len > 0 then (* Leaf "" cannot happen *)
698
 
          (try Leaf (STRING.sub s start len) with _ -> raise Out_of_bounds)
699
 
        else if len < 0 || start < 0 || start > STRING.length s then
700
 
          raise Out_of_bounds
701
 
        else Empty
702
 
    | Concat(l,cl,r,cr,_) ->
703
 
        if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds;
704
 
        let left =
705
 
          if start = 0 then
706
 
            if len >= cl then
707
 
              l
708
 
            else sub 0 len l
709
 
          else if start > cl then Empty
710
 
          else if start + len >= cl then
711
 
            sub start (cl - start) l
712
 
          else sub start len l in
713
 
        let right =
714
 
          if start <= cl then
715
 
            let upto = start + len in
716
 
              if upto = cl + cr then r
717
 
              else if upto < cl then Empty
718
 
              else sub 0 (upto - cl) r
719
 
          else sub (start - cl) len r
720
 
        in
721
 
          concat left right
722
 
  
723
 
  let insert start rope r =
724
 
    concat (concat (sub 0 start r) rope) (sub start (length r - start) r)
725
 
  
726
 
  let remove start len r =
727
 
    concat (sub 0 start r) (sub (start + len) (length r - start - len) r)
728
 
  
729
 
  let to_string r =
730
 
    let rec strings l = function
731
 
        Empty -> l
732
 
      | Leaf s -> s :: l
733
 
      | Concat(left,_,right,_,_) -> strings (strings l right) left
734
 
    in
735
 
      string_of_string_list (strings [] r)
736
 
  
737
 
  let rec iter f = function
738
 
      Empty -> ()
739
 
    | Leaf s -> STRING.iter f s
740
 
    | Concat(l,_,r,_,_) -> iter f l; iter f r
741
 
  
742
 
  let iteri f r =
743
 
    let rec aux f i = function
744
 
      Empty -> ()
745
 
    | Leaf s ->
746
 
        for j = 0 to STRING.length s - 1 do
747
 
          f (i + j) (STRING.unsafe_get s j)
748
 
        done
749
 
    | Concat(l,cl,r,_,_) -> aux f i l; aux f (i + cl) r
750
 
    in
751
 
      aux f 0 r
752
 
  
753
 
  let rec rangeiter f start len = function
754
 
      Empty -> if start <> 0 || len <> 0 then raise Out_of_bounds
755
 
    | Leaf s ->
756
 
        let n = start + len in
757
 
        let lens = STRING.length s in
758
 
        if start >= 0 && len >= 0 && n <= lens then
759
 
          for i = start to n - 1 do
760
 
            f (STRING.unsafe_get s i)
761
 
          done
762
 
        else raise Out_of_bounds
763
 
    | Concat(l,cl,r,cr,_) ->
764
 
        if start < 0 || len < 0 || start + len > cl + cr then raise Out_of_bounds;
765
 
        if start < cl then begin
766
 
          let upto = start + len in
767
 
            if upto <= cl then
768
 
              rangeiter f start len l
769
 
            else begin
770
 
              rangeiter f start (cl - start) l;
771
 
              rangeiter f 0 (upto - cl) r
772
 
            end
773
 
        end else begin
774
 
          rangeiter f (start - cl) len r
775
 
        end
776
 
  
777
 
  let rec fold f a = function
778
 
      Empty -> a
779
 
    | Leaf s ->
780
 
        let acc = ref a in
781
 
          for i = 0 to STRING.length s - 1 do
782
 
            acc := f !acc (STRING.unsafe_get s i)
783
 
          done;
784
 
          !acc
785
 
    | Concat(l,_,r,_,_) -> fold f (fold f a l) r
786
 
 
787
 
  let rec map f = function
788
 
      Empty -> Empty
789
 
    | Leaf a -> Leaf (RANDOMACCESS.map f a)
790
 
    | Concat(l,cl,r,cr,h) -> Concat(map f l, cl, map f r, cr, h)
791
 
 
792
 
  let of_array = of_string
793
 
  let of_container = of_string
794
 
  let to_container = to_string
795
 
  let append = append_char
796
 
  let prepend = prepend_char
797
 
 
798
 
  let to_list r =
799
 
    let rec aux acc = function
800
 
        Empty -> acc
801
 
      | Leaf a -> RANDOMACCESS.fold_right (fun x l -> x :: l) a acc
802
 
      | Concat(l,_,r,_,_) -> aux (aux acc r) l
803
 
    in
804
 
      aux [] r
805
 
 
806
 
  let filter f =
807
 
    fold (fun s x -> if f x then append x s else s) Empty
808
 
 
809
 
  let mapi f v =
810
 
    let off = ref 0 in
811
 
      map (fun x -> f (Ref.post_incr off) x) v
812
 
 
813
 
        
814
 
  let rec fold f a = function
815
 
      Empty -> a
816
 
    | Leaf s ->
817
 
        let acc = ref a in
818
 
          for i = 0 to RANDOMACCESS.length s - 1 do
819
 
            acc := f !acc (RANDOMACCESS.unsafe_get s i)
820
 
          done;
821
 
          !acc
822
 
    | Concat(l,_,r,_,_) -> fold f (fold f a l) r
823
 
        
824
 
  let fold_left = fold
825
 
  let fold_right (f:'a -> 'b -> 'b) (v:'a t) (acc:'b)  : 'b =
826
 
    let rec aux (acc:'b) = function
827
 
      | Empty  -> acc
828
 
      | Leaf s -> RANDOMACCESS.fold_right f s acc
829
 
      | Concat(l, _, r, _, _) -> aux (aux acc r) l
830
 
    in aux acc v
831
 
 
832
 
  let exists f v =
833
 
    Return.label (fun label ->
834
 
  let rec aux = function
835
 
    | Empty                  -> ()
836
 
    | Leaf a                 -> RANDOMACCESS.iter (fun x -> if f x then Return.return label true) a
837
 
    | Concat (l, _, r, _, _) -> aux l; aux r
838
 
  in aux v; false)
839
 
 
840
 
let for_all f v = 
841
 
  Return.label (fun label ->
842
 
  let rec aux = function
843
 
    | Empty                  -> ()
844
 
    | Leaf a                 -> RANDOMACCESS.iter (fun x -> if not (f x) then Return.return label false) a
845
 
    | Concat (l, _, r, _, _) -> aux l; aux r
846
 
  in aux v; true)
847
 
 
848
 
  let findi f v = (*We rely on the order of exploration of the tree by [find]*)
849
 
    let off = ref 0 in
850
 
    let _   = find (fun x -> let result = f x in incr off; result) v in
851
 
      !off
852
 
 
853
 
  let partition p v =
854
 
    fold_left (fun (yes, no) x -> if p x then (append x yes,no) else (yes,append x no)) (empty,empty) v
855
 
 
856
 
  let find_all p v =
857
 
    fold_left (fun acc x -> if p x then append x acc else acc) empty v
858
 
      
859
 
  let mem m v = try let _ = find ( ( = ) m ) v in true with Not_found -> false
860
 
    
861
 
  let memq m v = try let _ = find ( ( == ) m ) v in true with Not_found -> false
862
 
 
863
 
 
864
 
let filter_map f =
865
 
  fold (fun acc x -> match f x with
866
 
          | None   -> acc
867
 
          | Some v -> append v acc) Empty
868
 
 
869
 
let enum e =
870
 
  let rec aux = function
871
 
    | Empty                 -> Enum.empty ()
872
 
    | Leaf s                -> RANDOMACCESS.enum s
873
 
    | Concat(l, _, r, _, _) -> Enum.append (Enum.delay (fun () -> aux l))
874
 
                                           (Enum.delay (fun () -> aux r))
875
 
  in aux e
876
 
 
877
 
let backwards e =
878
 
  let rec aux = function
879
 
    | Empty                 -> Enum.empty ()
880
 
    | Leaf s                -> RANDOMACCESS.backwards s
881
 
    | Concat(l, _, r, _, _) -> Enum.append (Enum.delay (fun () -> aux r))
882
 
                                           (Enum.delay (fun () -> aux l))
883
 
  in aux e
884
 
 
885
 
let of_enum e =
886
 
  Enum.fold (fun acc x -> append_char x acc) empty e
887
 
 
888
 
let of_backwards e =
889
 
  Enum.fold (fun acc x -> prepend_char x acc) empty e
890
 
 
891
 
  let print ?(first="[|") ?(last="|]") ?(sep="; ") print_a  out t =
892
 
    Enum.print ~first ~last ~sep print_a out (enum t)
893
 
 
894
 
end