From a6b5a6bdd138a5ccc6827bcc73580df1e9218820 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 24 Nov 2017 09:22:24 +0100 Subject: Moved all the code to src directory --- tools.ml | 392 --------------------------------------------------------------- 1 file changed, 392 deletions(-) delete mode 100755 tools.ml (limited to 'tools.ml') diff --git a/tools.ml b/tools.ml deleted file mode 100755 index 6dfe564..0000000 --- a/tools.ml +++ /dev/null @@ -1,392 +0,0 @@ -let u = UTF8.from_utf8string - -module Option = struct - - let map f = function - | Some x -> Some (f x) - | None -> None - - let iter f = function - | Some x -> f x - | None -> () - - let bind f = function - | None -> None - | Some x -> f x - - let default v = function - | None -> v - | Some x -> x - - -end - -module String = struct - - include String - - let split str ~by:sep = begin - let p = String.index str sep in - let slen = String.length str in - String.sub str 0 p, String.sub str (p + 1) (slen - p - 1) - end - - let cut str ~by:sep = begin - try String.sub str 0 @@ String.index str sep with - | Not_found -> str - end - - let string_of_ints v = begin - let buff = Buffer.create 1 in - let rec convert value = begin - Buffer.add_char buff @@ char_of_int @@ value land 0xFF; - let rem = value lsr 8 in - match rem with - | 0 -> Buffer.contents buff - | x -> convert x - end in - let res = convert v in - let buff' = Buffer.create @@ String.length res in - for i = ((String.length res) - 1) downto 0 do - Buffer.add_char buff' @@ String.get res i - done; - Buffer.contents buff' - end - - let print_buffer f t = begin - let buff = UTF8.Buffer.create 16 in - f buff t; - UTF8.Buffer.contents buff - end - - let filter_float str = begin - let l = String.length str in - if l > 0 && String.get str (l - 1) = '.' then - String.sub str 0 (l - 1) - else - str - end - -end - -module List = struct - - (** fold_left over only the first element *) - let fst f init = function - | hd::tl -> f init hd - | [] -> init - - let printb ?(first=(u"(")) ?(last=(u")")) ?(sep=(u",")) f buffer elems = begin - - let rec print = begin function - | [] -> () - | hd::[] -> - f buffer hd; - | hd::tl -> - f buffer hd; - UTF8.Buffer.add_string buffer sep; - print tl - end in - - UTF8.Buffer.add_string buffer first; - print elems; - UTF8.Buffer.add_string buffer last - end - - let rec find_map f = begin function - | [] -> raise Not_found - | hd::tl -> begin match f hd with - | Some x -> x - | None -> (find_map[@tailrec]) f tl - end - end - - let rec findOpt p = begin function - | [] -> None - | x::l -> - if p x then - Some(x) - else - findOpt p l - end - - and find_map2 p = begin function - | [] -> raise Not_found - | x::l -> - begin try find_map p x with - Not_found -> find_map2 p l - end - end - - (** Convert the list [l] as an array *) - let to_array l = begin - let elems = ref l in - let build = fun _ -> - begin match (!elems) with - | [] -> assert false - | hd::tl -> - elems := tl; - hd - end - in Array.init (List.length l) build - end - - let linearize elems = begin - let rec _linearize acc (elems:'a list list) : 'a list = begin - let split (hds, tls) = function - | hd::tl -> hd::hds, tl::tls - | [] -> hds, tls - in - match elems with - | [] -> acc - | elems -> - let acc, tls = List.fold_left split (acc, []) elems in - _linearize acc tls - end in - List.rev @@ _linearize [] elems - end - -end - -module Tuple2 = struct - - let fst = Pervasives.fst - - let snd = Pervasives.snd - - let map1 f (a, b) = (f a, b) - - let map2 f (a, b) = (a, f b) - - let replace1 v (a, b) = (v, b) - - let replace2 v (a, b) = (a, v) - - let printb ?(first="(") ?(last=")") ?(sep=",") format1 format2 out (a, b) = begin - UTF8.Printf.bprintf out "%s%a%s%a%s" - first - format1 a - sep - format2 b - last - end - -end - -module Tuple3 = struct - - let fst (a, b, c) = a - - let snd (a, b, c) = b - - let thd (a, b, c) = c - - let map f (a, b, c) = (f a, f b, f c) - - let map1 f (a, b, c) = (f a, b, c) - - let map2 f (a, b, c) = (a, f b, c) - - let map3 f (a, b, c) = (a, b, f c) - - let replace1 v (a, b, c) = (v, b, c) - - let replace2 v (a, b, c) = (a, v, c) - - let replace3 v (a, b, c) = (a, b, v) -end - -module NCurses = struct - - type mouse_event = - | BUTTON1_PRESSED - | BUTTON1_RELEASED - | BUTTON1_CLICKED - | BUTTON1_DOUBLE_CLICKED - | BUTTON1_TRIPLE_CLICKED - | BUTTON2_PRESSED - | BUTTON2_RELEASED - | BUTTON2_CLICKED - | BUTTON2_DOUBLE_CLICKED - | BUTTON2_TRIPLE_CLICKED - | BUTTON3_PRESSED - | BUTTON3_RELEASED - | BUTTON3_CLICKED - | BUTTON3_DOUBLE_CLICKED - | BUTTON3_TRIPLE_CLICKED - | BUTTON4_PRESSED - | BUTTON4_RELEASED - | BUTTON4_CLICKED - | BUTTON4_DOUBLE_CLICKED - | BUTTON4_TRIPLE_CLICKED - | BUTTON_SHIFT - | BUTTON_CTRL - | BUTTON_ALT - | ALL_MOUSE_EVENTS - | REPORT_MOUSE_POSITION - - type event_type - - external set_mouse_event: mouse_event list -> unit = "c_set_mouse_event" - - external get_mouse_event: unit -> (int * event_type * (int * int * int)) option = "c_get_mouse_event" - - external is_event_of_type: mouse_event -> event_type -> bool = "c_is_event_of_type" - -end - -let try_finally f except = - try let res = f () in - except (); - res - with e -> - except (); - raise e - -type (_,_) cmp = - | Eq : ('a,'a) cmp - | Lt : ('a,'b) cmp - | Gt : ('a,'b) cmp - -(** Existencial type for comparing two types. - This type has no utility, except for structural comparison between two - values. - *) -type existencial = Ex: 'a -> existencial - -module type COMPARABLE_TYPE = sig - - type 'a t - - val comp: 'a t -> 'b t -> ('a, 'b) cmp - -end - -module ArrayMap(Ord: COMPARABLE_TYPE) = struct - - type 'a key = 'a Ord.t - - type t = Val : ('a key * 'a) array -> t - - let find: type a. a key -> t -> a = begin fun k (Val map) -> - let rec find_ idx : a = begin - let x, v = Array.get map idx in - match Ord.comp x k with - | Eq -> v - | Lt -> find_ ((2 * idx) + 1) - | Gt -> find_ ((2 * idx) + 2) - end in - find_ 0 - end - - let from_list l = begin - let compare (key_x, _) (key_y, _) = match Ord.comp key_x key_y with - | Eq -> 0 - | Lt -> -1 - | Gt -> 1 - in - let arr = List.to_array l in - Array.sort compare arr; - Val arr - end - -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 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 -- cgit v1.2.3