diff options
Diffstat (limited to 'src/tools.ml')
-rwxr-xr-x | src/tools.ml | 104 |
1 files changed, 7 insertions, 97 deletions
diff --git a/src/tools.ml b/src/tools.ml index 7f500bf..8481d59 100755 --- a/src/tools.ml +++ b/src/tools.ml @@ -298,101 +298,11 @@ module ArrayMap(Ord: COMPARABLE_TYPE) = struct end -(** Map for any comparable value. - This map can bind 'a key -> 'a value as long as the key are comparable. - *) -module Map(Ord: COMPARABLE_TYPE) = struct - - type 'a key = 'a Ord.t - - type wrapper = Ex: 'a key * 'a -> wrapper - - type t = - | Empty : t - | Node : t * 'a key * 'a * t * int -> t - - let singleton x d = Node(Empty, x, d, Empty, 1) - - let empty = Empty - - let is_empty = function - | Empty -> true - | _ -> false - - let height = function - | Empty -> 0 - | Node(_,_,_,_,h) -> h - - let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Map.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - create ll lv ld (create lr x d r) - else begin - match lr with - Empty -> invalid_arg "Map.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Map.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - create (create l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Map.bal" - | Node(rll, rlv, rld, rlr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - - let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with - | Empty -> Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - match Ord.comp x v with - | Eq -> Node(l, x, data, r, h) - | Lt -> bal (add x data l) v d r - | Gt -> bal l v d (add x data r) - end - - let rec find: type a. a key -> t -> a = begin fun x t -> match t with - | Empty -> raise Not_found - | Node(l, k, v, r, _) -> - match Ord.comp x k with - | Eq -> v - | Lt -> find x l - | Gt -> find x r - end +let fold_for f a b init = + let rec _fold res i = begin + if i >= b then res + else + _fold (f i res) (i + 1) + end in + (_fold[@tailcall]) init a - let rec mem: type a. a key -> t -> bool = begin fun x t -> match t with - | Empty -> false - | Node(l, k, v, r, _) -> - match Ord.comp x k with - | Eq -> true - | Lt -> mem x l - | Gt -> mem x r - end - - (* - let rec fold: ('a -> wrapper -> 'a) -> 'a -> t -> 'a = - begin fun f init t -> match t with - | Empty -> init - | Node(l, k, v, r, _) -> - let res_left = fold f init l in - let result = f res_left @@ Ex (k, v) in - fold f result r - end - *) -end |