Source

cadastr / src / cd_Array.ml

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
module Array
 =
  struct

    include Array;

    type t 'a = array 'a;

    open Cd_Typeinfo;
    open Cd_Option;
    open Printf;
    open Cd_Ops;
    open Cdt;

    value map_to_list f arr =
      inner [] (Array.length arr - 1)
      where rec inner acc i =
        if i = -1
        then acc
        else inner [(f arr.(i)) :: acc] (i - 1)
    ;

    value dump ~t arr =
      arr
      |> map_to_list t#show
      |> String.concat " ; "
      |> sprintf "[| %s |]"
    ;

    module BuildSized
     :
      sig
        type t 'a;
        value create : ~size:int -> t 'a;
        value add : 'a -> t 'a -> unit;
        value get : t 'a -> array 'a;
      end
     =
      struct

        type t 'a =
          { size : int
          ; ofs : mutable int
          ; arr : mutable array 'a
          }
        ;

        value create ~size =
          if size < 0
          then
            invalid_arg "Cd_Array.Array.BuildSized.create: \
                         size < 0"
          else if size > Sys.max_array_length
          then
            invalid_arg "Cd_Array.Array.BuildSized.create: \
                         size > Sys.max_array_length"
          else
          { size = size
          ; ofs = 0
          ; arr = [| |]
          }
        ;

        value add x a =
          let i = a.ofs in
          if i = a.size
          then
            ( a.arr := [| |]
            ; invalid_arg "Cd_Array.Array.BuildSized.add: \
                           adding more elements than expected"
            )
          else
          (
            if i = 0
            then
              a.arr := Array.make a.size x  (* fills a.arr.(0) too *)
            else
              a.arr.(i) := x
          ;
            a.ofs := i + 1
          )
        ;

        value get a =
          let r = a.arr in
          ( a.arr := [| |]
          ; if a.ofs = a.size
            then
              r
            else
              invalid_arg "Cd_Array.Array.BuildSized.get: \
                           trying to get an incompletely built array"
          )
        ;

      end
    ;

    value for_all pred arr =
      loop 0
      where rec loop i =
        if i = Array.length arr
        then True
        else
          if pred arr.(i)
          then loop (i + 1)
          else False
    ;

    module BuildSizedRandAcc
     :
      sig
        type t 'a;
        value create : ~size:int -> t 'a;
        value set : t 'a -> int -> 'a -> unit;
        value get : t 'a -> array 'a;
      end
     =
      struct

        type t 'a =
          { inited : mutable bool
          ; res : mutable array 'a
          ; filled : mutable array bool
          }
        ;

        value create ~size =
          { inited = False
          ; res = [| |]
          ; filled = Array.make size False
          }
        ;

        value set arr i a =
          ( if arr.inited
            then
              ( arr.res.(i) := a
              )
            else
              ( arr.res := Array.make (Array.length arr.filled) a
              ; arr.inited := True
              )
          ; arr.filled.(i) := True
          )
        ;

        value get arr =
          if for_all ( ( == ) True ) arr.filled
          then
            arr.res
          else
            failwith "Array.BuildSizedRandAcc: array is not filled completely"
        ;

      end
    ;


    (* to Array: *)

    (* returns arrays paired with arrays of equivalence classes
       (where [f a b = True]) and the classes count.
       (array values are in [0 .. count-1]).
       time = O(sum_of_lengths_of_arrays^2)
       (named after topological "fibration"). *)

    value arrays_fibration
    : ('a -> 'a -> bool) ->
      list (array 'a) ->
      (list (array 'a * array int) * int)
    = fun f arrs ->

      let set_cls ~theitem ~thecls ~arr ~cls ~ofs =
        let jmax = Array.length arr - 1 in
        for j = ofs to jmax do
          if cls.(j) = -1
          then
            if f theitem arr.(j)
            then
              cls.(j) := thecls
            else
              ()
          else
            ()
        done
      in

      let set_clss ~theitem ~thecls ~arr ~cls ~tail_arrsclss ~firstofs =
        ( set_cls ~theitem ~thecls ~arr ~cls ~ofs:firstofs
        ; List.iter
            (fun (arr, cls) ->
               set_cls ~theitem ~thecls ~arr ~cls ~ofs:0
            )
            tail_arrsclss
        )
      in

      let orig_arrsclss = List.map
        (fun a -> (a, Array.make (Array.length a) (-1))) arrs in

      let curcls = ref 0 in

      inner orig_arrsclss
      where rec inner arrsclss =
        match arrsclss with
        [ [] -> (orig_arrsclss, curcls.val)
        | [(arr, cls) :: tail_arrsclss] ->
            let len = Array.length arr in
            let imax = len - 1 in
            let () =
              for i = 0 to imax do
                if cls.(i) = -1
                then
                  let thecls = curcls.val in
                  let () = incr curcls in
                  let () = cls.(i) := thecls in
                  set_clss ~theitem:arr.(i) ~thecls ~arr ~cls
                    ~tail_arrsclss
                    ~firstofs:(i + 1)
                else
                  ()
              done
            in
              inner tail_arrsclss
        ]
    ;

(* single array:
    value array_fibration f arr =
      let len = Array.length arr in
      let cls = Array.make len (-1) in
      let curcls = ref 0 in
      let () =
      let imax = len - 1 in
        for i = 0 to imax do
          if cls.(i) = -1
          then
            let thecls = curcls.val in
            let () = incr curcls in
            let () = cls.(i) := thecls in
            for j = i + 1 to imax do
              if cls.(j) = -1
              then
                if keq arr.(i) arr.(j)
                then
                  cls.(j) := thecls
                else
                  ()
              else
                ()
          else
            ()
      in
        (cls, curcls.val)
    ;
*)


    (* todo: поменять на алгоритм, который будет для каждого массива
       составлять массив, где .(cls) = список элементов с таким классом. *)

    value merge_maps ?tikey ?tival ~builder ~keq ~f ~k1 ~v1 ~k2 ~v2 () =

      let _tikey = Option.default tikey Typeinfo.ti_no in
      let _tival = Option.default tival Typeinfo.ti_no in

      (*
      let () =
        ( Printf.printf "k1: %s\nv1: %s\nk2: %s\nv2: %s\n"
            (dump ~t:_tkey k1)
            (dump ~t:_tval v1)
            (dump ~t:_tkey k2)
            (dump ~t:_tval v2)
        )
      in
      *)

      let len1 = Array.length k1 in
      let () = assert (len1 = Array.length v1) in
      let len2 = Array.length k2 in
      let () = assert (len2 = Array.length v2) in

      let (f, first_only) =
        match f with
        [ `Merge_rws f_opt ->
            let opt_of_list l =
              match l with
              [ [] -> None
              | [x] -> Some x
              | [_ :: _] -> assert False
              ]
            in
            let f_lst k v1lst v2lst =
              match f_opt k (opt_of_list v1lst) (opt_of_list v2lst) with
              [ None -> []
              | Some v -> [v]
              ]
            in
            (f_lst, True)
        | `Merge_rwm f_lst ->
            (f_lst, False)
        ]
      in

      (* собирает varr.(i) по порядку, чей cls.(i) = cls,
         начиная с ofs включительно;
         возвращает собранное и следующий минимальный индекс,
         с которого начнётся какой-либо следующий класс, или -1,
         если такого не найдено. *)
      let gather_cls ~thecls ~cls ~varr ~ofs =
        let imax = Array.length cls - 1 in
        inner (-1) [] ofs
        where rec inner nextcls_ofs acc i =
          if i > imax
          then (List.rev acc, nextcls_ofs)
          else
            let c = cls.(i) in
            let nextcls_ofs =
              if nextcls_ofs = -1 && c > thecls then i else nextcls_ofs in
            let acc =
              match ((c = thecls), first_only, acc) with
              [ (True, False, acc) | (True, True, ([] as acc)) ->
                  [varr.(i) :: acc]
              | (False, _, acc) | (True, True, ([_ :: _] as acc)) ->
                  acc
              ]
            in
              inner nextcls_ofs acc (i + 1)
      in

      match arrays_fibration keq [k1; k2] with
      [ ([(_a1, cls1) ; (_a2, cls2)] , maxcls) ->

          (*
          let () =
            Typeinfo.
            ( printf "cls1: %s\ncls2: %s\n%!"
                (dump ~t:tint cls1)
                (dump ~t:tint cls2)
            )
          in
          *)

          let acc_add = builder#add in

          let rec return ~acc =

            builder#result acc

          and add ~k ~v1s ~v2s ~acc =

            let addon_vals_top_first = f k v1s v2s in

            (*
            let () =
              let show_list lst =
                lst
                |> List.map _tval#tiopt#show
                |> String.concat " ; "
                |> sprintf "[%s]" in
              printf "k=%s v1s=%s v2s=%s\n"
                 (_tkey#tiopt#show k) (show_list v1s) (show_list v2s)
            in
            *)

            List.fold_right
              (fun v acc -> acc_add acc k v)
              addon_vals_top_first
              acc

          and proc_arr1 ~acc ~curcls ofs =

            (*
            let () = printf "proc_arr1: curcls=%i, ofs=%i\n%!" curcls ofs in
            *)

            if curcls = maxcls
            then
              return ~acc
            else

              if ofs = len1
              then

                proc_arr2 ~curcls ~acc 0

              else

                let (v1s, nextcls1_ofs) =
                  gather_cls ~thecls:curcls ~cls:cls1 ~varr:v1 ~ofs in

                let (v2s, _nextcls2_ofs) =
                  gather_cls ~thecls:curcls ~cls:cls2 ~varr:v2 ~ofs:0 in

                let k1k = k1.(ofs) in

                let acc = add ~k:k1k ~v1s ~v2s ~acc in

                let curcls = curcls + 1 in

                if nextcls1_ofs = -1
                then
                  proc_arr2 ~curcls ~acc 0
                else
                  proc_arr1 ~acc ~curcls nextcls1_ofs

          and proc_arr2 ~acc ~curcls ofs =

            (*
            let () = printf "proc_arr2: curcls=%i, ofs=%i\n%!"
              curcls ofs in
            *)

            if curcls = maxcls
            then
              let () = assert (ofs = 0 || ofs = -1) in
              return ~acc
            else

              if cls2.(ofs) < curcls
              then

                proc_arr2 ~acc ~curcls (ofs + 1)

              else
                let (v2s, nextcls2_ofs) =
                  gather_cls ~thecls:curcls ~cls:cls2 ~varr:v2 ~ofs in

                let k2k = k2.(ofs) in

                let acc = add ~k:k2k ~v1s:[] ~v2s ~acc in

                let curcls = curcls + 1 in

                let () = assert (
                  if nextcls2_ofs = -1
                  then curcls = maxcls
                  else True
                ) in

                proc_arr2 ~acc ~curcls nextcls2_ofs

          in
            proc_arr1 ~curcls:0 ~acc:builder#empty 0

      | _ -> assert False
      ]
    ;


    value map2to1
     : ! 'a 'b 'z . ('a -> 'b -> 'z) -> array 'a -> array 'b -> array 'z
     = fun f a b ->
         let len = Array.length a in
         if len <> Array.length b
         then invalid_arg "Array.map2to1: different lengths"
         else
           if len = 0
           then [| |]
           else
             let z0 = f a.(0) b.(0) in
             let z = Array.make len z0 in
             let () =
               for i = 1 to len - 1 do
                 ( z.(i) := f a.(i) b.(i)
                 )
                 done
             in
               z
    ;


    (* typeinfo *)

    class ti ['z]
    ?cmp ?eq ?hash ?show
    (ti_elem : #Cdt.ti 'b)
    () =
      object (_self : #tifull (array 'a))

        constraint 'z = array 'a;

        inherit Cdt.ti ['z] ();

        initializer
          ( v_type_name.val := Some
             (Printf.sprintf "array (%s)" ti_elem#type_name)
          )
        ;

        method type_desc = Simple "array"
        ;

        inherit tifull_ops [_] ?cmp ?eq ?hash
          ~show:
            (match show with
             [ None ->
                 fun arr ->
                   Cd_List.List.dump
                     ~begins:"[|" ~ends:"|]" ~delim:"; "
                     ti_elem
                     (Array.to_list arr)
             | Some show -> show
             ]
            )
          ()
        ;

      end
    ;


  end
;