Better memory management

3 files changed, 409 insertions, 0 deletions

diff --git a/src/tree/pageMap.ml b/src/tree/pageMap.ml
new file mode 100755
index 0000000..38bbe42
--- /dev/null
+++ b/src/tree/pageMap.ml
@@ -0,0 +1,178 @@
+type cell = int * int

+

+module type T_DEFAULT = sig

+

+  type t

+

+  val default : t

+

+end

+

+module MapArray(T:T_DEFAULT) = struct

+

+  (** The type is composed by the number of defined cell in the page, and the page itself *)

+  type t = int * (T.t array array)

+

+  let find (x:int) (y:int) (t:t) : T.t = begin

+    let block = snd t in

+    block.(y).(x)

+  end

+

+  let add (x:int) (y:int) (value:T.t) (t:t) : t = begin

+    let n, block = t in

+    let n' =

+      if (block.(y).(x) == T.default) then

+        n + 1

+      else

+        n in

+    block.(y).(x) <- value;

+    n', block

+  end

+

+  let remove (x:int) (y:int) (t:t) : t = begin

+    let n, block = t in

+    if (block.(y).(x) = T.default) then

+     t

+    else (

+      if n = 1 then

+        (* Do not keep empty block in memory *)

+        raise Not_found

+      else (

+        block.(y).(x) <- T.default;

+        (n -1, block)

+      )

+    )

+  end

+

+  let create array_size =  begin

+    0, Array.make_matrix array_size array_size T.default

+  end

+

+  let fold_line f y init t = begin

+    let n, block = t

+    and res = ref init in

+

+    let array_size = Array.length block in

+    for x = 0 to (array_size - 1) do

+      let value = block.(y).(x) in

+      if value != T.default then

+        res := f x value !res;

+    done;

+    !res

+  end

+

+end

+

+module SplayMap(T:T_DEFAULT) = struct

+

+  let array_size = 8

+

+  module PageMap = MapArray(T)

+

+  (** Module for the keys *)

+  module K = struct

+

+    type 'a t = K : (int * int) -> PageMap.t t [@@unboxed]

+

+    let comp:type a b. a t -> b t -> (a, b) Tools.cmp = fun a b -> begin

+      match a, b with K (x1, y1), K (x2, y2) ->

+        let res = Pervasives.compare (y1, x1) (y2, x2) in

+        if res < 0 then

+          Tools.Lt

+        else if res > 0 then

+          Tools.Gt

+        else

+          Tools.Eq

+    end

+

+    let repr: type a. Format.formatter -> a t -> unit = fun formatter (K (x, y)) ->

+      Format.fprintf formatter "%d, %d" x y

+

+  end

+

+  module Map = Splay.Make(K)

+

+  type t = Map.t

+

+  (* Values are always positive *)

+  let get_bounded_values (x, y) = (max 0 x), (max 0 y)

+

+  let find (id:cell) (t:Map.t) : T.t = begin

+    let x, y = get_bounded_values id in

+    let block_x = x / array_size

+    and block_y = y / array_size in

+    try

+      let block = Map.find (K (block_x, block_y)) t in

+      PageMap.find (x mod array_size) (y mod array_size) block

+    with Not_found -> T.default

+  end

+

+  let add (id:cell) (value:T.t) (t:Map.t) : Map.t = begin

+    let x, y = get_bounded_values id in

+    let block_x = x / array_size

+    and block_y = y / array_size in

+    let block =

+      try Map.find (K (block_x, block_y)) t

+      with Not_found -> PageMap.create array_size in

+    let page = PageMap.add (x mod array_size) (y mod array_size) value block in

+    Map.add (K (block_x, block_y)) page t

+  end

+

+  let remove (id:cell) (t:Map.t) : Map.t = begin

+    let x, y = get_bounded_values id in

+    let block_x = x / array_size

+    and block_y = y / array_size in

+    try

+      let block = Map.find (K (block_x, block_y)) t in

+      try

+        let block' = PageMap.remove (x mod array_size) (y mod array_size) block in

+        Map.add (K (block_x, block_y)) block' t

+      with Not_found ->

+        Map.remove (K (block_x, block_y)) t

+    with Not_found -> t

+  end

+

+  (** Empty map *)

+  let empty = Map.empty

+

+  (** Fold over the elements in the Map.*)

+  let fold f (t:Map.t) init = begin

+    let res = ref init in

+

+    let call_function column row x value acc = begin

+      f (column + x, row) value acc

+    end in

+

+    (* Call process_line for each block on the same row *)

+    let process_pages block_y acc = begin

+      let blocks = List.rev acc

+      and row_index = block_y * array_size in

+      for y = 0 to (array_size - 1) do

+        let row = row_index + y in

