From: Stefano Zacchiroli <zack@upsilon.cc>
Date: Mon, 7 Apr 2003 13:13:02 +0000 (+0000)
Subject: added zack's helpers
X-Git-Tag: before_refactoring~45
X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=807220be0830826e99c4b74c5d6b41fe5ad2293e;p=helm.git

added zack's helpers
---

diff --git a/helm/http_getter/zack.ml b/helm/http_getter/zack.ml
new file mode 100644
index 000000000..bc40f0c05
--- /dev/null
+++ b/helm/http_getter/zack.ml
@@ -0,0 +1,475 @@
+(*
+ * 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 ;;
+
diff --git a/helm/http_getter/zack.mli b/helm/http_getter/zack.mli
new file mode 100644
index 000000000..581bcfd05
--- /dev/null
+++ b/helm/http_getter/zack.mli
@@ -0,0 +1,149 @@
+(*
+ * 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.
+ *)
+
+exception Not_implemented
+
+val fold_in : ('a -> string -> 'a) -> 'a -> in_channel -> 'a
+val iter_in : (string -> unit) -> in_channel -> unit
+val map_in : (string -> 'a) -> in_channel -> 'a list
+val input_lines : in_channel -> string list
+val input_all : in_channel -> string
+val output_lines : string list -> out_channel -> unit
+val read_lines : unit -> string list
+val read_all : unit -> string
+val unsome : 'a option -> 'a
+
+module Array :
+  sig
+    val index : ('a -> bool) -> 'a array -> int
+    val find : ('a -> bool) -> 'a array -> 'a
+
+    val exists : ('a -> bool) -> 'a array -> bool
+    val for_all : ('a -> bool) -> 'a array -> bool
+
+    val filter : ('a -> bool) -> 'a array -> 'a array
+
+(*     val lrotate : ?step:int -> 'a array -> 'a array *)
+(*     val rrotate : ?step:int -> 'a array -> 'a array *)
+  end
+
+module Dbm :
+  sig
+    val fold : ('a -> string -> string -> 'a) -> 'a -> Dbm.t -> 'a
+  end
+
+module Hashtbl :
+  sig
+    val keys : ('a, 'b) Hashtbl.t -> 'a list
+    val values : ('a, 'b) Hashtbl.t -> 'b list
+
+    val remove_all : ('a, 'b) Hashtbl.t -> 'a -> unit
+  end
+
+module List :
+  sig
+    val map' : ('a -> 'b) -> 'a list -> 'b list
+    val map_if : ('a -> 'b) -> ('a -> bool) -> 'a list -> 'b list
+    val map_if' : ('a -> 'b) -> ('a -> bool) -> 'a list -> 'b list
+
+    val assoc_all : 'a -> ('a * 'b) list -> 'b list
+    val assq_all : 'a -> ('a * 'b) list -> 'b list
+
+    val lrotate : 'a list -> 'a list
+    val rrotate : 'a list -> 'a list
+(*     val List.lrotate: ?step:int -> 'a list -> 'a list *)
+(*     val List.rrotate: ?step:int -> 'a list -> 'a list *)
+  end
+
+module Logic :
+  sig
+    val non : ('a -> bool) -> 'a -> bool
+    val conj : ('a -> bool) -> ('a -> bool) -> 'a -> bool
+    val disj : ('a -> bool) -> ('a -> bool) -> 'a -> bool
+    val imply : ('a -> bool) -> ('a -> bool) -> 'a -> bool
+
+    val ( &&& ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool
+    val ( ||| ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool
+    val ( => ) : ('a -> bool) -> ('a -> bool) -> 'a -> bool
+  end
+
+module Random :
+  sig
+    val digit_range : (int * int) list
+    val alpha_upper_range : (int * int) list
+    val alpha_lower_range : (int * int) list
+    val alpha_range : (int * int) list
+    val alphanum_range : (int * int) list
+    val word_range : (int * int) list
+
+    val char : ?ranges:(int * int) list -> unit -> char
+    val string : ?ranges:(int * int) list -> int -> string
+  end
+
+module Stream :
+  sig
+    val map : ('a -> 'b) -> 'a Stream.t -> 'b Stream.t
+    val fold : ('a -> 'b -> 'a) -> 'a -> 'b Stream.t -> 'a
+
+    val of_inchan : in_channel -> string Stream.t
+  end
+
+module String :
+  sig
+    val explode : string -> char list
+    val implode : char list -> string
+
+    val chomp : string -> string
+
+    val map : (char -> char) -> string -> unit
+    val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a
+(*     val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a *)
+    val iter : (char -> unit) -> string -> unit
+(*     val filter : (char -> bool) -> string -> string *)
+
+    val init : int -> (int -> char) -> string
+  end
+
+(*
+module Sys :
+  sig
+    val copy : src:string -> dst:string -> unit
+  end
+*)
+
+module Unix :
+  sig
+(*     val mkdir : ?parents:bool -> string -> unit *)
+
+    val is_regular : ?follow_symlink:bool -> string -> bool
+    val is_directory : ?follow_symlink:bool -> string -> bool
+    val is_chardev : ?follow_symlink:bool -> string -> bool
+    val is_blockdev : ?follow_symlink:bool -> string -> bool
+    val is_symlink : ?follow_symlink:bool -> string -> bool
+    val is_fifo : ?follow_symlink:bool -> string -> bool
+    val is_socket : ?follow_symlink:bool -> string -> bool
+
+    val size : ?follow_symlink:bool -> string -> int
+
+    val ls : string -> string list
+  end
+