adding messages to an ftree

gistfile1.fs

type ('k,'v) msg =
  | Insert of 'k * 'v
  | Delete of 'k

let key = function
  | Insert (k,_) -> k
  | Delete k     -> k

type ('k,'v) row = 
  | Empty
  | Full of ('k,'v) msg list

let merge_msgs ns ns_l os os_l =
  let rec inner acc size k k_size l l_size = match k,l with
  | [], [] -> (List.rev acc, size)
  | _ , [] -> (List.rev_append acc k, size + k_size)
  | [], _  -> (List.rev_append acc l, size + l_size)
  | k0 :: kt, l0 :: lt ->
    let k0k = key k0
    and l0k = key l0
    in
    if k0k < l0k
    then
      let acc' = k0 :: acc
      and size' = size + 1
      and k_size' = k_size - 1
      in
      inner acc' size' kt k_size' l l_size
    else if k0k > l0k then
      let acc' = l0 :: acc
      and size' = size + 1
      and lt_size = l_size - 1
      in
      inner acc' size' k k_size lt lt_size
    else
      begin
        let kt_size = k_size -1 in
        let lt_size = l_size -1 in
        match k0,l0 with
          | Delete _, Insert (_,v0) ->
            inner acc size kt kt_size lt lt_size
          | _       ,    _          ->
            let acc' = k0 :: acc
            and size' = size + 1
            in
            inner acc' size' kt kt_size lt lt_size
      end

  in
  inner [] 0 ns ns_l os os_l


let create () = []

let rec find_msg k = function
  | [] -> None
  | m :: ms ->
    if key m = k
    then Some m
    else find_msg k ms

let find_row k =  function
  | Empty   -> None
  | Full ms -> find_msg k ms


let rec find k = function
  |[]      -> None
  |r :: rs ->
    begin
      match find_row k r with
        | None -> find k rs
        | x    -> x
    end

let capacity level = 1 lsl level

let rec finish up down =
  match up with
  | [] -> down
  | u :: us -> finish us (u::down)

let rec redivide level us us_l up down =
  if us = [] 
  then finish up down
  else
    begin
      match up with
      | [] -> assert (us = []); down 
      | Empty :: up_t ->
        let c = capacity level in
        if us_l < c 
        then
          redivide (level -1) us us_l up_t (Empty :: down)
        else
          let rec loop acc msgs i =
            if i = 0
            then
              let row = Full (List.rev acc) in
              redivide (level -1) msgs (us_l - c) up_t (row :: down)
            else
              match msgs with
              | m :: ms -> loop (m :: acc) ms (i-1)
              | [] -> failwith "can't happen"
          in
          loop [] us c
      | _ :: up_t -> failwith "is full?"
    end




let rec _add ms ms_l level up down =
  if ms_l = 0
  then finish up down
  else
    begin
      let c = capacity level in
      match down with
      | [] ->
        assert(ms_l = c);
        finish up [Full ms]
      | row :: rows ->
        begin
          match row with
          | Empty ->
            begin
              assert (ms_l = c);
              finish up (Full ms :: rows)
            end
          | Full ms0 ->
            begin
              let msgs, x' = merge_msgs ms ms_l ms0 c in
              if x' = 2 * c 
              then _add msgs x' (level +1) (Empty :: up) rows
              else redivide level msgs x'  (Empty :: up) rows
            end
        end

    end


let add ms ft =
  let ms_l = List.length ms in
  _add ms ms_l 0 [] ft


let t0 = []
let t1 = add [Insert(5,"5")] t0;;
let t2 = add [Delete 4] t1;;
let t3 = add [Delete 4] t2;;
let t4 = add [Insert(6,"6")] t3;;