+        res := List.fold_left (fun init (column, block) ->

+          PageMap.fold_line (call_function column row) y init block

+        ) !res blocks;

+

+      done

+    end in

+

+    let fold_blocks (current_row, acc) (Map.C key_val) = begin

+      match key_val with ((K.K (block_x, block_y)), (block:PageMap.t)) ->

+      (* As long as the page lay in the same row, accumulate it *)

+      if current_row = block_y then

+        current_row, (block_x * array_size, block)::acc

+      else (

+        (* We apply the function for each accumulated block in the row *)

+        process_pages current_row acc;

+        block_y, (block_x, block)::[]

+      )

+    end in

+

+    let row_number, acc = Map.fold fold_blocks (1, []) t in

+    (* Apply the function to the last row *)

+    process_pages row_number acc;

+    !res

+  end

+

+

+end

diff --git a/src/tree/splay.ml b/src/tree/splay.ml
new file mode 100644
index 0000000..662fc6c
--- /dev/null
+++ b/src/tree/splay.ml
@@ -0,0 +1,194 @@
+module type KEY = sig
+
+  type 'a t
+
+  (** Parametrized comparator *)
+  val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp
+
+  val repr: Format.formatter -> 'a t -> unit
+
+end
+
+module Make (El : KEY) = struct
+
+  type container = C : ('a El.t * 'a) -> container [@@unboxed]
+
+  type leaf (** Fantom type for typing the tree *)
+  type node (** Fantom type for typing the tree *)
+
+  type 'a branch =
+    | Leaf : leaf branch
+    | Node : _ branch * ('a El.t * 'a) * _ branch -> node branch
+
+  type t = T : 'a branch ref -> t [@@unboxed]
+
+  let empty = T (ref Leaf)
+
+  let isEmpty (T tree) = match !tree with
+    | Leaf -> true
+    | _ -> false
+
+  let rec splay : type a. a El.t -> node branch -> node branch = fun x t -> begin
+    let Node (l, y, r) = t in
+    begin match El.comp x (fst y)  with
+      | Tools.Eq -> t
+      | Tools.Lt ->
+        begin match l with
+          | Leaf -> t
+          | Node (ll, z, rr) ->
+            begin match El.comp x (fst z)  with
+              | Tools.Eq -> Node (ll, z, Node (rr, y, r))
+              | Tools.Lt ->
+                begin match ll with
+                  | Leaf -> Node (ll, z, Node (rr, y, r))
+                  | Node _ as ll ->
+                    let Node (newL, newV, newR) = splay x ll
+                    in Node (newL, newV, Node (newR, z, Node (rr, y, r)))
+                end
+              | Tools.Gt ->
+                begin match rr with
+                  | Leaf -> Node (ll, z, Node (rr, y, r))
+                  | Node _ as rr ->
+                    let Node (newL, newV, newR) = splay x rr
+                    in Node (Node (ll, z, newL), newV, Node (newR, y, r))
+                end
+            end
+        end
+      | Tools.Gt ->
+        begin match r with
+          | Leaf -> t
+          | Node (ll, z, rr) ->
+            begin match El.comp x (fst z)  with
+              | Tools.Eq -> Node (Node (l, y, ll), z, rr)
+              | Tools.Lt ->
+                begin match ll with
+                  | Leaf -> Node (Node (l, y, ll), z, rr)
+                  | Node _ as ll ->
+                    let Node (newL, newV, newR) = splay x ll
+                    in Node (Node (l, y, newL), newV, Node (newR, z, rr))
+                end
+              | Tools.Gt ->
+                begin match rr with
+                  | Leaf -> Node (Node (l, y, ll), z, rr)
+                  | Node _ as rr ->
+                    let Node (newL, newV, newR) = splay x rr
+                    in Node (Node (Node(l, y, ll), z, newL), newV, newR)
+                end
+            end
+        end
+    end
+  end
+
+  let member: type a. a El.t -> t -> bool = fun x (T t) -> match !t with
+    | Leaf -> false
+    | Node _ as root ->
+        let root' = splay x root in
+        t := root';
+        let Node (_, c', _) = root' in
+        begin match El.comp (fst c') x  with
+          | Tools.Eq -> true
+          | _ -> false
+        end
+
+  let find: type a. a El.t -> t -> a = fun x (T t) -> match !t with
+    | Leaf -> raise Not_found
+    | Node _ as root ->
+        let root' = splay x root in
+        t := root';
+        let Node (_, c', _) = root' in
+        begin match El.comp (fst c') x with
+          | Tools.Eq -> snd c'
+          | _ -> raise Not_found
+        end
+
+  let add: type a. a El.t -> a -> t -> t = fun key value (T t) -> match !t with
+    | Leaf -> T (ref (Node (Leaf, (key, value), Leaf)))
+    | Node _ as root ->
+        let root' = splay key root in
+        let Node (l, y, r) = root' in
+        begin match El.comp key (fst y)  with
+          | Tools.Eq -> T (ref (Node(l, (key, value), r)))
+          | Tools.Lt -> T (ref (Node (l, (key, value), Node (Leaf, y, r))))
+          | Tools.Gt -> T (ref (Node (Node (l, y, Leaf), (key, value), r)))
+        end
+
+  let rec _subtree_maximum:type a. a branch -> a branch = fun t -> begin match t with
+  | Leaf -> Leaf
+  | Node (_, _, (Node (_, _, _) as x)) -> _subtree_maximum x
+  | Node (_, (key, value), Leaf) -> splay key t
+  end
+
+  let rec _subtree_minimum: type a. a branch -> a branch = fun t -> begin match t with
+  | Leaf -> Leaf
+  | Node ((Node (_, _, _) as x), _, _) -> _subtree_minimum x
+  | Node (Leaf, (key, value), _) -> splay key t
+  end
+
+  let remove: type a. a El.t -> t -> t = fun key (T t) -> begin match !t with
+    | Leaf -> empty
+    | Node _ as root ->
+      let root' = splay key root in
+      let Node (l, c', r) = root' in
+      begin match El.comp (fst c') key with
+        | Tools.Eq -> begin match _subtree_maximum l with
+          | Node(l, c, Leaf) -> T (ref (Node(l, c, r)))
+          | Node(l, c, _) -> raise Not_found
+          | Leaf -> begin match _subtree_minimum r with
+            | Leaf -> empty
+            | Node(Leaf, c, r) -> T (ref (Node(l, c, r)))
+            | Node(_, c, r) -> raise Not_found
+          end
+        end
+        (* The key is not present, return the splayed tree *)
+        | _ -> T (ref root')
+      end
+  end
+
+  (** Existencial type for the branches *)
+  type exBranch = Branch : _ branch -> exBranch [@@unboxed]
+
+  let fold f init (T t) = begin
+    let rec _fold : type b. (container * exBranch) list -> 'a -> b branch -> 'a = begin
+      fun acc v -> function
+    (* We have a node : we accumulate the right part, and process the left branch *)
+    | Node (left, (key, value), right) ->
+        let c = C (key, value) in
+        (_fold [@tailcall]) ((c, Branch right)::acc) v left
+    (* We have nothing left, we process the values delayed *)
+    | Leaf -> begin match acc with
+      | [] -> v
+      | (c, (Branch right))::tl -> (_fold [@tailcall]) tl (f v c) right
+      end
+    end in
+    _fold [] init !t
+  end
+
+  let repr formatter (T t) = begin
+
+    let repr_edge from formatter dest = begin
+      Format.fprintf formatter "\"%a\" -> \"%a\"\n"
+        El.repr from
+        El.repr dest
+    end in
+
+    let rec repr': type a b. a El.t -> Format.formatter -> b branch -> unit = fun parent formatter -> function
+    | Leaf -> ()
+    | Node (l, c, r) ->
+        let key = fst c in
+        Format.fprintf formatter "%a%a%a"
+        (repr_edge parent) key
+        (repr' key) l
+        (repr' key) r in
+
+    begin match !t with
+    | Leaf -> Format.fprintf formatter "digraph G {}"
+    | Node (l, c, r) ->
+      let key = fst c in
+      Format.fprintf formatter "digraph G {\n%a%a}"
+        (repr' key) l
+        (repr' key) r
+    end
+
+  end
+
+end
diff --git a/src/tree/splay.mli b/src/tree/splay.mli
new file mode 100755
index 0000000..521441c
--- /dev/null
+++ b/src/tree/splay.mli
@@ -0,0 +1,37 @@
+module type KEY = sig

+

+    type 'a t

+

+    val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp

+

+    val repr: Format.formatter -> 'a t -> unit

+

+end

+

+module Make (El : KEY) : sig

+

+  type t

+

+  (** Create an empty tree *)

+  val empty: t

+

+  (** Return the element in the tree with the given key *)

+  val find: 'a El.t -> t -> 'a

+

+  (** Add one element in the tree, if the element is already present, it is replaced. *)

+  val add: 'a El.t -> 'a -> t -> t

+

+  (** Check if the key exists *)

+  val member: 'a El.t -> t -> bool

+

+  val remove: 'a El.t -> t -> t

+

+  (** This type is used in the fold function as existencial type *)

+  type container = C : ('a El.t * 'a) -> container [@@unboxed]

+

+  val fold: ('a -> container -> 'a) -> 'a -> t -> 'a

+

+  (** Represent the content in dot syntax *)

+  val repr: Format.formatter -> t -> unit

+

+end