+++ /dev/null
-(*
- * Zack's own OCaml library -- set of "helpers" function for the OCaml language
- *
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@bononia.it>
- *
- * This module is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * This module is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this module; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *)
-
-open Printf ;;
-
-exception Not_implemented ;;
-
-let (newline, newline_len) =
- let default_newline = "\n" in
- let newline =
- match Sys.os_type with
- | "Unix" -> "\n"
- | "Win32" | "Cygwin" -> "\r\n"
- | "MacOS" -> "\r"
- | _ -> default_newline
- in
- (newline, String.length newline)
-;;
-
-module ZLogic =
- struct
-
- let non pred x = not (pred x) ;;
- let conj p1 p2 x = (p1 x) && (p2 x) ;;
- let disj p1 p2 x = (p1 x) || (p2 x) ;;
- let imply p1 p2 x = (non p1) x || p2 x ;;
-
- let (&&&) = conj ;;
- let (|||) = disj ;;
- let (=>) = imply ;;
-
- end
-;;
-
-module ZArray =
- struct
-
- exception Found of int;;
-
- (** return the index of first element in ary on which pred is true *)
- let index pred ary =
- try
- Array.iteri (fun idx e -> if pred e then raise (Found idx)) ary;
- raise Not_found
- with Found idx -> idx
- ;;
- (** as index but return the element itself instead of the index *)
- let find pred ary = ary.(index pred ary) ;;
- (** check if at least one element in ary satisfies pred *)
- let exists pred ary =
- try
- ignore (find pred ary);
- true
- with Not_found -> false
- ;;
- (** check if all elements in ary satisfy pred *)
- let for_all pred ary = not (exists (ZLogic.non pred) ary) ;;
-
- (** return a fresh array containing all elements of ary that satisfy pred
- *)
- let filter pred ary =
- let indexes = (* indexes of element on which pred is satisfied *)
- let (_, indexes) =
- Array.fold_left
- (fun (i, acc) e -> if pred e then (i+1, i::acc) else (i+1, acc))
- (0, [])
- ary
- in
- List.rev indexes
- in
- let size = List.length indexes in
- let newary = Array.make size ary.(0) in
- let rec fill i = function
- | [] -> ()
- | idx::tl ->
- newary.(i) <- ary.(idx);
- fill (i+1) tl
- in
- fill 0 indexes;
- newary
- ;;
-
- let lrotate () =
- raise Not_implemented; () ;;
- let rrotate () =
- raise Not_implemented; () ;;
-
- end
-
-module ZDbm =
- struct
- (** fold on dbm key and values, processing order is not specified *)
- let fold f init dbm =
- let res = ref init in
- Dbm.iter (fun key value -> res := f !res key value) dbm;
- !res
- ;;
- end
-
-module ZHashtbl =
- struct
- let keys tbl = Hashtbl.fold (fun key _ acc -> key :: acc) tbl [] ;;
- let values tbl = Hashtbl.fold (fun _ valu acc -> valu :: acc) tbl [] ;;
- let remove_all tbl key =
- for i = 1 to List.length (Hashtbl.find_all tbl key) do
- Hashtbl.remove tbl key
- done
- ;;
- end
-
-module ZList =
- struct
- (** tail recursive version of List.map *)
- let map' f l =
- let rec aux acc = function
- | [] -> List.rev acc
- | hd :: tl -> aux (f hd :: acc) tl
- in
- aux [] l
- ;;
- (** guarded map on lists. List.length output <= List.length input.
- Not tail recursive *)
- let rec map_if f pred = function
- | [] -> []
- | hd::tl when pred hd -> f hd :: map_if f pred tl
- | hd::tl -> map_if f pred tl
- ;;
- (** tail recursive version of map_if *)
- let map_if' f pred l =
- let rec aux acc = function
- | [] -> List.rev acc
- | hd::tl when pred hd -> aux (f hd :: acc) tl
- | hd::tl -> aux acc tl
- in
- aux [] l
- ;;
- (** low level to implement assoc_all and assq_all *)
- let assoc_all_gen eq key list =
- let rec aux acc = function
- | [] -> acc
- | (k, v)::tl when (eq k key) -> aux (v :: acc) tl
- | _::tl -> aux acc tl
- in
- List.rev (aux [] list)
- ;;
- (** return all binding of k in association list l in the order they appear
- in l. Uses structural equality *)
- let assoc_all k l = assoc_all_gen (=) k l ;;
- (** as assoc_all but uses physical equality *)
- let assq_all k l = assoc_all_gen (==) k l ;;
- let lrotate = function
- | [] -> raise (Invalid_argument "Zack.List.lrotate")
- | hd::tl -> tl @ [hd]
- ;;
- let rrotate l =
- match List.rev l with
- | [] -> raise (Invalid_argument "Zack.List.rrotate")
- | hd::tl -> hd :: List.rev tl
- ;;
- end
-
-module ZSys =
- struct
- let copy () =
- raise Not_implemented; () ;;
- end
-
-module ZUnix =
- struct
-
- let mkdir () =
- raise Not_implemented; () ;;
-
- let get_stats follow_symlink =
- if follow_symlink then Unix.stat else Unix.lstat
- ;;
- (* low level for is_* predicates *)
- let is_file_kind follow_symlink kind fname =
- (get_stats follow_symlink fname).Unix.st_kind = kind
- ;;
- let is_regular ?(follow_symlink = true) =
- is_file_kind follow_symlink Unix.S_REG ;;
- let is_directory ?(follow_symlink = true) =
- is_file_kind follow_symlink Unix.S_DIR ;;
- let is_chardev ?(follow_symlink = true) =
- is_file_kind follow_symlink Unix.S_CHR ;;
- let is_blockdev ?(follow_symlink = true) =
- is_file_kind follow_symlink Unix.S_BLK ;;
- let is_symlink ?(follow_symlink = false) =
- is_file_kind follow_symlink Unix.S_LNK ;;
- let is_fifo ?(follow_symlink = true) =
- is_file_kind follow_symlink Unix.S_FIFO ;;
- let is_socket ?(follow_symlink = true) =
- is_file_kind follow_symlink Unix.S_SOCK ;;
-
- let size ?(follow_symlink = true) fname =
- (get_stats follow_symlink fname).Unix.st_size ;;
-
- (** return a list of all entries contained in a directory. Return order is
- not specified *)
- let ls dirname =
- let dir = Unix.opendir dirname in
- let rec aux acc =
- match (try Some (Unix.readdir dir) with End_of_file -> None) with
- | Some entry -> aux (entry :: acc)
- | None -> acc
- in
- let res = aux [] in
- Unix.closedir dir;
- res
- ;;
-
- end
-
-module ZString =
- struct
-
- (** string -> char list *)
- let explode s =
- let chars = ref [] in
- for i = String.length s - 1 downto 0 do
- chars := s.[i] :: !chars
- done;
- !chars
- ;;
-
- (** char list -> string *)
- let implode l =
- let buf = Buffer.create (List.length l) in
- let rec implode' = function
- | [] -> Buffer.contents buf
- | hd::tl ->
- Buffer.add_char buf hd;
- implode' tl
- in
- implode' l
- ;;
-
- (** perl's chomp, remove once trailing "\n", if any *)
- let chomp s =
- let len = String.length s in
- let diff = len - newline_len in
- if String.sub s diff newline_len = newline then (* trailing newline *)
- String.sub s 0 diff
- else
- s
- ;;
-
- (** map on string *)
- let map f s =
- for i = 0 to String.length s do
- s.[i] <- f s.[i]
- done
- ;;
-
- (** fold_left on string *)
- let fold_left f init s =
- let len = String.length s in
- let rec fold_left' idx acc =
- if idx = len then
- acc
- else (* idx < len *)
- fold_left' (idx + 1) (f acc s.[idx])
- in
- fold_left' 0 init
- ;;
-
- (* TODO Non funge *)
- let fold_right f s init =
- let len = String.length s in
- let rec fold_right' idx acc =
- if idx < 0 then
- acc
- else (* idx >= 0 *)
- fold_right' (idx - 1) (f s.[idx] acc)
- in
- fold_right' len (init - 1)
- ;;
-
- (** iter on string *)
- let iter (f: char -> unit) = fold_left (fun _ c -> f c) () ;;
- (*
- let string_iter (f: char -> unit) s =
- for i = 0 to String.length s do
- f s.[i]
- done
- ;;
- *)
-
- let filter () =
- raise Not_implemented; () ;;
-
- (** create a string of length len and sets each char of them to the result
- of applying f to the char's index *)
- let init len f =
- let str = String.create len in
- for i = 0 to len - 1 do
- str.[i] <- f i
- done;
- str
- ;;
-
- end
-
-module ZRandom =
- struct
-
- type ranges = (int * int) list
-
- let digit_range = [48, 57] ;;
- let alpha_upper_range = [65, 90] ;;
- let alpha_lower_range = [97, 122] ;;
- let alpha_range = alpha_upper_range @ alpha_lower_range ;;
- let alphanum_range = digit_range @ alpha_range ;;
- let word_range = alphanum_range @ [95, 95] ;; (* alphanum + '_' *)
-
- let rec ranges_are_sane = function
- | (min, max) :: tl ->
- if min > max || min < 0 || max > 255 then
- failwith (sprintf "ZRandom: invalid range %d .. %d" min max);
- ranges_are_sane tl
- | [] -> ()
- ;;
- let size_of_ranges = (* assumption: ranges are sane *)
- let rec aux acc = function
- | [] -> acc
- | ((min, max) as range) :: tl -> aux (acc + (max - min + 1)) tl
- in
- aux 0
- ;;
- let nth_in_ranges idx ranges = (* assumption: ranges are sane *)
- if ranges = [] then
- failwith "ZRandom: no range provided";
- let rec aux idx = function
- | [] -> assert false
- | (min, max) :: tl ->
- let nth = min + idx in
- if nth <= max then nth else aux (nth - max - 1) tl
- in
- aux idx ranges
- ;;
-
- (* low level for char and string *)
- let char' ranges =
- let int = Random.int (size_of_ranges ranges) in
- Char.chr (nth_in_ranges int ranges)
- ;;
-
- (** generate a random char inside provided ranges. Ranges are provided as
- a list of int pairs. Each pair represent an inclusive interval of possible
- character codes. Default range is [0, 255] *)
- let char ?(ranges = [0,255]) () =
- ranges_are_sane ranges;
- char' ranges
- ;;
-
- (** generate a string of random characters inside provided range *)
- let string ?(ranges = [0,255]) len =
- ranges_are_sane ranges;
- ZString.init len (fun _ -> char' ranges)
- ;;
-
- end
-
-module ZStream =
- struct
-
- (** map on streams. Beware that this function build stream using
- Stream.from. That kind of stream can't be mixed with ordinary streams *)
- let map f stream =
- Stream.from
- (fun _ -> try Some (f (Stream.next stream)) with Stream.Failure -> None)
- ;;
- (** fold on streams. Beware that this function build stream using
- Stream.from. That kind of stream can't be mixed with ordinary streams *)
- let rec fold f init stream =
- match (try Some (Stream.next stream) with Stream.Failure -> None) with
- | Some item -> fold f (f init item) stream
- | None -> init
- ;;
-
- (** given an input channel return the stream of its lines (without
- trailing new line) *)
- let of_inchan ic =
- Stream.from (fun _ -> try Some (input_line ic) with End_of_file -> None)
- ;;
-
- end
-
- (** fold_left on input channel lines *)
-let rec fold_in f init ic =
- match (try Some (input_line ic) with End_of_file -> None) with
- | Some l -> fold_in f (f init l) ic
- | None -> init
-;;
-
- (** iter on input channel lines *)
-let iter_in f = fold_in (fun _ line -> f line) () ;;
-
- (** map on input channel lines *)
-let map_in f ic = List.rev (fold_in (fun acc line -> f line :: acc) [] ic) ;;
-
- (** return list of lines read from an input channel *)
-let input_lines ic = List.rev (fold_in (fun acc line -> line :: acc) [] ic) ;;
-
- (** read all data available on an input channel and return them as a string *)
-let input_all =
- let strlen = 8192 in
- let buflen = 8192 * 2 in
- let str = String.create strlen in
- fun ic ->
- let buf = Buffer.create buflen in
- let rec input' () =
- let bytes = input ic str 0 strlen in
- if bytes = 0 then (* EOF *)
- Buffer.contents buf
- else begin
- Buffer.add_substring buf str 0 bytes;
- input' ()
- end
- in
- input' ()
-;;
-
- (** write a list of lines to an output channel. Newline is added at the end of
- each line *)
-let rec output_lines lines oc =
- match lines with
- | [] -> ()
- | hd::tl ->
- output_string oc (hd ^ newline);
- output_lines tl oc
-;;
-
- (** read_lines on stdin *)
-let read_lines () = input_lines stdin ;;
- (** read_all on stdin *)
-let read_all () = input_all stdin ;;
-
- (** Some constructor inverse *)
-let unsome = function
- | Some x -> x
- | None -> raise (Invalid_argument "Zack.unsome")
-;;
-
-module Array = ZArray ;;
-module Dbm = ZDbm ;;
-module Hashtbl = ZHashtbl ;;
-module List = ZList ;;
-module Logic = ZLogic ;;
-module Random = ZRandom ;;
-module Stream = ZStream ;;
-module String = ZString ;;
-module Sys = ZSys ;;
-module Unix = ZUnix ;;
-
projects / helm.git / blobdiff