(*
 * 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 ;;