diff options
Diffstat (limited to 'src/tree/pageMap.ml')
| -rw-r--r-- | src/tree/pageMap.ml | 165 |
1 files changed, 64 insertions, 101 deletions
diff --git a/src/tree/pageMap.ml b/src/tree/pageMap.ml index e18ba6f..967ccfe 100644 --- a/src/tree/pageMap.ml +++ b/src/tree/pageMap.ml @@ -18,178 +18,141 @@ along with licht. If not, see <http://www.gnu.org/licenses/>. type cell = int * int
module type T_DEFAULT = sig
-
type t
val default : t
-
end
-module MapArray(T:T_DEFAULT) = struct
-
+module MapArray (T : T_DEFAULT) = struct
+ type t = int * T.t array array
(** 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 find (x : int) (y : int) (t : t) : T.t =
let block = snd t in
block.(y).(x)
- end
- let add (x:int) (y:int) (value:T.t) (t:t) : t = begin
+ let add (x : int) (y : int) (value : T.t) (t : t) : t =
let n, block = t in
- let n' =
- if (block.(y).(x) == T.default) then
- n + 1
- else
- n in
+ let n' = if block.(y).(x) == T.default then n + 1 else n in
block.(y).(x) <- value;
- n', block
- end
+ (n', block)
- let remove (x:int) (y:int) (t:t) : t = begin
+ let remove (x : int) (y : int) (t : t) : t =
let n, block = t in
- if (block.(y).(x) = T.default) then
- t
+ if block.(y).(x) = T.default then t
+ else if n = 1 then (* Do not keep empty block in memory *)
+ raise Not_found
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
+ block.(y).(x) <- T.default;
+ (n - 1, block))
- let create array_size = begin
- 0, Array.make_matrix array_size array_size T.default
- end
+ let create array_size = (0, Array.make_matrix array_size array_size T.default)
- let fold_line f y init t = begin
- let n, block = t
- and res = ref init in
+ let fold_line f y init t =
+ let n, block = t and res = ref init in
let array_size = Array.length block in
- for x = 0 to (array_size - 1) do
+ for x = 0 to array_size - 1 do
let value = block.(y).(x) in
- if value != T.default then
- res := f x value !res;
+ if value != T.default then res := f x value !res
done;
!res
- end
-
end
-module SplayMap(T:T_DEFAULT) = struct
-
+module SplayMap (T : T_DEFAULT) = struct
let array_size = 8
- module PageMap = MapArray(T)
+ 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
+ let comp : type a b. a t -> b t -> (a, b) Tools.cmp =
+ fun a b ->
+ match (a, b) with
+ | K (x1, y1), K (x2, y2) ->
+ let res = Stdlib.compare (y1, x1) (y2, x2) in
+ if res < 0 then Tools.Lt else if res > 0 then Tools.Gt else Tools.Eq
+ 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)
+ 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 get_bounded_values (x, y) = (max 0 x, max 0 y)
- let find (id:cell) (t:Map.t) : T.t = begin
+ let find (id : cell) (t : Map.t) : T.t =
let x, y = get_bounded_values id in
- let block_x = x / array_size
- and block_y = y / array_size 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 add (id : cell) (value : T.t) (t : Map.t) : Map.t =
let x, y = get_bounded_values id in
- let block_x = x / array_size
- and block_y = y / array_size 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
+ 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 remove (id : cell) (t : Map.t) : Map.t =
let x, y = get_bounded_values id in
- let block_x = x / array_size
- and block_y = y / array_size 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
+ 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 -> 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 fold f (t : Map.t) init =
let res = ref init in
- let call_function column row x value acc = begin
- f (column + x, row) value acc
- end in
+ let call_function column row x value acc = f (column + x, row) value acc 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 process_pages block_y acc =
+ 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;
-
+ 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
+ in
+
+ let fold_blocks (current_row, acc) (Map.C key_val) =
+ 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) ]))
+ 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
|