(* -*- caml -*- *)

(* @@PLEAC@@_NAME *)
(* @@SKIP@@ Objective CAML @@SKIP@@ *)

(* @@PLEAC@@_WEB *)
(* @@SKIP@@ http://www.ocaml.org/ @@SKIP@@ *)

(* @@PLEAC@@_APPENDIX *)
open Printf

let sort_ l = List.sort compare l

let rec uniq = function
  | [] -> []
  | e::l -> if List.mem e l then uniq l else e :: uniq l

let rec filter_some = function
  | [] -> []
  | Some e :: l -> e :: filter_some l
  | None :: l -> filter_some l

let rec all_assoc e = function
  | [] -> []
  | (e',v) :: l when e=e' -> v :: all_assoc e l
  | _ :: l -> all_assoc e l

(* fold_left alike. note that it is tail recursive *)
let rec fold_lines f init chan =
  match
    try Some (input_line chan)
    with End_of_file -> None
  with
  | Some line -> fold_lines f (f init line) chan
  | None -> init

let iter_lines f chan = fold_lines (fun _ line -> f line) () chan  
let readlines chan = List.rev (fold_lines (fun l e -> e::l) [] chan)
;;
(* @@PLEAC@@_1.0 *)
(*---------------------------*)
let string = "\\n"                  (* two characters, \ and an n*)
let string = "Jon 'Maddog' Orwant"  (* literal single quotes*)
(*---------------------------*)
let string = "\n"                     (* a "newline" character *)
let string = "Jon \"Maddog\" Orwant"  (* literal double quotes *)

let a = "
    This is a multiline here document
    terminated by one  double quote
    "
(* @@PLEAC@@_1.1 *)
let value = String.sub string offset count
let value = String.sub string offset (String.length string - offset)
(* or *)
let value = sub_end string offset
(* using *)
let sub_end string offset = String.sub string offset (String.length string - offset)

(*-----------------------------*)
(* get a 5-byte string, skip 3, then grab 2 8-byte strings, then the rest*)

(* split at 'sz' byte boundaries *)
let rec split_every_n_chars sz = function
  | "" -> []
  | s -> 
      try
        let (beg, rest) = String.sub s 0 sz, sub_end s sz in
        beg :: split_every_n_chars sz rest
      with _ -> [s]

let fivers = split_every_n_chars 5 string

(* chop string into individual characters *)
let chars = List.map (fun x -> x.[0]) (split_every_n_chars 1 string)

(*-----------------------------*)
let string = "This is what you have";;
(* Indexes are left to right. There is no possibility to index *)
(* directly from right to left *)
(* "T" *)
let first  = String.sub string 0 1   
(* "is" *)
let start  = String.sub string 5 2 
(* "you have" *)
let rest   = String.sub string 13 (String.length string - 13)   
(* "e" *)
let last   = String.sub string (String.length string - 1) 1
(* "have" *)
let theend = String.sub string (String.length string - 4) 4  
(* "you" *)
let piece  = String.sub string (String.length string - 8) 3
(*-----------------------------*)
let string = "This is what you have";;
Printf.printf "%s" string ;
(*This is what you have*)

(* Change "is" to "wasn't"*)
let string = (String.sub string 0 5) ^ "wasn't" ^ sub_end string 7
(*This wasn't what you have *)   

(*This wasn't wonderous *)
let string = (String.sub string 0 (String.length string -12)) ^
   "ondrous";;

(* delete first character *)
let string = String.sub string 1 (String.length string - 1)
(*his wasn't wondrous*)

(* delete last 10 characters *)
let string = String.sub string 0 (String.length string -10)
(*his wasn'*)
(*-----------------------------*)

(* @@PLEAC@@_1.2 *)

(* Because OCaml doesn't have the same notion of truth or definedness as Perl,
 * most of these examples just can't be done as they are in Perl.  Some can be
 * approximated via the use of options, but remember, unbound variables are not
 * automatically assigned the value of None -- the variable has to have been
 * explicitly bound to None (or Some x) beforehand.
*)

(* use b if b is not None, else use c *)
let a = match b with None -> c | _ -> b;;

(* set x to y if x is currently None *)
let x = match x with None -> y | _ -> x;;

(* Note that these are much closer to Perls notion of definedness than truth *)

(* We can set foo to either bar or "DEFAULT VALUE" in one of two ways *)
(* keep foo as a string option *)
let foo = match bar with Some x -> bar | _ -> Some "DEFAULT VALUE";;

(* Use foo as a string *)
let foo = match bar with Some x -> x | _ -> "DEFAULT VALUE";;

let dir = if Array.length Sys.argv > 1 then argv.(1) else "/tmp";;

(* None of the other examples really make sense in OCaml terms... *)

(* @@PLEAC@@_1.3 *)
(*-----------------------------*)
let var1, var2 = var2, var1
(*-----------------------------*)
let temp    = a
let a       = b
let b       = temp
(*-----------------------------*)
let a       = "alpha"
let b       = "omega"
let a, b = b, a      (* the first shall be last -- and versa vice *)
(*-----------------------------*)
let alpha, beta, production = "January", "March", "August"
(* move beta       to alpha,
 * move production to beta,
 * move alpha      to production *)
let alpha, beta, production = beta, production, alpha
(*-----------------------------*)

(* @@PLEAC@@_1.4 *)
(*-----------------------------*)
let num  = Char.code char
let char = Char.chr num
(*-----------------------------*)
(* char and int are distinct datatypes in OCaml *)
printf "Number %d is character %c\n" num (Char.chr num)
(* Number 101 is character e *)
(*-----------------------------*)
(* convert string to list of chars *)
let explode s =
  let rec f acc = function
    | -1 -> acc
    | k -> f (s.[k] :: acc) (k - 1)
  in f [] (String.length s - 1)

(* convert list of chars to string *)
let implode l =
  let s = String.create (List.length l) in
  let rec f n = function
    | x :: xs -> s.[n] <- x; f (n + 1) xs
    | [] -> s
  in f 0 l

(* ascii is list of ints. *)
let ascii = List.map Char.code (explode string)
let string = implode (List.map Char.ord ascii)
(*-----------------------------*)
let ascii_value = Char.code 'e'    (* now 101 *)
let character   = Char.chr 101     (* now 'e' *)
(*-----------------------------*)
printf "Number %d is character %c\n" 101 (Char.chr 101)
(*-----------------------------*)
let ascii_character_numbers = List.map Char.code (explode "sample");;
List.iter (printf "%d ") ascii_character_numbers;
printf "\n"
115 97 109 112 108 101

let word = implode (List.map Char.chr ascii_character_numbers)
let word = implode (List.map Char.chr [115; 97; 109; 112; 108; 101]);; (* same *)
printf "%s\n" word
sample
(*-----------------------------*)
let hal = "HAL"
let ascii = List.map Char.code (explode hal)
let ascii = List.map (( + ) 1) ascii  (* add one to each ASCII value *)
let ibm = implode (List.map Char.chr ascii);;
printf "%s\n" ibm             (* prints "IBM" *)
(*-----------------------------*)

(* @@PLEAC@@_1.5 *)

(* One can split a string into an array of character, or corresponding ASCII
 * codes as follows, but this is not necessary to process the strings a
 * character at a time: *)

let array_of_chars = Array.init (String.length s) (fun i -> s.[i]);;
let array_of_codes = Array.init (String.length s) (fun i -> Char.code s.[i]);;

(* or one can just use String.iter *)
String.iter 
  (fun i -> (*do something with s.[i], the ith char of the string*)) s;;

(* The following function can be used to return a list of all unique keys in a
 * hashtable *)

let keys h =
  let k = Hashtbl.fold (fun k v b -> k::b) h [] in
  (* filter out duplicates *)
  List.fold_left (fun b x -> if List.mem x b then b else x::b) [] k;;

(* and this function is a shorthand for adding a key,value pair to a hashtable
*)

let ( <<+ ) h (k,v) = Hashtbl.add h k v;;

let seen = Hashtbl.create 13;;
let s = "an apple a day";;
let array_of_chars = Array.init (String.length s) (fun i -> s.[i]);;
Array.iter (fun x -> seen <<+ (x,1)) array_of_chars;
print_string "unique chars are:\t";
List.iter print_char (List.sort compare (keys seen));
print_newline ();;

(* or, without the unnecessary and innefficient step of converting the string
 * into an array of chars *)
let seen = Hashtbl.create 13;;
let s = "an apple a day";;
String.iter (fun x -> seen <<+ (x,1)) s;
print_string "unique chars are:\t";
List.iter print_char (List.sort compare (keys seen));
print_newline ();;

(* To compute the simple 31-bit checksum of a string *)
let cksum s =
  let sum = ref 0 in
  String.iter (fun x -> sum := !sum + (Char.code x)) s;
  !sum;;
(*
# cksum "an apple a day";;
- : int = 1248
*)

(* to emulate the SysV 16-bit checksum, we will first write two routines sort of
 * similar to Perl's (<>), that will return the contents of a file either as a
 * list of strings or as a single string - not that the list of strings version
 * throws away the \n at the end of each line *)

let slurp_to_list filename =
  let ic = open_in filename and
  l = ref [] in
  let rec loop () =
    let line = input_line ic in
    l := line::!l;
    loop () in
  try loop () with End_of_file -> close_in ic; List.rev !l;;

let slurp_to_string filename =
  let ic = open_in filename and
  buf = Buffer.create 4096 in
  let rec loop () =
    let line = input_line ic in
    Buffer.add_string buf line;
    Buffer.add_string buf "\n";
    loop () in
  try loop () with End_of_file -> close_in ic; Buffer.contents buf;;

let cksum16 fn =
  let addString sum s =
    let sm = ref sum in
    String.iter (fun c -> sm := !sm + (Char.code c)) (s ^ "\n"); 
    !sm mod 65537 (* 2^16 - 1 *)in
  List.fold_left addString 0 (slurp_to_list fn);;

(* or *)
let cksum16 fn = 
  let sum = ref 0
  and s = slurp_to_string fn in
  String.iter (fun c -> sum := (!sum + (Char.code c)) mod 65537) s;
  !sum;;



(* Note: slowcat as written is meant to be run from the command line, not in the
 * toplevel *)

#!/usr/local/bin/ocaml
(* slowcat - emulate a   s l o w  line printer *)
(* usage: slowcat [-DELAY] [files ...] *)
#load "unix.cma";;

(* make sure you have the code for the slurp_to_string function in this file as
 * well... *)

let _ =
  let delay,fs = try (float_of_string Sys.argv.(1)),2 with Failure _ -> 1.,1 in
  let files = Array.sub Sys.argv fs (Array.length Sys.argv - fs) in
  let print_file f =
    let s = slurp_to_string f in
    String.iter 
      (fun c -> 
        print_char c;
        ignore(Unix.select [] [] [] (0.005 *. delay))) s in
  Array.iter print_file files;;

(* @@PLEAC@@_1.6 *)

(* To flip the characters of a string, we can use a for loop.
 * Note that this version does not destructively update the string *)

let reverse s = 
  let len = String.length s - 1 in
  let s' = String.create (len + 1) in
  for i = 0 to len do
    s'.[i] <- s.[len - i]
  done;
  s';;

(* to modify the string in place, we can use the following function *)
let reverse_in_place s =
  let len = String.length s - 1 in
  for i = 0 to (len + 1)/ 2 - 1 do
    let t = s.[i] in
    s.[i] <- s.[len - i];
    s.[len - i] <- t
  done;;

(* To reverse the words in a string, we can use String.concat, Str.split and
 * List.rev.  Note that this requires us to load in the Str module -- 
 * use `#load "str.cma"' in* the toplevel, or be sure to include str.cma in the
 * list of object files when compiling your code.  E.g.:
 *      ocamlc other options str.cma other files   -or-
 *      ocamlopt other options str.cmxa other files 
*)

let reverse_words s =
  String.concat " " (List.rev (Str.split (Str.regexp " ") s));;

let is_palindrome s = 
  s = reverse s;;

(* We do need to do a bit more work that Perl to find the big palindromes in
 * /usr/share/dict/words ... *)

let findBigPals () = 
  let words = open_in "/usr/share/dict/words" in
  let rec loop () =
    let w = input_line words in
    if String.length w > 5 && w = reverse w then
      print_endline w;
    loop () in
  try loop () with End_of_file -> close_in words;;

(* @@PLEAC@@_1.7 *)

let expand_tabs ?(spaces = 8) s =
  Str.global_replace (Str.regexp "\t") (String.make spaces ' ') s;;

let compress_tabs ?(spaces = 8) s = 
  Str.global_replace (Str.regexp (String.make spaces ' ')) "\t" s;;

(*
# let st = "\tyo baby!\n\t\tWhat the shizzle?\t(Mack)";;
val st : string = "\tyo baby!\n\t\tWhat the shizzle?\t(Mack)"
# let etst = expand_tabs st;;
val etst : string =
  "        yo baby!\n                What the shizzle?        (Mack)"
# let etst = expand_tabs ~spaces:4 st;;
val etst : string = "    yo baby!\n        What the shizzle?    (Mack)"
# let etst = expand_tabs ~spaces:8 st;;
val etst : string =
  "        yo baby!\n                What the shizzle?        (Mack)"
# let rest = compress_tabs etst;;
val rest : string = "\tyo baby!\n\t\tWhat the shizzle?\t(Mack)"
# let rest = compress_tabs ~spaces:4 etst;;
val rest : string = "\t\tyo baby!\n\t\t\t\tWhat the shizzle?\t\t(Mack)"
# let rest = compress_tabs ~spaces:3 etst;;
val rest : string =
  "\t\t  yo baby!\n\t\t\t\t\t What the shizzle?\t\t  (Mack)"
*)

(* @@PLEAC@@_1.8 *)
(* As far as I know there is no way to do this in OCaml due to
   type-safety contraints built into the OCaml compiler -- it may be
   feasible with *much* juju, but don't expect to see this anytime
   soon...

   If you don't mind supplying a data structure rather than capturing
   local variables, you can use Buffer.add_substitute to get a similar
   effect. *)

let buffer = Buffer.create 16
let vars = [("debt", "$700 billion")]
let () =
  Buffer.add_substitute buffer
    (fun name -> List.assoc name vars)
    "You owe $debt to me.";
  print_endline (Buffer.contents buffer)

(* @@PLEAC@@_1.9 *)

(* Just use the String module's uppercase, lowercase, capitalize and
 * uncapitalize *)

let big = String.uppercase little;;    (* "bo peep" -> "BO PEEP" *)
let little = String.lowercase big;;    (* "JOHN" -> "john" *)
let big = String.capitalize little;;   (* "bo" -> "Bo" *)
let little = String.uncapitalize big;; (* "BoPeep" -> "boPeep" *)

(* Capitalize each word's first character, downcase the rest *)
let text = "thIS is a loNG liNE";;
let text = String.capitalize (String.lowercase text);;
print_endline text;;

(*
This is a long line
*)

(* To do case insensitive comparisons *)
if String.uppercase a = String.uppercase b then
  print_endline "a and b are the same\n";;

let randcap fn =
  let s = slurp_to_string fn in
  for i = 0 to String.length s - 1 do
    if Random.int 100 < 20 then
      String.blit (String.capitalize (String.sub s i 1)) 0 s  i 1
  done;
  print_string s;;


(*
# randcap "/etc/passwd";;

##
# User DatAbAse
# 
# Note That this fIle is consuLTed wHen the sysTeM Is runninG In single-user
# modE.  At other times this iNformAtion is handlEd by one or moRe oF:
# lOokupD DIrectorYServicEs  
# By default, lOOkupd getS inFormaTion frOm NetInFo, so thiS fIle will 
# not be cOnsultEd unless you hAvE cHaNged LOokupd's COnfiguratiOn.
# This fiLe is usEd while in siNgle UseR Mode.
#
# TO Use this file for noRmal aUthEnticatIon, you may eNable it With
# /ApPlicatiOns/Utilities/DiRectory AccEss.
##

< ... snip ... >
*)

(* @@PLEAC@@_1.10 *)

(* Again, because of OCaml's type-safe nature, actual interpolation cannot be
 * done inside of strings -- one must use either string concatenation or sprintf
 * to get the results we're looking for *)

let phrase = "I have " ^ (string_of_int (n+1)) ^ " guanacos.";;
let prhase = sprintf "I have %d guanacos." (n+1);;

(* @@PLEAC@@_1.11 *)
#load "str.cma";;
let var =  Str.global_replace (Str.regexp "^[\t ]+") "" "\
    your text
    goes here
";;

(* @@PLEAC@@_1.12 *)

(* We can emulate the Perl wrap function with the following function *)
let wrap width s =
  let l = Str.split (Str.regexp " ") s in
  Format.pp_set_margin Format.str_formatter width;
  Format.pp_open_box Format.str_formatter 0;
  List.iter 
    (fun x -> 
      Format.pp_print_string Format.str_formatter x;
      Format.pp_print_break Format.str_formatter 1 0;) l;
  Format.flush_str_formatter ();;

(*
# let st = "May I say how lovely you are looking today... this wrapping has done wonders for your figure!\n";;
val st : string =
  "May I say how lovely you are looking today... this wrapping has done wonders for your figure!\n"

# print_string (wrap 50 st);;
May I say how lovely you are looking today...
this wrapping has done wonders for your figure!

# print_string (wrap 30 st);;
May I say how lovely you are
looking today... this
wrapping has done wonders for
your figure!
*)

(* Note that this version doesn't allow you to specify an opening or standard
 * indentation (I am having trouble getting the Format module to behave as I
 * think it should...).  However, if one only wants to print spaces there
 * instead of arbitrary line leaders, we can use the following version *)

let wrap ?(lead=0) ?(indent=0) width s =
  let l = Str.split (Str.regexp " ") s in
  Format.pp_set_margin Format.str_formatter width;
  Format.pp_open_box Format.str_formatter 0;
  Format.pp_print_break Format.str_formatter lead indent;
  List.iter 
    (fun x -> 
      Format.pp_print_string Format.str_formatter x;
      Format.pp_print_break Format.str_formatter 1 indent;) l;
  Format.flush_str_formatter ();;

(*
# print_string (wrap 20 st);;
May I say how
lovely you are
looking today...
this wrapping has
done wonders for
your figure!
 - : unit = ()

# print_string (wrap ~lead:6 ~indent:2 20 st);;
      May I say how
  lovely you are
  looking today...
  this wrapping has
  done wonders for
  your figure!

# print_string (wrap ~lead:2 20 st);;
  May I say how
lovely you are
looking today...
this wrapping has
done wonders for
your figure!
*)

(* @@PLEAC@@_1.13 *)
(*
** The Str module is deistributed with the standard Ocaml compiler
** suit but it is not automatically pulled in by the command line
** interpreter or the compilers.
**
** The "#load" line is only needed if you are running this in the 
** command interpretter.
**
** If you are using either of the ocaml compilers, you will need 
** to remove the "#load" line and link in str.cmxa in the final 
** compile command.
*)

#load "str.cma" ;;

open Str

let escape charlist str =
        let rx = Str.regexp ("\\([" ^ charlist ^ "]\\)") in
        Str.global_replace rx "\\\\\\1" str

let text = "Mom said, \"Don't do that.\"" ;;
print_endline text ;;

let text = escape "'\"" text ;;
print_endline text ;;

(* @@PLEAC@@_1.14 *)

let trim s =
  let s' = Str.replace_first (Str.regexp "^[ \t\n]+") "" s in
  Str.replace_first (Str.regexp "[ \t\n]+$") "" s';;

let chop s =
  if s = "" then s else String.sub s 0 (String.length s - 1);;

let chomp ?(c='\n') s =
  if s = "" then s else
    let len = String.length s - 1 in
    if s.[len] = c then String.sub s 0 len else s;;

(* @@PLEAC@@_1.15 *)

let parse_csv =
  let regexp = Str.regexp (String.concat "\\|" [
                             "\"\\([^\"\\\\]*\\(\\\\.[^\"\\\\]*\\)*\\)\",?";
                             "\\([^,]+\\),?";
                             ",";
                           ]) in
  fun text ->
    let rec loop start result =
      if Str.string_match regexp text start then
        let result =
          (try Str.matched_group 1 text with Not_found ->
             try Str.matched_group 3 text with Not_found ->
               "") :: result in
        loop (Str.match_end ()) result
      else
        result in
    List.rev ((if
                 try String.rindex text ',' = String.length text - 1
                 with Not_found -> false
               then [""] else [])
              @ loop 0 [])

let line = "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall, Larry\",\"a \\\"glug\\\" bit,\",5,\"Error, Core Dumped\""
let () =
  Array.iteri
    (fun i x -> Printf.printf "%d : %s\n" i x)
    (Array.of_list (parse_csv line))

(* @@PLEAC@@_1.16 *)

let soundex =
  let code_1 = Char.code '1' in
  let code_A = Char.code 'A' in
  let code_Z = Char.code 'Z' in

  let trans = Array.make (code_Z - code_A + 1) 0 in
  let add_letters number letters =
    let add letter =
      trans.(Char.code letter - code_A) <- (number + code_1) in
    String.iter add letters in
  Array.iteri add_letters [| "BFPV"; "CGJKQSXZ"; "DT"; "L"; "MN"; "R" |];

  fun ?(length=4) s ->
    let slength = String.length s in
    let soundex = String.make length '0' in
    let rec loop i j last =
      if i < slength && j < length then begin
        let code = Char.code (Char.uppercase s.[i]) in
        if code >= code_A && code <= code_Z
        then (if j = 0
              then (soundex.[j] <- Char.chr code;
                    loop (i + 1) (j + 1) trans.(code - code_A))
              else (match trans.(code - code_A) with
                      | 0 -> loop (i + 1) j 0
                      | code when code <> last ->
                          soundex.[j] <- Char.chr code;
                          loop (i + 1) (j + 1) code
                      | _ -> loop (i + 1) j last))
        else loop (i + 1) j last
      end in
    loop 0 0 0;
    soundex

(*-----------------------------*)

let code = soundex string;;
let codes = List.map soundex list;;

(*-----------------------------*)

#load "str.cma"
#load "unix.cma"

let () =
  print_string "Lookup user: ";
  let user = read_line () in
  if user <> "" then begin
    let name_code = soundex user in
    let regexp = Str.regexp ("\\([a-zA-Z_0-9]+\\)[^,]*[^a-zA-Z_0-9]+"
                             ^ "\\([a-zA-Z_0-9]+\\)") in
    let passwd = open_in "/etc/passwd" in
    try
      while true do
        let line = input_line passwd in
        let name = String.sub line 0 (String.index line ':') in
        let {Unix.pw_gecos=gecos} = Unix.getpwnam name in
        let (firstname, lastname) =
          if Str.string_match regexp gecos 0
          then (Str.matched_group 1 gecos, Str.matched_group 2 gecos)
          else ("", "") in
        if (name_code = soundex name
            || name_code = soundex lastname
            || name_code = soundex firstname)
        then Printf.printf "%s: %s %s\n" name firstname lastname
      done
    with End_of_file ->
      close_in passwd
  end

(* @@PLEAC@@_1.17 *)
(* fixstyle - switch first set of data strings to second set *)
#load "str.cma";;

let data = Hashtbl.create 0
let keys = ref []
let () =
  let ( => ) key value =
    keys := key :: !keys;
    Hashtbl.replace data key value in
  (
    "analysed"       => "analyzed";
    "built-in"       => "builtin";
    "chastized"      => "chastised";
    "commandline"    => "command-line";
    "de-allocate"    => "deallocate";
    "dropin"         => "drop-in";
    "hardcode"       => "hard-code";
    "meta-data"      => "metadata";
    "multicharacter" => "multi-character";
    "multiway"       => "multi-way";
    "non-empty"      => "nonempty";
    "non-profit"     => "nonprofit";
    "non-trappable"  => "nontrappable";
    "pre-define"     => "predefine";
    "preextend"      => "pre-extend";
    "re-compiling"   => "recompiling";
    "reenter"        => "re-enter";
    "turnkey"        => "turn-key";
  )

let pattern_text =
  "\\(" ^ (String.concat "\\|" (List.map Str.quote !keys)) ^ "\\)"
let pattern = Str.regexp pattern_text

let args = ref (List.tl (Array.to_list Sys.argv))

let verbose =
  match !args with
    | "-v" :: rest -> args := rest; true
    | _ -> false

let () =
  if !args = []
  then (Printf.eprintf "%s: reading from stdin\n" Sys.argv.(0);
        args := ["-"])

let replace_all text line file =
  String.concat ""
    (List.map
       (function
          | Str.Text s -> s
          | Str.Delim s ->
              if verbose
              then Printf.eprintf "%s => %s at %s line %d.\n"
                s (Hashtbl.find data s) file line;
              Hashtbl.find data s)
       (Str.full_split pattern text))

let () =
  List.iter
    (fun file ->
       let in_channel =
         if file = "-"
         then stdin
         else open_in file in
       let line = ref 0 in
       try
         while true do
           let text = input_line in_channel in
           incr line;
           print_endline (replace_all text !line file)
         done
       with End_of_file ->
         close_in in_channel)
    !args

(* @@PLEAC@@_1.18 *)
#!/usr/bin/ocaml
(* psgrep - print selected lines of ps output by
            compiling user queries into code *)
#load "unix.cma";;

(* Warning: In order to closely approximate the original recipe, this
   example performs dynamic evaluation using the toplevel. This mechanism
   is undocumented and not type-safe. Use at your own risk.

   The "psgrep" utility, defined below, can be used to filter the results
   of the command-line "ps" program. Here are some examples:

   Processes whose command names start with "sh":

   % psgrep 'String.sub command 0 2 = "sh"'

   Processes running with a user ID below 10:

   % psgrep 'uid < 10'

   Login shells with active ttys:

   % psgrep "command.[0] = '-'" 'tty <> "?"'

   Processes running on pseudo-ttys:

   % psgrep 'String.contains "pqrst" tty.[0]'

   Non-superuser processes running detached:

   % psgrep 'uid > 0 && tty = "?"'

   Huge processes that aren't owned by the superuser:

   % psgrep 'vsz > 50000' 'uid <> 0'
*)

(* Eval recipe thanks to Clément Capel. *)
let () = Toploop.initialize_toplevel_env ()
let eval text = let lexbuf = (Lexing.from_string text) in
  let phrase = !Toploop.parse_toplevel_phrase lexbuf in
  ignore (Toploop.execute_phrase false Format.std_formatter phrase)
let get name = Obj.obj (Toploop.getvalue name)
let set name value = Toploop.setvalue name (Obj.repr value)

(* Type for "ps" results. *)
type ps =
    {f : int; uid : int; pid : int; ppid : int; pri : int; ni : string;
     vsz : int; rss : int; wchan : string; stat : string; tty : string;
     time : string; command : string}

(* Based on the GNU ps from Debian Linux. Other OSs will most likely
   require changes to this format. *)
let parse_ps_line line =
  Scanf.sscanf line "%d %d %d %d %d %s %d %d %6s %4s %10s %4s %s@\000"
    (fun f uid pid ppid pri ni vsz rss wchan stat tty time command ->
       {f=f; uid=uid; pid=pid; ppid=ppid; pri=pri; ni=ni;
        vsz=vsz; rss=rss; wchan=wchan; stat=stat; tty=tty;
        time=time; command=command})

let eval_predicate ps pred =
  (* Use "eval" to initialize each variable's name and type,
     then use "set" to set a value. *)
  eval "let f = 0;;";          set "f" ps.f;
  eval "let uid = 0;;";        set "uid" ps.uid;
  eval "let pid = 0;;";        set "pid" ps.pid;
  eval "let ppid = 0;;";       set "ppid" ps.ppid;
  eval "let pri = 0;;";        set "pri" ps.pri;
  eval "let ni = \"\";;";      set "ni" ps.ni;
  eval "let vsz = 0;;";        set "vsz" ps.vsz;
  eval "let rss = 0;;";        set "rss" ps.rss;
  eval "let wchan = \"\";;";   set "wchan" ps.wchan;
  eval "let stat = \"\";;";    set "stat" ps.stat;
  eval "let tty = \"\";;";     set "tty" ps.tty;
  eval "let time = \"\";;";    set "time" ps.time;
  eval "let command = \"\";;"; set "command" ps.command;
  (* Evaluate expression and return result as boolean. *)
  eval ("let result = (" ^ pred ^ ");;");
  (get "result" : bool)

exception TypeError of string
exception SyntaxError of string

let preds = List.tl (Array.to_list Sys.argv)
let () =
  if preds = []
  then (Printf.eprintf "usage: %s criterion ...
    Each criterion is an OCaml expression involving:
     f uid pid ppid pri ni vsz rss wchan stat tty time command
    All criteria must be met for a line to be printed.
" Sys.argv.(0); exit 0)

let () =
  let proc = Unix.open_process_in "ps wwaxl" in
  try
    print_endline (input_line proc);
    while true do
      let line = input_line proc in
      let ps = parse_ps_line line in
      if List.for_all
        (fun pred ->
           try eval_predicate ps pred
           with e ->
             (* Convert exceptions to strings to avoid depending on
                additional toplevel libraries. *)
             match Printexc.to_string e with
               | "Typecore.Error(_, _)" -> raise (TypeError pred)
               | "Syntaxerr.Error(_)"
               | "Lexer.Error(1, _)"
               | "Lexer.Error(_, _)" -> raise (SyntaxError pred)
               | "Misc.Fatal_error" -> failwith pred
               | _ -> raise e)
        preds
      then print_endline line
    done
  with
    | End_of_file ->
        ignore (Unix.close_process_in proc)
    | e ->
        ignore (Unix.close_process_in proc);
        raise e


(* @@PLEAC@@_2.1 *)

(* Something like this must be done differently in OCaml because of its
* type-safety.  Some of the tests will use regular expressions, but most won't *)
let has_NonDigits s = 
  try ignore (search_forward (regexp "[^0-9]") s); true
  with Not_found -> true;;
let is_NaturalNumber s =
  try let n = int_of_string s in n > 0 with Failure _ -> false;;
let is_Integer s =
  try ignore(int_of_string s); true with Failure _ -> false;;
let is_DecimalNumber s =
  try ignore(int_of_string s); true with Failure _ ->
    try let n = float_of_string s in (abs_float f) >= 1. 
    with Failure _ -> false;;
let is_CFloat s = 
  try ignore(float_of_string s); true 
  with Failure _ -> false;;

(* One of the above predicates can then be used as needed *)
if predicate s then
  (* is a number *)
else
  (* is not a number *)

(* @@PLEAC@@_2.2 *)
(*-----------------------------*)
(* equalStr num1 num2 accuracy returns true if num1 and num2 
   are equal to accuracy decimal places *)

(* done by converting to strings, a la the Perl example *)   
let equalStr num1 num2 accuracy =
  let p x = sprintf "%.*f" accuracy x in
  (p num1) = (p num2)

(* Done in a more or less sane way, i.e. treating them as numbers *)
let equal num1 num2 accuracy =
  let chop x = floor (x *. (10. ** (float accuracy))) in
  (chop num1) = (chop num2);;

(*-----------------------------*)
let wage = 536;;
let week = 40 * wage;;
Printf.printf "One week's wage is %.2f\n" ((float week) /. 100.);;
(*-----------------------------*)

(* @@PLEAC@@_2.3 *)
(*-----------------------------*)
let rounded digits fl = float_of_string (sprintf "%.*f" digits fl);;
(*-----------------------------*)
let a = 0.255;;
let b = float_of_string (sprintf "%.2f" a);;
let c = rounded 2 a;;
printf "Unrounded %f\nRounded %f\nOther rounded %f\n" a b c;;
printf "Unrounded %f\nRounded %.2f\nOther rounded %f\n" a c (rounded 2 a);;

(*
 * Unrounded 0.255000
 * Rounded 0.260000
 * Other rounded 0.260000
 * Unrounded 0.255000
 * Rounded 0.26
 * Other rounded 0.260000
 *)

(*-----------------------------*)
(* To "round" to the nearest integer, use ceil, floor, or truncate.  Note that
truncate converts the float to an integer, so a conversion back to a float is
necessary *)
let fs = [3.3; 3.5; 3.7; -. 3.3];;
printf "number\tint\tfloor\tceil\n";
List.iter 
  (fun x -> printf "%.1f\t%.1f\t%.1f\t%.1f\n" x (float (truncate x)) (floor x) (ceil x)) 
  fs;;

(*
 * number       int     floor   ceil
 * 3.3  3.0     3.0     4.0
 * 3.5  3.0     3.0     4.0
 * 3.7  3.0     3.0     4.0
 * -3.3 -3.0    -4.0    -3.0
 *) 
  
(* Or if you really want an integer in column 2 *)
printf "number\tint\tfloor\tceil\n";
List.iter 
  (fun x -> printf "%.1f\t%d\t%.1f\t%.1f\n" x (truncate x) (floor x) (ceil x)) 
  fs;;

(* 
 * number       int     floor   ceil
 * 3.3  3       3.0     4.0
 * 3.5  3       3.0     4.0
 * 3.7  3       3.0     4.0
 * -3.3 -3      -4.0    -3.0
 *) 

(* @@PLEAC@@_2.4 *)

(*-----------------------------*)
(* 
 * Two versions in each direction -- one to deal with decimal strings,
 * and the other to deal with decimal integers.  Binary numbers will
 * always be strings 
 *)

let binStr_of_decInt i =
  let rec strip_bits i s =
    match i with
      0 -> s
    | _ -> strip_bits (i lsr 1) ((string_of_int (i land 0x01)) ^ s) in
  strip_bits i "";;

let binStr_of_decStr i =
  let rec strip_bits i s =
    match i with
      0 -> s
    | _ -> strip_bits (i lsr 1) ((string_of_int (i land 0x01)) ^ s) in
  strip_bits (int_of_string i) "";;
(* Of course if you have binStr_of_decInt already, it's easier to just call
   binStr_of_decInt (int_of_string i) *)

(*-----------------------------*)
let decInt_of_binStr s =
  int_of_string ("0b" ^ s);;

let decStr_of_binStr s =
  string_of_int (int_of_string ("0b" ^ s));;
(*-----------------------------*)
let numInt = decInt_of_binStr "0110110";; (* numInt = 54 *)
let numInt = decStr_of_binStr "0110110";; (* numInt = "54" *)
let bin1 = binStr_of_decInt 54;;   (* bin1 = "110110" *)
let bin2 = binStr_of_decStr "54";; (* bin2 = "110110" *)
(*-----------------------------*)

(* @@PLEAC@@_2.5 *)
(*-----------------------------*)
(* The boring way is to use a for loop... *)
for i = low to high do
  (* Do your stuff *)
  (* Note, if what you want to do in the loop does not have have type unit, you
     need to wrap it with ignore, e.g. ignore (2 * i) *)
done

(* Or you skip the syntactic sugar and write it recursively yourself *)
let rec loop low high f =
  if low > high then
    ()
  else
    begin
      ignore (f low);
      loop (succ low) high f
    end;;

(* and now with stepsize different from 1 *)
let rec loopStep low high step f =
  if low > high then
    ()
  else
    begin
      ignore (f low);
      loopStep (low + step) high f
    end;;

    
(* Or, if you don't mind wasting space, you can use the useful iter functions
 *)
(* Array based *)
let makeArraySequence lo hi =
  Array.init (hi - lo + 1) (fun i -> i + lo);;
Array.iter ( your function here ) (makeArraySequence lo hi);;
  
(* List based *)
let makeListSequence lo hi = 
  let rec msHelper lo hi l =
    match (a - b) with
    0 -> b::l
        | _ -> msHelper a (b-1) (b::l) in
  msHelper lo hi [];;
List.iter ( your function here ) (makeListSequence lo hi);;
(*-----------------------------*)
printf "Infancy is: ";
for i = 0 to 2 do
  printf "%d " i
done;;

print_newline();;

printf "Toddling is: ";
loop 3 4 (fun i -> printf "%d " i);;

print_newline ();;

printf "Childhood is: ";
Array.iter (fun i -> printf "%d " i) (makeArraySequence 5 12);;

print_newline();;

(*
 * Infancy is: 0 1 2
 * Toddling is: 3 4
 * Childhood is: 5 6 7 8 9 10 11 12
 *) 
(*-----------------------------*)

(* @@PLEAC@@_2.6 *)
(* Based on Groovy version by Paul King. *)

let roman_map =
  [1000, "M"; 900, "CM"; 500, "D"; 400, "CD"; 100, "C"; 90, "XC";
   50,   "L"; 40,  "XL"; 10,  "X"; 9,   "IX"; 5,   "V"; 4,  "IV"; 1, "I"]

let roman arabic =
  let rec loop remains text map =
    match map with
      | (key, value) :: rest ->
          if remains >= key
          then loop (remains - key) (text ^ value) map
          else loop remains text rest
      | [] -> text in
  loop arabic "" roman_map

let arabic roman =
  let rec loop text sum map =
    match map with
      | (key, value) :: rest ->
          if (String.length text >= String.length value
              && String.sub text 0 (String.length value) = value)
          then (loop
                  (String.sub
                     text
                     (String.length value)
                     (String.length text - String.length value))
                  (sum + key)
                  map)
          else loop text sum rest
      | [] -> sum in
  loop (String.uppercase roman) 0 roman_map

(*-----------------------------*)

(* Alternative version by Ken Wakita. *)
let roman arabic =
  let nstr s n = String.concat "" (Array.to_list (Array.make n s)) in
  snd (List.fold_left
         (fun (arabic, roman) (arab, rom) ->
           arabic mod arab, roman ^ (nstr rom (arabic / arab)))
         (arabic, "")
         roman_map)

(*-----------------------------*)

let () =
  let roman_fifteen = roman 15 in
  Printf.printf "Roman for fifteen is %s\n" roman_fifteen;
  let arabic_fifteen = arabic roman_fifteen in
  Printf.printf "Converted back, %s is %d\n" roman_fifteen arabic_fifteen

(* Roman for fifteen is XV
   Converted back, XV is 15 *)

(* @@PLEAC@@_2.7 *)
(*-----------------------------*)
let random_int lo hi =
  (Random.int (hi - lo + 1)) + lo;;

let random_float lo hi =
  (Random.float (hi -. lo +. 1.)) +. lo;;
(*-----------------------------*)
let random_number = random_int 25 75 in
  printf "%d\n" random_number;;
(*-----------------------------*)
let elem = arr.(Random.int (Arry.length arr))
(*-----------------------------*)
let uc = Array.init 26 (fun i -> Char.chr (i+ (Char.code 'A')))
and lc = Array.init 26 (fun i -> Char.chr (i+ (Char.code 'a')))
and nums = Array.init 10 (fun i -> Char.chr (i + (Char.code '0')))
and puncs = [| '!'; '@'; '$'; '%'; '^'; '&'; '*' |];;
let chars = Array.concat [uc; lc; nums; puncs];;

(* to generate the random password as a char array *)
let password = Array.init 8 (fun i -> chars.(Random.int (Array.length chars)));;
(* to generate the random password as a string *)
let passString = 
  let s = String.make 8 ' ' in
  for i=0 to 7 do 
        s.[i] <- chars.(Random.int (Array.length chars))
  done;
  s;;

(*-----------------------------*)


(* @@PLEAC@@_2.8 *)
(* Seed the generator with an integer *)
Random.init 5;;

(* Seed the generator with an array of integers *)
Random.full_init [| 1; 2; 178653; -62 |];;

(* Automatically seed the generator in a system-dependant manner *)
Random.self_init ();;

(* @@PLEAC@@_2.9 *)
(* This requires installation of the third party the cryptokit library... *)
let prng = Cryptokit.Random.secure_rng;;
let buf = String.make 10 ' ';;
(* random_bytes buf pos len stores len random bytes in string buf, starting at position pos *)
prng#random_bytes buf 0 10;;  (* buf now contains 10 random bytes *)


(* @@PLEAC@@_2.10 *)
(* Note that this will return just one of the numbers, as returning either one
* or the other would requires always constructing an array or a list -- this
* just returns a float *)

let gaussianRand () =
  let rec getW () =
    let u1 = 2. *. (Random.float 1.) -. 1.
    and u2 = 2. *. (Random.float 1.) -. 1. in
    let w = u1 *. u1 +. u2 *. u2 in
    if w >= 0. then w,u1,u2 else getW () in
  let w,u1,u2 = getW () in
  let w = sqrt((-2. *. (log w)) /. w) in
  let g2 = u1 *. w
  and g1 = u2 *. w in
  g1;; 


(* note that because of the way dist is used, it makes the most sense to return
* it as a sorted associative list rather than another hash table *)
let weightToDist whash =
  let total = Hashtbl.fold (fun k v b -> b +. v) whash 0. in
  let dist = Hashtbl.fold (fun k v b -> (v,k)::b) whash [] in
  List.sort compare dist;;

let rec weightedRand dhash =
  let r = ref (Random.float 1.) in
  try 
    let v,k = List.find (fun (v,k) -> r := !r -. v; !r < 0.) dhash in k
  with Not_found -> weightedRand dhash;;  

let mean,dev = 25.,2. in
let salary = gaussianRand () *. sdev +. mean;;
printf "You have been hired at $%.2f\n" salary;;

(* @@PLEAC@@_2.11 *)
let pi = acos(-. 1.);;
let degrees_of_radians r = 180. *. r /. pi;;
let radians_of_degrees d = d *. pi /. 180.;;

let sinDeg d = sin (radians_of_degrees d);;
let cosDeg d = cos (radians_of_degrees d);;

(* @@PLEAC@@_2.12 *)
(* cos, sin, tan, acos, asin, atan, sinh, cosh and tanh are all standard
functions, but missing functions, such as secant can be construced in the usual
way... *)

let sec x = 1. /. (sin x);;

(* @@PLEAC@@_2.13 *)

(* to take a natural log, use the log function *)
let log_e = log 100.;;

(* to take a log to base 10, use the log10 function *)
let log_10 = log10 100.;;

(* to take a log to an arbitrary base, use traditional identities *)
let logB base x = (log x) /. (log base);;


(* @@PLEAC@@_2.14 *)
let mmult m1 m2 =
  let dim m =
    Array.length m,Array.length m.(0) in
  let r1,c1 = dim m1
  and r2,c2 = dim m2 in
  if c1 <> r2 then raise (Invalid_argument "Matrix dimensions don't match")
  else
    begin
      let dotP v1 v2 =
        let sum = ref 0. in
        for i = 0 to Array.length v1 - 1 do 
          sum := !sum +. (v1.(i) *. v2.(i))
        done;
        !sum in
      let row m i = m.(i)
      and col m i = Array.init (Array.length m) (fun r -> m.(r).(i)) in
      let res = Array.make_matrix r1 c2 0. in
      for r = 0 to pred r1 do
        for c = 0 to pred c2 do
          res.(r).(c) <- dotP (row m1 r) (col m2 c)
        done
      done;
      res
    end;;

(* @@PLEAC@@_2.15 *)
(*-----------------------------*)
(* c = a * b manually *)
type cplx = { real : float; imag : float; };;
let c = {real = a.real *. b.real -. a.imag *. b.imag;
         imag = a.imag *. b.real +. b.imag *. a.real};;
(*-----------------------------*)

(* c = a * b using the Complex module *)
open Complex;;

let c = Complex.mul a b;;
(* Note that we could have simply said let c = mul a b, but a later binding of a value to the
   name mul would render the complex mul invisible after that, Complex.mul is
   less ambiguous. *)
(*-----------------------------*)
let a = {real=3.; imag=5.};;
let b = {real=2.; imag=(-. 2.);}
let c = {real = a.real *. b.real -. a.imag *. b.imag;
         imag = a.imag *. b.real +. b.imag *. a.real};;
printf "c = %f+%fi\n" c.real c.imag;;
         
(* c = 16.000000+4.000000i *)

let a = {re=3.; im=5.};;
let b = {re=2.; im=(-. 2.);}
let c = mul a b;;
printf "c = %f+%fi\n" c.re c.im;;

(* c = 16.000000+4.000000i *)

let d = {re=3.; im=4.};;
let s = sqrt d in
printf "sqrt(%.2f+%.2fi) = %.2f+%.2fi\n" d.re d.im s.re s.im;;

(* sqrt(3.00+4.00i) = 2.00+1.00i *)

(* @@PLEAC@@_2.16 *)
(* Since integers and strings are very different things in OCaml, we will
   represent both octal and hexidecimal values as strings *)

let oct_of_hex h =
  Printf.sprintf "%0o" (int_of_string ("0x" ^ h));;
let hex_of_oct o =
  Printf.sprintf "%0x" (int_of_string ("0o" ^ o));;

(* One small problem is that OCaml integers are 31 (or 63) bit values, if you need
   something larger, you can use the following for a full 32 bits: *)
let oct_of_hex32 h =
  Printf.sprintf "%0lo" (Int32.of_string ("0x" ^ h));;
let hex_of_oct32 o =
  Printf.sprintf "%0lx" (Int32.of_string ("0o" ^ o));;

(* Or this for 64 bits: *)
let oct_of_hex64 h =
  Printf.sprintf "%0Lo" (Int64.of_string ("0x" ^ h));;
let hex_of_oct64 o =
  Printf.sprintf "%0Lx" (Int64.of_string ("0o" ^ o));;

(* For anything else you have to roll your own *)
let chopn n s =
  (* Chops strings into list of n byte substrings *)
  match s with 
    "" -> [""] (* avoids wierd edge case *)
    | _ ->
      let ex = (String.length s) mod n in
      let ss = if ex = 0 then s else ((String.make (n-ex) '0') ^ s) in
      let rec schopn x s l =
        match x with
          0 -> (String.sub s 0 n)::l
          | _ -> schopn (x-n) s ((String.sub s x n)::l) in
      schopn (String.length ss - n) ss [];;
        
let long_oct_of_hex h =
  let choppedH = chopn 6 h in
  let f x = int_of_string ("0x" ^ x) in
  String.concat "" (List.map (fun x -> Printf.sprintf "%08o" (f x)) choppedH);;

let long_hex_of_oct o =
  let choppedO = chopn 8 o in
  let f x = int_of_string ("0o" ^ x) in
  String.concat "" (List.map (fun x -> Printf.sprintf "%06x" (f x)) choppedO);;
(*-----------------------------*)
(* Since octal, hex and decimal are all the same internally, we don't need to do
    any explicit conversion *)
printf "Gimme a number in decimal, octal, or hex: ";;
let num = read_int ();;
printf "%d %x %o\n" num num num;;
(*-----------------------------*)
printf "Enter file permission in octal: ";;
let permissions = try read_int ()
with Failure message -> failwith "Exiting...\n";;
printf "The decimal value is %d\n" permissions;;

(* @@PLEAC@@_2.17 *)
(* This example requires the PCRE library, available at:
   http://www.ocaml.info/home/ocaml_sources.html#pcre-ocaml *)
#directory "+pcre";;
#load "pcre.cma";;

let rev_string s =
  let s' = String.copy s in
  let i = ref (String.length s - 1) in
  String.iter (fun c -> s'.[!i] <- c; decr i) s;
  s'

let commify s =
  rev_string
    (Pcre.replace ~pat:"(\\d\\d\\d)(?=\\d)(?!\\d*\\.)" ~templ:"$1,"
       (rev_string s))

(*-----------------------------*)

(* more reasonable web counter :-) *)
let () =
  Random.self_init ();
  let hits = Random.int32 2147483647l in
  Printf.printf "Your web page received %s accesses last month.\n"
    (commify (Int32.to_string hits))
(* Your web page received 1,670,658,439 accesses last month. *)

(* @@PLEAC@@_2.18 *)
(* Hardcoded examples can be done as follows: *)
Printf.printf "It took %d hour%s\n" n (if n <> 1 then "s" else "");;
Printf.printf "It took %d centur%s\n" n (if n <> 1 then "ies" else "y");;

(* For a more general solution *)
(* First define the rules *)
(* Note: the OS needs to support dynamic loading of C libraries for this *)
#load "str.cma";;

let rules = 
  List.map (fun x -> (Str.regexp (fst x)),(snd x))
    ["\\([psc]h\\)$\\|z$","\\0es";
     "\\(ff\\)$\\|\\(ey\\)$","\\0s";
     "f$","ves";
     "y$","ies";
     "ix$","ices";
     "ius$","ii";
     "[sx]$","\\0es";
     "non","na"];;

let f w x =
  ignore(Str.search_forward (fst x) w 0); 
  Str.replace_first (fst x) (snd x) w;;

let rec exn_map ex fn1 fn2 l =
  match l with
    [] -> fn2
  | h::t -> try (fn1 h) with ex -> exn_map ex fn1 fn2 t;;

let pluralize x = (* "wish" in *)
  exn_map Not_found (f x) (x ^ "s") rules;;
  
(* Note: This next example doesn't work on the odd cases *)
let nouns = ["fish"; "fly"; "ox"; "species"; "genus"; "phylum"; "cherub";
             "radius"; "jockey"; "index"; "matrix"; "mythos"; "phenomenon";
             "formula"];;
List.iter (fun x -> printf "One %s, two %s\n" x (pluralize x)) nouns;;
  

(* @@PLEAC@@_2.19 *)
(* Note: the OS needs to support dynamic loading of C libraries for this
   otherwise you will need to link the nums library with the code at comple time *)
#load "nums.cma";;
open Big_int;;

let cmd = [|"bigfact"; "8"; "9"; "96"; "2178"; 
            "239322000000000000000000"; "25000000000000000000000000"; "17"|];;

(* This will raise an exception if a nonnumeric string is in the argument list
*)
let argList = 
  Array.map big_int_of_string (Array.sub cmd 1 ((Array.length cmd) - 1));;

let factorize num = 
  let two = big_int_of_int 2 and four = big_int_of_int 4 in
  let rec genFactors (i,sqi) n fList =
    if eq_big_int n unit_big_int then fList else
    if lt_big_int n sqi then ((n,1)::fList) else
      let newn = ref n and fcount = ref 0 in
      while  (eq_big_int (mod_big_int !newn i) zero_big_int) do
          newn := div_big_int !newn i;
          fcount := !fcount + 1;
      done;
      let nexti,nextsqi = 
          if eq_big_int i two then
              (add_big_int i unit_big_int),
                (add_big_int sqi (add_big_int (mult_big_int i two)
                 unit_big_int))
          else
              (add_big_int i two),
                (add_big_int sqi (add_big_int (mult_big_int i four) two)) in
      genFactors (nexti,nextsqi) !newn (if !fcount = 0 then fList else
          ((i,!fcount)::fList)) in
   genFactors (two,four) num [];;

let _ = 
  Array.iter
  (fun n ->
    let l = factorize n in
    match l with
      [(x,1)] -> printf "%s\tPrime!\n" (string_of_big_int x)
    | _ -> 
        printf "%s\t" (string_of_big_int n);
        List.iter
          (fun (x,count) -> let sx = string_of_big_int x in
            if count = 1 then printf "%s " sx
            else printf "%s**%d " sx count)
          (List.rev l);
    print_newline()) argList;;


(* @@PLEAC@@_3.0 *)
(*-----------------------------*)

(* The unix module acts as a thin wrapper around the standard C
** Posix API. It comes standard with the Ocaml compiler but is
** not automatcially linked.
** If you are not using the command line interpreter, delete the
** the "#load" line
*)

#load "unix.cma" ;;
open Unix ;;
let t = Unix.localtime (Unix.time ());;

Printf.printf "Today is day %d of the current year.\n" t.tm_yday ;;

(* @@PLEAC@@_3.1 *)
(*-----------------------------*)
(* Finding todays date *)

let (day, month, year) = (t.tm_mday, t.tm_mon, t.tm_year) ;;
Printf.printf "The current date is %04d-%02d-%02d\n"
  (1900 + year) (month + 1) day ;;

(* @@PLEAC@@_3.2 *)
(*-----------------------------*)
(*
** Converting DMYHMS to Epoch Seconds
** Again, use the Unix module.
*)

(* For the local timezone *)
let ttup = mktime (localtime (time ())) ;;
Printf.printf "Epoch Seconds (local): %.0f\n" (fst ttup) ;;

(* For UTC *)
let ttup = mktime (gmtime (time ())) ;;
Printf.printf "Epoch Seconds (UTC): %.0f\n" (fst ttup) ;;

(* @@PLEAC@@_3.3 *)
#load "unix.cma";;

let time = Unix.time ()

let {Unix.tm_sec=seconds; tm_min=minutes; tm_hour=hours;
     tm_mday=day_of_month; tm_mon=month; tm_year=year;
     tm_wday=wday; tm_yday=yday; tm_isdst=isdst} =
  Unix.localtime time

let () =
  Printf.printf "Dateline: %02d:%02d:%02d-%04d/%02d/%02d\n"
    hours minutes seconds (year + 1900) (month + 1) day_of_month

(* @@PLEAC@@_3.4 *)
let birthtime = 96176750.                     (* 18/Jan/1973, 3:45:50 am *)
let interval = 5. +.                          (* 5 seconds *)
               17. *. 60. +.                  (* 17 minutes *)
               2.  *. 60. *. 60. +.           (* 2 hours *)
               55. *. 60. *. 60. *. 24.       (* and 55 days *)
let then' = birthtime +. interval
let () =
  (* format_time is defined in section 3.8. *)
  Printf.printf "Then is %s\n" (format_time then');
  (* Then is Tue Mar 13 23:02:55 1973 *)

(* @@PLEAC@@_3.5 *)
let bree = 361535725.                   (* 16 Jun 1981, 4:35:25 *)
let nat  =  96201950.                   (* 18 Jan 1973, 3:45:50 *)

let difference = bree -. nat
let () =
  Printf.printf "There were %.f seconds between Nat and Bree\n"
    difference
  (* There were 265333775 seconds between Nat and Bree *)

let seconds    =  mod_float difference 60.
let difference = (difference -. seconds) /. 60.
let minutes    =  mod_float difference 60.
let difference = (difference -. minutes) /. 60.
let hours      =  mod_float difference 24.
let difference = (difference -. hours)   /. 24.
let days       =  mod_float difference 7.
let weeks      = (difference -. days)    /.  7.

let () =
  Printf.printf "(%.f weeks, %.f days, %.f:%.f:%.f)\n"
    weeks days hours minutes seconds
  (* (438 weeks, 4 days, 23:49:35) *)

(* @@PLEAC@@_3.6 *)
#load "unix.cma";;

let {Unix.tm_mday=monthday; tm_wday=weekday; tm_yday=yearday} =
  Unix.localtime date
let weeknum = yearday / 7 + 1

(* @@PLEAC@@_3.7 *)
#load "unix.cma";;

let epoch_seconds date =
  Scanf.sscanf date "%04d-%02d-%02d"
    (fun yyyy mm dd ->
       fst (Unix.mktime {Unix.tm_sec=0; tm_min=0; tm_hour=0;
                         tm_mday=dd; tm_mon=mm-1; tm_year=yyyy-1900;
                         tm_wday=0; tm_yday=0; tm_isdst=false}))

let () =
  while true do
    let line = read_line () in
    try
      let date = epoch_seconds line in
      let {Unix.tm_mday=day; tm_mon=month; tm_year=year} =
        Unix.localtime date in
      let month = month + 1 in
      let year = year + 1900 in
      Printf.printf "Date was %d/%d/%d\n" month day year
    with
      | Scanf.Scan_failure _
      | End_of_file 
      | Unix.Unix_error (Unix.ERANGE, "mktime", _) ->
          Printf.printf "Bad date string: %s\n" line
  done

(* @@PLEAC@@_3.8 *)
#load "unix.cma";;

open Unix
open Printf

let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
                "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

let format_time time =
  let tm = localtime time in
  sprintf "%s %s %2d %02d:%02d:%02d %04d"
    days.(tm.tm_wday)
    months.(tm.tm_mon)
    tm.tm_mday
    tm.tm_hour
    tm.tm_min
    tm.tm_sec
    (tm.tm_year + 1900)

let time = fst (Unix.mktime {tm_sec=50; tm_min=45; tm_hour=3;
                             tm_mday=18; tm_mon=0; tm_year=73;
                             tm_wday=0; tm_yday=0; tm_isdst=false})
let () = printf "format_time gives: %s\n" (format_time time)

(* @@PLEAC@@_3.9 *)
#load "unix.cma";;

let t0 = Unix.gettimeofday ()
let () = print_string "Press return when ready: "; ignore (read_line ())
let t1 = Unix.gettimeofday ()
let () = Printf.printf "You took %f seconds.\n" (t1 -. t0)

(*-----------------------------*)

let size = 500 in
let number_of_times = 100 in
let total_time = ref 0. in

for i = 1 to number_of_times do
  let array = Array.init size (fun _ -> Random.bits()) in

  let before = Unix.gettimeofday() in
  Array.stable_sort compare array ;
  let time = Unix.gettimeofday() -. before in
  total_time := !total_time +. time
done ;

Printf.printf "On average, sorting %d random numbers takes %.5f seconds\n" size (!total_time /. float number_of_times)

(* @@PLEAC@@_3.10 *)
let usleep time =
  ignore (Unix.select [] [] [] time)

let () =
  while true do
    usleep 0.25;
    print_newline ();
  done

(* @@PLEAC@@_3.11 *)
#!/usr/bin/ocaml
(* hopdelta - feed mail header, produce lines
              showing delay at each hop. *)
#load "str.cma";;
#load "unix.cma";;

(* Modify this function to tweak the format of results. *)
let print_result sender recipient time delta =
  Printf.printf "%-30s %-30s %-20s   %s\n"
    sender recipient time delta

(* Produce a stream of lines from an input channel. *)
let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

(* Turn a stream of lines into a stream of paragraphs, where each
   paragraph is a stream of lines. Paragraphs are delimited by one
   or more empty lines. *)
let paragraphs lines =
  let rec next para_lines i =
    match Stream.peek lines, para_lines with
      | None, [] -> None
      | Some "", [] -> Stream.junk lines; next para_lines i
      | Some "", _ | None, _ -> Some (Stream.of_list (List.rev para_lines))
      | Some line, _ -> Stream.junk lines; next (line :: para_lines) i in
  Stream.from (next [])

(* Find blocks of email headers in a stream of paragraphs. Headers
   are all assumed to have a first line starting with "From" and
   containing a '@' character. This is not very robust. *)
let header_blocks paras =
  let rec next i =
    match Stream.peek paras with
      | Some lines ->
          if (match Stream.peek lines with
                | Some line ->
                    (String.length line >= 5
                     && (String.sub line 0 5 = "From ")
                     && (String.contains line '@'))
                | None -> false)
          then Some (Stream.next paras)
          else (Stream.junk paras; next i)
      | None -> None in
  Stream.from next

(* Pattern to detect continuation lines. *)
let continuation_regexp = Str.regexp "^[\t ]+"

(* Transform a stream of lines such that continuation lines are joined
   with previous lines by a single space. *)
let join_continuations lines =
  let rec continuations () =
    match Stream.peek lines with
      | Some line ->
          let found = ref false in
          let trimmed =
            Str.substitute_first
              continuation_regexp
              (fun _ -> found := true; "")
              line in
          if !found
          then (Stream.junk lines; " " ^ trimmed ^ continuations ())
          else ""
      | None -> "" in
  let rec next i =
    match Stream.peek lines with
      | Some line ->
          Stream.junk lines;
          Some (line ^ continuations ())
      | None -> None in
  Stream.from next

(* A type for headers, where "from" contains the text of the "From"
   line, and the rest of the headers are parsed into a (key, value)
   list called "params". *)
type header = { from : string;
                params : (string * string) list }

(* Given a stream of header blocks, produce a stream of values of the
   above "header" type. *)
let headers blocks =
  let parse_from line =
    String.sub line 5 (String.length line - 5) in
  let parse_param params line =
    try
      let index = String.index line ':' in
      let key = String.sub line 0 index in
      let value =
        if String.length line > index + 2
        then
          String.sub
            line
            (index + 2)
            (String.length line - index - 2)
        else "" in
      params := (key, value) :: !params
    with
      | Not_found
      | Invalid_argument "String.sub" ->
          Printf.eprintf "Unable to parse header: %s\n" line;
          () in
  let rec next i =
    try
      let lines = Stream.next blocks in
      let lines = join_continuations lines in
      let from = parse_from (Stream.next lines) in
      let params = ref [] in
      Stream.iter (parse_param params) lines;
      Some { from = from; params = List.rev !params }
    with Stream.Failure ->
      None in
  Stream.from next

(* Combine the above stream transformers to produce a function from
   input channels to streams of headers. *)
let header_stream_of_channel channel =
  headers
    (header_blocks
       (paragraphs
          (line_stream_of_channel channel)))

(* Association list mapping month abbreviations to 0-based month
   numbers as required by Unix.mktime. *)
let months =
  ["Jan", 0; "Feb", 1; "Mar", 2; "Apr", 3; "May", 4; "Jun", 5;
   "Jul", 6; "Aug", 7; "Sep", 8; "Oct", 9; "Nov", 10; "Dec", 11]

(* Turn a time zone into an offset in minutes. Not exhaustive. *)
let parse_tz = function
  | "" | "Z" | "GMT" | "UTC" | "UT" -> 0
  | "PST" -> -480
  | "MST" | "PDT" -> -420
  | "CST" | "MDT" -> -360
  | "EST" | "CDT" -> -300
  | "EDT" -> -240
  | string ->
      Scanf.sscanf string "%c%02d%_[:]%02d"
        (fun sign hour min ->
           min + hour * (if sign = '-' then -60 else 60))

(* List of date-parsing functions from strings to epoch seconds. *)
let date_parsers =
  [
    (fun string ->
       Scanf.sscanf string "%d %s %d %d:%d:%d %s"
         (fun mday mon year hour min sec tz ->
            let mon = List.assoc mon months in
            fst (Unix.mktime
                   {Unix.tm_sec=sec; tm_min=min; tm_hour=hour;
                    tm_mday=mday; tm_mon=mon; tm_year=year-1900;
                    tm_wday=0; tm_yday=0; tm_isdst=false})
            -. (float (parse_tz tz) *. 60.0)));
    (fun string ->
       Scanf.sscanf string "%3s, %d %s %4d %d:%d:%d %s"
         (fun wday mday mon year hour min sec tz ->
            let mon = List.assoc mon months in
            fst (Unix.mktime
                   {Unix.tm_sec=sec; tm_min=min; tm_hour=hour;
                    tm_mday=mday; tm_mon=mon; tm_year=year-1900;
                    tm_wday=0; tm_yday=0; tm_isdst=false})
            -. (float (parse_tz tz) *. 60.0)));
    (fun string ->
       Scanf.sscanf string "%3s, %d %s %2d %d:%d:%d %s"
         (fun wday mday mon year hour min sec tz ->
            let mon = List.assoc mon months in
            fst (Unix.mktime
                   {Unix.tm_sec=sec; tm_min=min; tm_hour=hour;
                    tm_mday=mday; tm_mon=mon; tm_year=year;
                    tm_wday=0; tm_yday=0; tm_isdst=false})
            -. (float (parse_tz tz) *. 60.0)));
  ]

(* Tries each of the above date parsers, one at a time, until one
   of them doesn't throw an exception. If they all fail, returns
   a value of 0.0. *)
let getdate string =
  let result = ref 0.0 in
  let parsers = ref date_parsers in
  while !result = 0.0 && !parsers <> [] do
    let parse = List.hd !parsers in
    parsers := List.tl !parsers;
    try result := parse string with _ -> ()
  done;
  !result

(* Formats a date given in epoch seconds for display. *)
let fmtdate epoch =
  let tm = Unix.localtime epoch in
  Printf.sprintf "%02d:%02d:%02d %04d/%02d/%02d"
    tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
    (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday

(* Formats the difference between two epoch times for display. *)
let fmtdelta delta =
  let sign    = if delta < 0.0 then '-' else ' ' in
  let delta   = abs_float delta in
  let seconds = mod_float delta 60. in
  let delta   = (delta -. seconds) /. 60. in
  let minutes = mod_float delta 60. in
  let delta   = (delta -. minutes) /. 60. in
  let hours   = mod_float delta 24. in
  Printf.sprintf "%c%02.f:%02.f:%02.f" sign hours minutes seconds

(* Process the header for a single email. *)
let process_header header =
  let start_from =
    try List.assoc "From" header.params
    with Not_found -> header.from in
  let start_from =
    Str.replace_first
      (Str.regexp ".*@\\([^ >]*\\).*") "\\1" start_from in
  let start_date =
    try List.assoc "Date" header.params
    with Not_found -> "" in
  let start_date =
    Str.replace_first
      (Str.regexp " +(.*$") "" start_date in
  let then' = ref (getdate start_date) in
  print_result "Sender" "Recipient" "Time" " Delta";
  print_result "Start" start_from (fmtdate !then') "";
  let prevfrom = ref start_from in
  List.iter
    (fun (key, value) ->
       if key = "Received"
       then
         begin
           let when' =
             Str.replace_first
               (Str.regexp ".*; +\\(.*\\)$") "\\1" value in
           let when' =
             Str.replace_first
               (Str.regexp " +(.*$") "" when' in
           let from' =
             try
               ignore (Str.search_forward
                         (Str.regexp "from +\\([^ )]+\\)") value 0);
               Str.matched_group 1 value
             with Not_found ->
               try
                 ignore (Str.search_forward
                           (Str.regexp "(\\([^)]*\\))") value 0);
                 Str.matched_group 1 value
               with Not_found -> "" in
           let from' = Str.replace_first (Str.regexp ")$") "" from' in
           let by' =
             try
               ignore (Str.search_forward
                         (Str.regexp "by +\\([^ ]+\\.[^ ]+\\)") value 0);
               Str.matched_group 1 value
             with Not_found -> "" in
           let now = getdate when' in
           let delta = now -. !then' in
           print_result
             (if !prevfrom <> "" then !prevfrom else from')
             by'
             (fmtdate now)
             (fmtdelta delta);
           then' := now;
           prevfrom := by';
         end)
    (List.rev header.params);
  print_newline ();
  flush stdout

(* Process all emails from standard input. *)
let () =
  Stream.iter process_header (header_stream_of_channel stdin)


(* @@PLEAC@@_4.0 *)
let nested = ["this"; "that"; "the"; "other"] (* string list *)

(* there is no such non-homogeneous list. You can do things with tuples: *)
let nested = ("this", "that", ["the"; "other"]) (* string * string * string list *)
(*-----------------------------*)
let tune = ["The"; "Star-Spangled"; "Banner"]
(*-----------------------------*)

(* @@PLEAC@@_4.1 *)
(* Note that Perl sort of munges OCaml lists and arrays into a single data
 * structure.  In OCaml, they are two distinct data structures, and one needs to
 * learn when it is best to use lists vs. arrays. *)

(* To initialize a list *)
let l = ["quick"; "brown"; "fox"];;

(* To initialize an array *)
let a = [|"quick"; "brown"; "fox"|];;

(*-----------------------------*)
let words s = Str.split (Str.regexp "[ \t]+") s;;
let l = words "Why are you teasing me?";;
(*-----------------------------*)
let str = "  The boy stood on the burning deck,
  It was as hot as glass.
" in
let f l =
  let sep = Str.regexp "[ \t\n]*\\(.+\\)" in
  List.map (fun s ->
    if (Str.string_match sep s 0) then
      Str.matched_group 1 s
    else
      ""
  ) l
in
f (Str.split (Str.regexp_string "\n") str);;
(*
 * - : string list =
 * ["The boy stood on the burning deck,"; "It was as hot as glass."]
 *)

let data = open_in "mydatafile" in
let bigarray = readlines data in
bigarray;;


(* @@PLEAC@@_4.2 *)

let commify_series l = 
  let rec sepChar l =
  match l with
    [] -> ", "
  | h::t -> 
       if String.contains h ',' then "; " else sepChar t in
  match l with
    [] -> ""
  | h::[] -> h
  | h1::h2::[] -> h1 ^ " and " ^ h2
  | _ ->
     let l' =
        let last::rest = List.rev l in
        (List.rev (("and " ^ last)::rest)) in
     String.concat (sepChar l) l';; 

let lists = 
  [
    [ "just one thing" ];
    [ "Mutt"; "Jeff" ];
    [ "Peter"; "Paul"; "Mary" ];
    [ "To our parents"; "Mother Theresa"; "God" ];
    [ "pastrami"; "ham and cheese"; "peanut butter and jelly"; "tuna" ];
    [ "recycle tired, old phrases"; "ponder big, happy thoughts" ];
    [ "recycle tired, old phrases"; 
      "ponder big, happy thoughts"; 
      "sleep and dream peacefully" ]
  ];;

List.iter (fun x -> printf "The list is: %s.\n" (commify_series x)) lists;;

(* 
The list is: just one thing.
The list is: Mutt and Jeff.
The list is: Peter, Paul, and Mary.
The list is: To our parents, Mother Theresa, and God.
The list is: pastrami, ham and cheese, peanut butter and jelly, and tuna.
The list is: recycle tired, old phrases and ponder big, happy thoughts.
The list is: recycle tired, old phrases; ponder big, happy thoughts; and sleep and dream peacefully.
*)

(* Note that if you are actually using arrays instead of lists, you can either
 * reuse the above code by calling "commify_series (Array.to_list a)", or you
 * can use the following solution (which won't work with lists, but is probably
 * more efficient).
*)

let commify_array a =
  let len = Array.length a in
  let rec sepChar a =
    try
      for i=0 to len - 1 do
        if String.contains a.(i) ',' then raise Not_found
      done;
      ", "
    with Not_found -> "; " in
  match len with
    0 -> ""
  | 1 -> a.(0)
  | 2 -> a.(0) ^ " and " ^ a.(1)
  | _ -> 
      let buf = Buffer.create 10
      and sep = sepChar a in
      for i = 0 to len - 2 do
        Buffer.add_string buf a.(i);
        Buffer.add_string buf sep;
      done;
      Buffer.add_string buf "and ";
      Buffer.add_string buf a.(len - 1);
      Buffer.contents buf;;

let arrays = 
  [|
    [| "just one thing" |];
    [| "Mutt"; "Jeff" |];
    [| "Peter"; "Paul"; "Mary" |];
    [| "To our parents"; "Mother Theresa"; "God" |];
    [| "pastrami"; "ham and cheese"; "peanut butter and jelly"; "tuna" |];
    [| "recycle tired, old phrases"; "ponder big, happy thoughts" |];
    [| "recycle tired, old phrases"; 
      "ponder big, happy thoughts"; 
      "sleep and dream peacefully" |]
  |];;

Array.iter (fun x -> printf "The list is: %s.\n" (commify_array x)) arrays;;

(* @@PLEAC@@_4.3 *)

(*
   OK, OCaml just doesn't work with arrays the same way tha Perl does.  In
   Ocaml, Arrays are immutable in their shape, while containing mutable
   contents.  You can simulate this example as shown below (which only works for
   string arrays), or you can get resizeable arrays from a library such as
   extlib <http://ocaml-lib.sourceforge.net/>
*)

let what_about_that_array a =
  let len = Array.length a in
  printf "The array now has %d elements.\n" len;
  printf "The index of the last element is %d.\n" (if len=0 then 0 else len-1);
  printf "Element 3 is \"%s\".\n" a.(3);; 

let resizeArray a s =
  (* begin stupid hack to work like the Perl example *)
  let s = s + 1 in
  (* end stupid hack to work like the Perl example *)
  assert (s >= 0);
  let len = Array.length a in
  if s = len then a else
    if s < len then
      Array.sub a 0 s
    else
      Array.append a (Array.make (s - len) "");;

let people = [|"Crosby"; "Stills"; "Nash"; "Young"|];;
what_about_that_array people;;

(*
The array now has 4 elements.
The index of the last element is 3.
Element 3 is "Young".
*)

let people = resizeArray people 2;;
what_about_that_array people;;

(*
The array now has 3 elements.
The index of the last element is 2.
Exception: Invalid_argument "index out of bounds".
*)

let people = resizeArray people 10000;;
what_about_that_array people;;
(*
The array now has 10001 elements.
The index of the last element is 10000.
Element 3 is "".
*)

(* @@PLEAC@@_4.4 *)

Array.iter complain bad_users;;
(* Or for lists *)
List.iter complain bad_users;;

(* For the hashtable example, we'd iterate over the table itself *)

Hashtbl.iter (fun k v -> printf "%s=%s\n" k v) h;; 

(* Of course if you want to iterate over the keys in lexicographic order, then
 * you'll need to build a list of keys, sort it, then iterate over that *)

List.iter (fun x -> printf "%s=%s\n" x (Hashtbl.find env x))
  (List.sort compare (Hashtbl.fold (fun k v b -> k::b) env []));;

Array.iter (fun x -> if get_usage x > max_quota then complain x) all_users;;
(* or for lists of users *)
List.iter (fun x -> if get_usage x > max_quota then complain x) all_users;;

(* for this example, we're going to assume that the output of the who command is
 * contained in the list named who, with one line of output per list element.
 * This example requires the use of the Str module which is not loaded or linked
 * by default (but is part of the standard library), at the toplevel, use the
 * directive "#load "str.cma"
*)

List.iter 
  (fun x -> 
    try 
      ignore (Str.search_forward (Str.quote "tchrist") x 0);
      print_endline x;
    with Not_found -> ()) who;;

(* To iterate over all lines read in from some channel we would do the following *)
  
let iter_channel f ic =
  try
    while true do
      f (input_line ic)
    done
  with Not_found -> ();;

(* and the example would then be written as *)
iter_channel
  (fun  s ->
    let reverse s ='let len = String.length s in
      let s' = String.create len in
      for i = 0 to len - 1 do
        s'.[len-i-1] <- s.[i]
      done;
      s' in
    (* assuming we have written a chomp workalike *)
    let s = chomp s in
    List.iter 
      (fun x -> print_endline (reverse x)) 
      (Str.split (Str.regexp "[ \t]+") s)) fh;;

(* In OCaml the iterator variable also is an alias for the current element,
 * however, because of the functional nature of OCaml, unless the elements of
 * the array are references, the only way to change them is by resetting the
 * value of the array to something new -- this is best done using iteri *)

let a = [|1; 2; 3|];;
Array.iteri (fun i x -> a.(i) <- x-1) a;;

(* or, with references *)

let a = [| ref 1; ref 2; ref 3 |];;
Array.iter (fun x -> x := !x - 1) a;;

(* You can, of course, use map to create a new array with the desired contents
 * as well *)
let a = [| 0.5; 3.|];;
let b = [|0.; 1.|];;
Array.iter (printf "%f ") (Array.map (( *. ) 7.) (Array.append a b));;


let strip s =
  Str.replace_first (Str.regexp "^[ \t\n]") ""
    (Str.replace_first (Str.regexp "[ \t\n$]") "" s);;


let sc,ar,h = 
  strip sc,
  Array.map strip ar,
  (Hashtbl.iter (fun k v -> Hashtbl.replace h k (strip v)) h; h);;

(* of course, the Hashtbl.replace already destructively updates the old
 * hashtable... *)

(* @@PLEAC@@_4.5 *)

(* iterate over elements of array in arrayref *)

Array.iter (fun x -> (* do something with x *)) !arrayref;;

for i = 0 to Array.length !arrayref - 1 do
  (* do something with !arrayref.(i) *)
done

let fruits = [| "Apple"; "Blackberry" |];;
let fruit_ref = ref fruits;;
Array.iter (printf "%s tastes good in a pie.\n") !fruit_ref;;

for i = 0 to  Array.length !fruit_ref - 1 do
  printf "%s tastes good in a pie.\n" !fruit_ref.(i)
done;;

Hashtbl.add namelist "felines" (ref rogue_cats);;
Array.iter (printf "%s purrs hypnotically.\n") !(Hashtbl.find namelist
"felines");;
print_endline "--More--\nYou are controlled.";;

for i=0 to Array.length !(Hashtbl.find namelist "felines") - 1 do
  printf "%s purrs hypnotically.\n" !(Hashtbl.find namelist "felines").(i)
done;;

(* @@PLEAC@@_4.6 *)

(* For lists, the most "natural" way to do this is by walking the list and
 * looking for duplicates of each item *)

let rec uniquesOnly l = 
  let rec contains x l =
    match l with
      [] -> false
    | h::t -> if x = h then true else contains x t in
  match l with 
    [] -> []
  | h::t -> if contains h t then uniquesOnly t else h::(uniquesOnly t);;

(* if you have a lot of duplicates, it might be better to use List.filter *)
let rec uniquesOnly l =
  match l with
    [] -> []
  | h::t -> h::(uniquesOnly (List.filter ((<>) h) t));;

(* Or, for lists or arrays, you can use a hashtable *)
(* Straightforward *)
let uniquesOnly l =
  let seen = Hashtbl.create 17
  and uniq = ref [] in
  List.iter 
    (fun x -> 
      if not (Hashtbl.mem seen x) then 
        (Hashtbl.add seen x 1; uniq := (x::!uniq)))
    l;
  !uniq;;

(* Or more likely *)
let uniquesOnly l =
  let seen = Hashtbl.create 17 in
  List.iter (fun x -> Hashtbl.replace seen x 1) l;
  Hashtbl.fold (fun k v b -> k::b) seen [];;

(* To apply a user function to each unique element of a list, one would likely
 * do something like *)

let userUnique f l =
  List.map f (uniquesOnly l);;

(* Generate a list of users logged in, removing duplicates.  Note that this
 * example requires linking with the Unix and Str libraries. *)
let who () =
  let w = Unix.open_process_in "who"
  and l = ref [] in
  try
    while true do
      l := (input_line w)::!l
        done;
        !l
  with End_of_file -> !l;;

let ucnt = Hashtbl.create 17;;
List.iter 
  (fun x -> 
    Hashtbl.replace ucnt (Str.replace_first (Str.regexp "[ \t].*$") "" x) 1)
  (who ());;
let users = Hashtbl.fold (fun k v b -> k::b) ucnt [];;

printf "users logged in: %s";;
List.iter (printf "%s ") users;;

(* @@PLEAC@@_4.7 *)

(* using hashtables, like the cookbook *)
let arrayDiff a b = 
  let seen = Hashtbl.create 17 
  and l = ref [] in
  Array.iter (fun x -> Hashtbl.add seen x 1) b;
  Array.iter (fun x -> if not (Hashtbl.mem seen x) then l := x::!l) a;
  Array.of_list !l;;


(* @@PLEAC@@_4.8 *)

let a = [ 1;3;5;6;7;8 ];;
let b = [ 2;3;5;7;9 ];;

let union = Hashtbl.create 13
and isect = Hashtbl.create 13
and diff = Hashtbl.create 13;;

(* simple solution for union and intersection *)
List.iter (fun x -> Hashtbl.add union x 1) a;;
List.iter 
  (fun x -> hashtbl.add (if Hashtbl.mem union x then isect else union) x 1) b;;
let u = Hashtbl.fold (fun k v b -> k::b) union []
and i = Hashtbl.fold (fun k v b -> k::b) isect [];;

(* Union, intersection, and symmetric difference *)
let hincr h x = 
  let v = try Hashtbl.find h x with Not_found -> 0 in
  Hashtbl.replace h x (v+1);;

let count = Hashtbl.create 13;;
List.iter (fun x -> Hashtbl.add count x 1) a;;
List.iter (hincr count) b;;
let u,i,d =
  let u = Hashtbl.fold (fun k v b -> (k,v)::b) count [] in
  let i,d = List.partition(fun x -> snd x = 2) u in
  let vo l = List.map fst l in
  (vo u),(vo i),(vo d);;


(* @@PLEAC@@_4.9 *)

(* For lists, use the @ operator for two lists, or List.concat for a list of
 * lists, for arrays, use Array.append for two arrays, or Array.concat for a
 * list of arrays*)

let list1 = list1 @ list2;;
let array1 = Array.append array1 array2;;

let members = [| "Time"; "Flies" |];;
let initiates = [| "An"; "Arrow" |];;
let members = Array.append members initiates;;

(* It is easiest to write a splice workalike and then just use the new function
 * much like in Perl *)

let splice ?length ?list arr off =
  let len = Array.length arr in
  let off = if off < 0 then len + off else off in
  let l,back =
    match length with
      None -> (len - off),[||]
    | Some l -> 
        l,
        (let boff = off + l in
        try Array.sub arr boff (len - boff)  with Invalid_argument _ -> [||]) in
  let front = Array.sub arr 0 off
  and mid = 
    match list with 
      None -> [||] 
    | Some a -> a
  and sp = Array.sub arr off l in
  sp,Array.concat [front;mid;back];;

let _,members = 
  splice members 2 ~length:0 ~list:(Array.append [|"Like"|] initiates);;
Array.iter (printf "%s ") members; print_newline ();;

let _,members = splice members 0 ~length:1 ~list:[|"Fruit"|];;
let _,members = splice members (-2) ~length:2 ~list:[|"A"; "Banana"|];;
Array.iter (printf "%s ") members; print_newline ();;

(* @@PLEAC@@_4.10 *)

(* To reverse a list, use List.rev *)
let reversed = List.rev l;;

(* For an array, it is probably easiest to use Array.init *)

let revArray a = 
  let len = Array.length a - 1 in
  Array.init len+1 (fun i -> a.(len - i);;

let reversed = revArray a;;

(* Or one can use a for loop *)
for i = Array.length a - 1 downto 0 do
  (* Do something to a.(i) *)
done;;

(* @@PLEAC@@_4.11 *)

(* To remove multiple elements from an array at once, one can use the splice
 * function from section 4.9 *)

(* Remove n elements from the front of arr *)
front,arr = splice arr 0 ~length:n;;
rear,arr = splice arr (-n);;

(* this can also be wrapped as an explicit function *)

let shift2 a = splice a 0 ~length:2;;
let pop2 a = splice a (-2);;

(* This lets you do something like Perl's hinkey pattern matching *)
let friends = [|"Peter"; "Paul"; "Mary"; "Jim"; "Tim" |];;
let [|this; that|],friends = shift2 friends;;

let beverages = [|"Dew"; "Jolt"; "Cola"; "Sprite"; "Fresca"|];;;
let pair,beverages =  pop2 beverages;;

(* @@PLEAC@@_4.12 *)

(* To find the first element in a list that satisfies some predicate, just use
 * the List.find function to return an 'a option *)

match
  (try Some (List.find (fun x -> x > 10) l)
  with Not_found -> None)
with
    None -> (* unfound *)
  | Some x -> (* Do something with x *);;

(* Note that this is a very general form, and can be shortened in some cases *)
let pf l =
  try 
    printf "hah! Found %d!\n" (List.find (fun x -> x > 10) l)
  with 
    Not_found -> "Sorry charly!\n";;

(*
# pf [1;2;3;4;5;6];;
Sorry charly!

# pf [1;2;3;50;100];;
Hah!  Found 50!
*)

(* To return the index of a matching element in an array, we can use exceptions
 * to short circuit the search *)

exception Found of int;;

let findi pred arr = 
  Array.iteri (fun i x -> if pred x then raise (Found i)) arr;
  raise Not_found;;

let f arr = 
try
  findi (fun x -> x > 10) arr
with
  Found i -> printf "element %d is a big element - %d\n" i arr.(i)
| Not_found -> printf "Only small values here!\n";;

(*
# f [|1; 2; 3; 4; 5; 6|];;
Only small values here!

# f [|1; 2; 3; 4; 5; 60; 8; 9; 100|];;
element 5 is a big element - 60
*)

let highest_engineer =
  List.find (fun x -> x#category = "engineer") employees in
  printf "Highest paid engineer is: %s\n" highest_engineer#name;;


(* @@PLEAC@@_4.13 *)

(* to find all elements of a list that satisfy a certain predicate, just use the
 * List.find_all function *)

let matching = List.find_all ( (* predicate *) l;;

(* for an array, it's likely easiest to convert the original array to a list,
 * use List.find_all, and convert that list into an array *)
let matching = 
  Array.ofList (List.find_all ( (*predicate *) ) (Array.to_list a));;

(* the next example requires use of the Str library, which must be linked in.
 * In the toplevel environment use `#load "str.cma"' *)

let bigs = List.find_all (fun x -> x > 1000000) nums;;
let pigs = List.find_all (fun x -> (Hashtbl.find users x) > 1e7) 
            (Hashtbl.fold (fun k v b -> k::b) users []);;

let matching = 
  List.find_all (fun x -> Str.string_match (Str.regexp "gnat") x 0) (who ());;

let engineers = List.find_all (fun x -> x#position = "Engineer") employees;;

let secondary_assistance = 
  List.find_all (fun x -> x#income >= 26000 && x#income < 30000) applicants;;

(* @@PLEAC@@_4.14 *)

(* OCaml is smart enough to figure out if a list is full of numbers or
 * non-numbers, so the polymorphic compare function works just fine *)
let sorted = List.sort compare unsorted;;

(* note that Array.sort sorts the given array in place, so unexpected results
 * can occur, e.g.
let sorted = Array.sort compare unsorted;;

 * results in unsorted referring to the now sorted array, and sorted referring
 * to something of type unit *)

(* pids is an unsorted list of process IDs *)
List.iter (printf "%d\n") (List.sort compare pids);;
print_endline "Select a process ID to kill:";;
let pid = read_int () in
  Unix.kill pid Sys.sigterm;
  Unix.sleep 2;
  Unix.kill pid Sys.sigterm;;

let descending = List.sort (fun x y -> compare y x) unsorted;;

(* @@PLEAC@@_4.15 *)
(* since compare orders tuples by first comparing the first slot then, if they
 * were equal, comparing the second slot, and so on, we can sort by computable
 * fields as follows *)

let sorted = 
  List.map snd (List.sort compare (List.map (fun x-> (compute x),x) unsorted));;

let ordered = List.sort (fun x y -> compare x#name y#name) employees;;
List.iter (fun x -> printf "%s earns $%2f\n" x#name x#salary)
  (List.sort (fun x y -> compare x#name y#name) employees);;

let sorted_employees = 
  List.map snd (List.sort compare (List.map (fun x-> (compute x),x) unsorted)) in
  List.iter (fun x -> printf "%s earns $%2f\n" x#name x#salary) sorted_employees;
  List.iter 
    (fun x -> if Hashtbl.mem bonus x#ssn then printf "%s got a bonus!\n" x#name)
    sorted_employees;;

let sorted = 
  List.sort 
    (fun x y ->
      match compare x#name y#name with
        0 -> compare x#age y#age
      | c -> c)
    employees;;

(* Assuming we have a getpwent function that returns a value of type users, or
 * throws an End_of_file exception when done (not sure what getpwent is supposed
 * to do), then we can write *)

let getUsers () = 
  let l = ref [] in
  try
    while true do
      l := (getpwent ())::!l
    done
  with End_of_file -> !l;;

List.iter 
  (fun x -> print_endline x#name) 
  (List.sort (fun x y -> compare x#name y#name) (getUsers ()));;

let sorted = List.sort (fun x y -> compare x.[1] y.[1]) strings;;

let sorted = 
  List.map snd
    (List.sort compare (List.map (fun x -> (String.length x),x) strings));;

let sorted_fields = 
  List.map snd
    (List.sort compare 
      (List.map 
        (fun x ->
          (try 
            ignore(Str.search_forward (Str.regexp "[0-9]+") x 0);
            int_of_string (Str.matched_string x)
          with Not_found -> max_int),x) 
        strings));;

let passwd () =
  let w = Unix.open_process_in "cat /etc/passwd"
  and l = ref [] in
  try
    while true do
      l := (input_line w)::!l
        done;
        !l
  with End_of_file -> !l;;

(* for illustration purposes, we provide a function to return the (non-comment)
 * contents of /etc/passwd *)
let passwd () =
  let w = Unix.open_process_in "cat /etc/passwd"
  and l = ref [] in
  try
    while true do
      l := (input_line w)::!l
        done;
        !l
  with End_of_file -> 
    List.filter (fun x -> x.[0] <> '#') !l;;

let sortedPasswd = 
  List.map (fun Some x -> snd x)
  (List.sort compare
   (List.filter (function Some x -> true | None -> false)
    (List.map
      (fun x -> 
        match Str.split (Str.regexp ":") x with
          name::_::uid::gid::t -> Some ((gid,uid,name),x)
        | _ -> None) 
     (passwd ()))));;

(* @@PLEAC@@_4.16 *)

(* To get a true circular list, one can use the let rec construct *)

let rec processes = 1::2::3::4::5::processes;;
while true do
  let process::processes = process in
  printf "Handling process %d\n" process;
  Unix.sleep 2;
done;;

(* or one can use these somewhat inefficient functions to simulate the Perl
 * examples *)

let popleft l =
  match l with
    [] -> raise Not_found
  | h::t -> h,(t @ [h]);;

let popright l =
  match List.rev l with
    [] -> raise Not_found
  | h::t -> h,(h::(List.rev t));;

let processes = ref [1;2;3;4;5];;
while true do
  let process,np = popleft !processes in
  processes := np;
  printf "Handling process %d\n" process;
  flush_all ();
  Unix.sleep 1;
done;;

(* @@PLEAC@@_4.17 *)

let fisher_yates_shuffle a =
  for i = Array.length a - 1 downto 1 do
    let x = a.(i)
    and r = Random.int (i+1) in
    a.(i) <- a.(r);
    a.(r) <- x;
  done;;

(* @@PLEAC@@_4.18 *)

(* Assuming we start with a list of all the data called data, and assuming we
 * already have the curent number of screen columns in a variable cols *)

let words data cols =
  let strippedData = 
    Array.of_list 
      (List.map (Str.replace_first (Str.regexp "[ \t\n]+$") "") data) in
  let maxlen = 
    (Array.fold_left (fun m s -> max m (String.length s)) 0 strippedData) + 1 in
  let cols = if cols < maxlen then 1 else cols / maxlen in
  let rows = ((Array.length strippedData - 1) + cols)/cols in
  let bufs = Array.init rows (fun x -> Buffer.create (cols * maxlen)) in
  for i = 0 to Array.length strippedData - 1 do
    let dst = String.make maxlen ' '
    and src = strippedData.(i) in
    String.blit src 0 dst 0 (String.length src);
    Buffer.add_string bufs.(i mod rows) dst
  done;
  Array.iter (fun x -> print_endline (Buffer.contents x)) bufs;;

(* @@PLEAC@@_4.19 *)

(* Note: This routine uses the splice routine written in section 4.9 *)

let tsc_permute arr =
  if Array.length arr > 0 then print_endline "Perms:";
  let rec permute arr perms =
    match Array.length arr with
      0 -> Array.iter (printf "%s ") perms; print_newline ();
    | _ ->
        for i = 0 to Array.length arr - 1 do
          let v,ni = splice arr i ~length:1 in
          permute ni (Array.append v perms);
        done in
  permute arr [||];;

(* Note: This example is going to permute the words of a given string - also, I
 * don't feel like bringing in the BigInt module, so we will trim any array
 * longer than 12 elements down to 12 before permuting *)

let fact = Array.append [|Some 1|] (Array.make 11 None);;
let rec factorial n =
  match fact.(n) with
    Some f -> f
  | None -> let f = n*(factorial (n-1)) in fact.(n) <- Some f; f;;

let n2pat n len =
  let rec nh n i pat =
    if i > len+1 then pat
    else
      nh (n/i) (i+1) ((n mod i)::pat) in
  nh n 1 [];;

let pat2perm pat =
  let rec ph source pat perm =
    match pat with
      [] -> perm
    | h::t ->
        let v,s = splice source h ~length:1 in
        ph s t (v.(0)::perm) in
  Array.of_list (ph (Array.init (List.length pat) (fun i -> i)) pat []);;
  
let n2perm n len =
  pat2perm (n2pat n len);;

let mjd_permute s =
  let arr = 
    let arr = Array.of_list (Str.split (Str.regexp "[ \t]+") s) in
    try
      Array.sub arr 0 12
    with Invalid_argument _ -> arr in
  let len = Array.length arr - 1 in
  for i = 0 to factorial (len+1) do
    let perm = Array.map (fun i -> arr.(i)) (n2perm i len) in
    Array.iter (printf "%s ") perm; print_newline ();
  done;;


(* @@PLEAC@@_5.0 *)
(*-----------------------------*)
(* build an hash table element by element *)
let age = Hashtbl.create 3 ;;  (* 3 is the supposed average size for the
                                  hash table *)
Hashtbl.replace age "Nat" 24 ;
Hashtbl.replace age "Jules" 25 ;
Hashtbl.replace age "Josh" 17 ;;
(*-----------------------------*)
let assoc_list2hashtbl assoc_list = 
  let h = Hashtbl.create 0 in
  List.iter (fun (k,v) -> Hashtbl.replace h k v) assoc_list ;
  h

let food_color = assoc_list2hashtbl 
    [ "Apple", "red" ; 
      "Banana", "yellow" ; 
      "Lemon", "yellow" ; 
      "Carrot", "orange" ;
    ] ;;
(*-----------------------------*)

(* @@PLEAC@@_5.1 *)
(*-----------------------------*)
Hashtbl.replace tbl key value ;;
(*-----------------------------*)
(* food_color defined per the introduction *)
Hashtbl.replace food_color "Raspberry" "pink" ;;


let hashtbl_keys h = Hashtbl.fold (fun key _ l -> key :: l) h []
let hashtbl_values h = Hashtbl.fold (fun _ value l -> value :: l) h []
let hashtbl2assoc_list h = Hashtbl.fold (fun key value l -> (key, value) :: l) h []
;;
print_string "Known_foods:\n" ;
Hashtbl.iter (fun food _ -> print_endline food) food_color ;
print_string "Known_foods:\n" ;
List.iter print_endline (hashtbl_keys food_color) ;;
(*
> Known_foods:
> Banana
> Raspberry
> Apple
> Carrot
> Lemon
*)
(*-----------------------------*)

(* @@PLEAC@@_5.2 *)
(*-----------------------------*)
(* does %HASH have a value for $KEY ?  *)
if (Hashtbl.mem hash key) then
  (* it exists *)
else
  (* id doesn't exists *)
 ;;
(*-----------------------------*)
(* food_color defined per the introduction *)
List.iter (fun name ->
  let kind = if Hashtbl.mem food_color name then "food" else "drink" in
  printf "%s is a %s.\n" name kind
) ["Banana"; "Martini"] ;;
(*
> Banana is a food.
> Martini is a drink.
*)
(*-----------------------------*)
(* there's no such thing called "undef", "nil" or "null" in Caml
   if you really want such a value, use type "option" as shown below *)
let age = assoc_list2hashtbl 
    [ "Toddler", 3 ; "Unborn", 0 ] ;;
(*> val age : (string, int) Hashtbl.t = <abstr> *)

List.iter (fun thing ->
  printf "%s: %s\n" thing
    (try match Hashtbl.find age thing with
    | 0 -> "Exists"
    | _ -> "Exists NonNull"
    with Not_found -> "")
) ["Toddler" ; "Unborn" ; "Phantasm" ; "Relic" ]

let age = assoc_list2hashtbl 
    [ "Toddler", Some 3 ; "Unborn", Some 0 ; "Phantasm", None ] ;;
(*> val age : (string, int option) Hashtbl.t = <abstr> *)

List.iter (fun thing ->
  printf "%s: %s\n" thing
    (try match Hashtbl.find age thing with
    | None -> "Exists"
    | Some 0 -> "Exists Defined"
    | Some _ -> "Exists Defined NonNull"
    with Not_found -> "")
) ["Toddler" ; "Unborn" ; "Phantasm" ; "Relic" ]
(*
> Toddler: Exists Defined NonNull
> Unborn: Exists Defined
> Phantasm: Exists
> Relic: 
*)
(*-----------------------------*)
let size = Hashtbl.create 20 in
List.iter (fun f -> 
  if not (Hashtbl.mem size f) then
    Hashtbl.replace size f (Unix.stat f).Unix.st_size;
) (readlines stdin);
(*-----------------------------*)
(* here is a more complete solution which does stat 2 times the same file (to
be mimic perl's version) *)
let size = Hashtbl.create 20 in
List.iter (fun f -> 
  if not (Hashtbl.mem size f) then
    Hashtbl.replace size f (try Some (Unix.stat f).Unix.st_size with _ -> None)
) (readlines stdin);


(* @@PLEAC@@_5.3 *)
(*-----------------------------*)
(* remove $KEY and its value from %HASH *)
Hashtbl.remove hash key ;
(*-----------------------------*)
(* food_color as per Introduction *)
open Printf

let print_foods () =
  printf "Keys: %s\n" (String.concat " " (hashtbl_keys food_color)) ;
  printf "Values: %s\n" (String.concat " " (hashtbl_values food_color))
;;
print_string "Initially:\n";
print_foods ();

print_string "\nWith Banana deleted\n";
Hashtbl.remove food_color "Banana";
print_foods ()
;;
(*-----------------------------*)
Hashtbl.clear food_color ;;
(*-----------------------------*)

(* @@PLEAC@@_5.4 *)
(*-----------------------------*)
(* in this section consider opened the Printf module using: *)
open Printf;;

Hashtbl.iter
  (fun key value ->
    (*
      do something with key and value
    *)
  )
  hash
;;
(*-----------------------------*)
List.iter (fun key ->
  let value = Hashtbl.find hash key in
    (*
      do something with key and value
    *)
) (hashtbl_keys hash)
;;
(*-----------------------------*)
(* food_color as defined in the introduction *)
Hashtbl.iter (printf "%s is %s.\n") food_color;
(*
> Lemon is yellow.
> Apple is red.
> Carrot is orange.
> Banana is yellow.
*)
(* but beware of: *)
Hashtbl.iter (printf "food_color: %s is %s.\n") food_color;
(*
> food_color: Lemon is yellow.
> Apple is red.
> Carrot is orange.
> Banana is yellow.
*)
(* write this instead:
  (more on it at http://caml.inria.fr/ocaml/htmlman/manual055.html) *)
Hashtbl.iter (fun k v -> printf "food_color: %s is %s.\n" k v) food_color;
(*
> food_color: Lemon is yellow.
> food_color: Apple is red.
> food_color: Carrot is orange.
> food_color: Banana is yellow.
*)

List.iter (fun key ->
  let value = Hashtbl.find food_color key in
  printf "%s is %s.\n" key value
) (hashtbl_keys food_color) ;
(*
> Lemon is yellow.
> Apple is red.
> Carrot is orange.
> Banana is yellow.
*)

(*-----------------------------*)
List.iter
  (fun key ->
    printf "%s is %s.\n" key (Hashtbl.find food_color key)
  )
  (sort_ (hashtbl_keys food_color))
;;

(*
> Apple is red.
> Banana is yellow.
> Carrot is orange.
> Lemon is yellow.
*)

(*-----------------------------*)
(* Ocaml is safe in loop, so you can't reset the hash iterator as in
Perl and you don't risk infinite loops using, say, List.iter or
Hashtbl.iter, but if you really want to infinite loop on the first key
you get ... *)
List.iter
  (fun key ->
    while true do
      printf "Processing %s\n" key
    done
  )
  (hashtbl_keys food_color)
;;
(*-----------------------------*)
(* countfrom - count number of messages from each sender *)
let main () =
  let file =
    let files = ref [] in
    Arg.parse [] (fun file -> files := !files @ [file]) "";
    try
      open_in (List.hd !files)
    with Failure "hd" -> stdin
  in
  let from = Hashtbl.create 50 in
  let add_from address =
    let old_count =
      try Hashtbl.find from address
      with Not_found -> 0
    in
    let new_count = old_count + 1 in
    Hashtbl.replace from address new_count;
  in
  let extractfrom = Str.regexp "^From: \(.*\)" in

  iter_lines (fun line ->
    if (Str.string_match extractfrom line 0) then
      add_from (Str.matched_group 1 line)
    else ()
  ) file;
  Hashtbl.iter (printf "%s: %d\n") from
;;
main() ;

(* @@PLEAC@@_5.5 *)
(*-----------------------------*)
(* note that OCaml does not have a native polymorphic print function, so
examples in this section work for hashes that map string keys to string
values *)
Hashtbl.iter (printf "%s => %s\n") hash ;
(*-----------------------------*)

(* map in ocaml maps a function on a list, rather that evaluate an
expression in turn on a list as Perl does *)
List.iter
  (fun key ->
    printf "%s => %s\n" key (Hashtbl.find hash key)
  )
  (hashtbl_keys hash) ;
(*-----------------------------*)

(* build a list from an hash table, note that this is possibile only if
the type of key and value are the same *)
let hashtbl2list hash =
  Hashtbl.fold
    (fun key value init -> key :: value :: init)
    hash
    []
;;
List.iter (printf "%s ") (hashtbl2list hash) ;
(* or *)
print_endline (String.concat " " (hashtbl2list hash)) ;

(* @@PLEAC@@_5.6 *)
(*-----------------------------*)
(* In OCaml one usually use association lists which really is a list of
(key,value). Note that insertion and lookup is O(n) (!!!) *)

(* initialization *)
let empty_food_color = []
let food_color = 
    [ "Banana", "Yellow" ; 
      "Apple", "Green" ; 
      "Lemon", "Yellow" ; 
    ]
(* adding *)
let food_color' = food_color @ [ "Carrot", "orange" ]
;;
(* output entries in insertion order *)
print_endline "In insertion order, the foods are:";
List.iter (printf "%s is colored %s.\n") food_color;
(*
> Banana is colored Yellow.
> Apple is colored Green.
> Lemon is colored Yellow.
*)
(* is it a key? *)
let has_food food = mem_assoc food food_color
(* remove a key *)
let remove_food food = remove_assoc food food_color
(* searching *)
let what_color food =
  try
    let color = assoc food food_color in
    printf "%s is colored %s.\n" food color
  with Not_found -> printf "i don't know the color of %s\n" food
;;
(* @@PLEAC@@_5.7 *)
(*-----------------------------*)
let re = Str.regexp "^\([^ ]*\) *\([^ ]*\)" in
let lines = readlines (Unix.open_process_in "who") in
let ttys = filter_some (List.map (fun line ->
  if (Str.string_match re line 0) then
    Some(Str.matched_group 1 line, Str.matched_group 2 line)
  else None) lines) in
List.iter
  (fun user ->
    printf "%s: %s\n" user (String.concat " " (all_assoc user ttys))
  ) (sort_ (uniq (List.map fst ttys)))
;
(*-----------------------------*)
List.iter
  (fun user ->
    let ttylist = all_assoc user ttys in
    printf "%s: %d ttys.\n" user (List.length ttylist);
    List.iter
      (fun tty ->
        let uname =
          try
            let uid = (Unix.stat ("/dev/" ^ tty)).Unix.st_uid in
            (Unix.getpwuid uid).Unix.pw_name
          with Unix.Unix_error _ -> "(not available)"
        in
        printf "%s (owned by %s)\n" tty uname
      ) ttylist
  ) (sort_ (uniq (List.map fst ttys)))
(*-----------------------------*)
(* @@PLEAC@@_5.8 *)
(*-----------------------------*)

open Hashtbl

(* size of an hash, i.e. number of bindings *)
let hashtbl_size h = List.length (hashtbl_keys h);;

(* in OCaml does not exists a builtin function like "reverse", here is
an equivalent one: *)
let hashtbl_reverse h =
  assoc_list2hashtbl (List.combine (hashtbl_values h) (hashtbl_keys h))
(* or *)
let hashtbl_reverse h =
  assoc_list2hashtbl (List.map (fun (a,b) -> (b,a)) (hashtbl2assoc_list h))
;;
(* or *)
let hashtbl_reverse_multi h =
  let newhash = Hashtbl.create (hashtbl_size h) in
  List.iter
    (fun v -> add newhash (find h v) v)
    (hashtbl_keys h);
  newhash
(* note that the last  implementation maintain also multiple binding for the
same key, see Hashtbl.add in the standard OCaml library for more info *)

(*-----------------------------*)
(* example of hashtbl_reverse *)

let reverse = hashtbl_reverse lookup;;
(*-----------------------------*)
let surname = assoc_list2hashtbl ["Mickey", "Mantle"; "Babe", "Ruth"] in
let firstname = hashtbl_reverse surname in
print_endline (Hashtbl.find firstname "Mantle");;
(*
> Mickey
*)

(*-----------------------------*)
(* foodfind - find match for food or color *)

let given = Sys.argv.(1) in
let color = assoc_list2hashtbl
  ["Apple", "red";
   "Banana", "yellow";
   "Lemon", "yellow";
   "Carrot", "orange"] in
let food = hashtbl_reverse color in
(try
  printf "%s is a food with color %s.\n" given (Hashtbl.find color given);
with Not_found -> ());
(try
  printf "%s is a food with color %s.\n" (Hashtbl.find food given) given
with Not_found -> ())
;;
(*-----------------------------*)
(* food_color defined as previous *)

let foods_with_color = hashtbl_reverse food_color in
List.iter (printf "%s ") (Hashtbl.find_all foods_with_color "yellow");
print_endline "were yellow foods."
;;
(*-----------------------------*)

(* @@PLEAC@@_5.9 *)
(*-----------------------------*)

(* you may define your own compare function to be used in sorting *)
let keys = List.sort compare_function (hashtbl_keys hash) in
List.iter
  (fun key ->
    let value = Hashtbl.find hash key in
    (* do something with key and value *)
    ()
  )
  keys ;
(* or use this one if you want to compare not only on keys *)
Hashtbl.iter
  (fun (key, value) ->
    (* do something with key and value *)
    ()
  ) (List.sort compare_function (hashtbl2assoc_list hash)) ;
(*-----------------------------*)
List.iter
  (fun food ->
    printf "%s is %s.\n" food (Hashtbl.find food_color food)
  )
  (List.sort (hashtbl_keys food_color))
;;
(*-----------------------------*)
(* examples of "compare_function": *)

(* alphabetical sort on the hash value *)
let compare_function (_,color1) (_,color2) = compare color1 color2

(* length sort on the hash value *)
let compare_function (_,color1) (_,color2) = compare (String.length color1) (String.length color2)

(*-----------------------------*)

(* @@PLEAC@@_5.10 *)
(*-----------------------------*)
(* definition of merge function on hashes: *)
let hashtbl_merge h1 h2 = assoc_list2hashtbl (hashtbl2assoc_list h1 @ hashtbl2assoc_list h2)

(* usage: *)
let merged = hashtbl_merge a b;;
(*-----------------------------*)
let merged = Hashtbl.create 0 in
List.iter
  (Hashtbl.iter (fun k v -> Hashtbl.add merged k v))
  [a;b]
;;
(*-----------------------------*)
let drink_color = assoc_list2hashtbl
    ["Galliano", "yellow";
     "Mai Tai", "blue"]
;;

let ingested_color = hashtbl_merge drink_color food_color;;
(*-----------------------------*)
let substance_color = Hashtbl.create 0 in
List.iter
  (Hashtbl.iter (fun k v -> Hashtbl.add merged k v))
  [food_color; drink_color]
;;

(* @@PLEAC@@_5.11 *)
(*-----------------------------*)
let common =
  List.filter
    (fun key -> Hashtbl.mem hash2 key)
    (hashtbl_keys hash1)
;;
(* common now contains commne keys, note that a key may appear multiple
times in this list due tu multiple bindings allowed in Hashtbl
implementation *)

let this_not_that =
  List.filter
    (fun key -> not (Hashtbl.mem hash2 key))
    (hashtbl_keys hash1)
;;
(*-----------------------------*)
let citrus_color = assoc_list2hashtbl
                      ["Lemon", "yellow";
                       "Orange", "orange";
                       "Lime", "green"]
in
let non_citrus = Hashtbl.create 3 in
List.filter
  (fun key -> not (Hashtbl.mem citrus_color key))
  (hashtbl_keys food_color)
;;

(*-----------------------------*)
(* @@PLEAC@@_5.12 *)
(*-----------------------------*)
open Unix;;
open Printf;;

let filenames = ["/etc/printcap"; "/vmlinuz"; "/bin/cat"] in
let openfiles = Hashtbl.create 3 in
print_newline();
List.iter
  (fun fname ->
    printf "%s is %d bytes long.\n"
      fname
      (stat fname).st_size
  )
  filenames
;;
  
(*-----------------------------*)
(* @@PLEAC@@_5.13 *)
(*-----------------------------*)

(* presize hash to num elements *)
let hash = Hashtbl.create num;;
(* other examples of initial size on hashes *)
let hash = Hashtbl.create 512;;
let hash = Hashtbl.create 1000;;

(*-----------------------------*)
(* @@PLEAC@@_5.14 *)
(*-----------------------------*)

(* size of an array named "a" *)
let count = Array.length a;;

(* size of a list named "l" *)
let count = List.length l;;

(*-----------------------------*)
(* @@PLEAC@@_5.15 *)
(*-----------------------------*)

open Printf;;
open Hashtbl;;

let father = assoc_list2hashtbl
  [ "Cain", "Adam";
    "Abel", "Adam";
    "Seth", "Adam";
    "Enoch", "Cain";
    "Irad", "Enoch";
    "Mehujael", "Irad";
    "Methusael", "Mehujael";
    "Lamech", "Methusael";
    "Jabal", "Lamech";
    "Jubal", "Lamech";
    "Tubalcain", "Lamech";
    "Enos", "Seth"] ;;
(*-----------------------------*)
(* recursively print all parents of a given name *)
let rec parents s =
  printf "%s " s;
  if mem father s then
    parents (find father s)
  else
    printf "\n"
in
  iter_lines parents stdin
;;
(*-----------------------------*)
let children = hashtbl_reverse_multi father in
iter_lines 
  (fun line ->
    List.iter (printf "%s ") (find_all children line);
    print_newline()
  )
  stdin;
;;
(*-----------------------------*)
(* build an hash that map filename to list of included file *)
open Hashtbl;;
open Str;;

let includes = create (List.length files);;
let includeRE = regexp "^#include <\([a-zA-Z0-9.]+\)>";;
let isincludeline l = string_match includeRE l 0;;
let getincludes fname =
  let includelines =
    List.filter isincludeline (readlines (open_in fname))
  in
  List.map (replace_first includeRE "\1") includelines
;;
List.iter (fun fname -> add includes fname (getincludes fname)) files;;

(*-----------------------------*)
(* build a list of files that does not include system headers *)
let hasnoinclude fname = (find includes fname = []) in
List.filter hasnoinclude (uniq (hashtbl_keys includes));;

(*-----------------------------*)
(* @@PLEAC@@_5.16 *)
(*-----------------------------*)

#!/usr/bin/ocaml
(* dutree - print sorted indented rendition of du output *)
#load "str.cma";;
#load "unix.cma";;

let dirsize = Hashtbl.create 0
let kids = Hashtbl.create 0

(* run du, read in input, save sizes and kids *)
(* return last directory (file?) read *)
let input () =
  let last_name = ref "" in
  let last_push = ref None in
  let argv = "du" :: List.tl (Array.to_list Sys.argv) in
  let ch = Unix.open_process_in (String.concat " " argv) in
  begin
    try
      while true do
        let line = input_line ch in
        match Str.bounded_split (Str.regexp "[ \t]+") line 2 with
          | [size; name] ->
              let size = int_of_string size in
              Hashtbl.replace dirsize name size;
              let parent =
                Str.replace_first (Str.regexp "/[^/]+$") "" name in
              last_name := name;
              last_push :=
                Some (parent,
                      try Some (Hashtbl.find kids parent)
                      with Not_found -> None);
              Hashtbl.replace kids parent
                (name ::
                   (try Hashtbl.find kids parent
                    with Not_found -> []))
          | _ -> failwith line
      done
    with End_of_file ->
      ignore (Unix.close_process_in ch)
  end;
  begin
    match !last_push with
      | None -> ()
      | Some (parent, None) ->
          Hashtbl.remove kids parent
      | Some (parent, Some previous) ->
          Hashtbl.replace kids parent previous
  end;
  !last_name

(* figure out how much is taken up in each directory *)
(* that isn't stored in subdirectories.  add a new *)
(* fake kid called "." containing that much. *)
let rec getdots root =
  let size = Hashtbl.find dirsize root in
  let cursize = ref size in
  if Hashtbl.mem kids root
  then
    begin
      List.iter
        (fun kid ->
           cursize := !cursize - Hashtbl.find dirsize kid;
           getdots kid)
        (Hashtbl.find kids root)
    end;
  if size <> !cursize
  then
    begin
      let dot = root ^ "/." in
      Hashtbl.replace dirsize dot !cursize;
      Hashtbl.replace kids root
        (dot ::
           (try Hashtbl.find kids root
            with Not_found -> []))
    end

(* recursively output everything, *)
(* passing padding and number width in as well *)
(* on recursive calls *)
let rec output ?(prefix="") ?(width=0) root =
  let path = Str.replace_first (Str.regexp ".*/") "" root in
  let size = Hashtbl.find dirsize root in
  let line = Printf.sprintf "%*d %s" width size path in
  Printf.printf "%s%s\n" prefix line;
  let prefix =
    Str.global_replace (Str.regexp "[^|]") " "
      (Str.replace_first (Str.regexp "[0-9] ") "| "
         (prefix ^ line)) in
  if Hashtbl.mem kids root
  then
    begin
      let kids = Hashtbl.find kids root in
      let kids =
        List.rev_map
          (fun kid -> (Hashtbl.find dirsize kid, kid)) kids in
      let kids = List.sort compare kids in
      let kids = List.rev_map (fun (_, kid) -> kid) kids in
      let width =
        String.length
          (string_of_int (Hashtbl.find dirsize (List.hd kids))) in
      List.iter (output ~prefix ~width) kids
    end

let () =
  let topdir = input () in
  getdots topdir;
  output topdir


(* @@PLEAC@@_6.0 *)
(* We will use the Str library distributed with OCaml for regular expressions.
 * There are two ways to use the str library, building a top or passing it to ocaml.
 * Under Unix, you can create a new toplevel which has the Str module:
 *      $ ocamlmktop -o strtop str.cma 
 *      $ ./strtop
 *   Now you don't need to prefix the contents of the str module with Str.
 * The alternative is to pass str.cma as a parameter:
 *     $ ocaml str.cma
 *   Now you may refer to the contents of the str module by using Str. 
 * Under Windows, if you are using ocamlwin.exe you can simply load Str:
 *      # load "str.cma";;
 *)
(* Str.search_forward returns an int or throws an exception if the pattern isn't found.
 * In Perl, the =~ operator returns null. Since these two values have different
 * types in OCaml, we cannot copy this behaviour directly.
 * Instead, we return an impossible index, -1 using try ... with.
 * Another method would be to define an =~ operator and use that directly:
# let (=~) s re = Str.string_match (Str.regexp re) s 0;; 
val ( =~ ) : string -> string -> bool = <fun>
# "abc" =~ "a";;
- : bool = true
# "bc" =~ "a";;
- : bool = false
 * Don't underestimate the power of this. Many of the following examples could be 
 * simplified by defining infix operators.
 *)
try Str.search_forward (Str.regexp pattern) string 0;
with Not_found -> -1;;

try Str.replace_first (Str.regexp pattern) replacement string;
with Not_found -> "";;
(*-----------------------------*)
try (Str.search_forward (Str.regexp "sheep") meadow 0) > -1;
with Not_found -> false;; (* true if meadow contains "sheep" *)

try not ((Str.search_forward (Str.regexp "sheep") meadow 0) > -1);
with Not_found -> true;; (* true if meadow doesn't contain "sheep" *)

let meadow = 
    try Str.replace_first (Str.regexp "old") "new" meadow;
    with Not_found -> meadow;; (* Replace "old" with "new" in meadow *)
(*-----------------------------*)
try 
    let temp = Str.search_forward (Str.regexp "\\bovines?\\b") meadow 0 in
        print_string "Here be sheep!";
with Not_found -> ();;
(*-----------------------------*)
let string = "good food" in
    try
        Str.replace_first (Str.regexp "o*") "e" string;
    with Not_found -> string;;
(*-----------------------------*)
(* There is no way to take command line parameters to ocaml that I know of. 
 * You would first have to compile your OCaml program using ocamlc.
 *)
(*-----------------------------*)
let rec match_num s start=
    if String.length s > 0 then
        try 
            let temp = Str.search_forward (Str.regexp "[0123456789]+") s start in
                print_string (String.concat "" ("Found number " :: Str.matched_string s :: ["\n"]));
                match_num s (temp + 1);
        with Not_found -> ();
    else
        ();;
(*-----------------------------*)
let rec match_group s start numbers=
    if String.length s > 0 then
        try 
            let temp = (Str.search_forward (Str.regexp "[0123456789]+") s start) in
                let numbers = Str.matched_string s :: numbers in 
                    match_group s (temp + 1) numbers;
        with Not_found -> numbers;
    else
        numbers;;
(*-----------------------------*)
let (=+) s re = 
    let result = ref [] in
    let offset = ref 0 in
    while ((String.length s) > !offset) do
        try
            offset := 1 + (Str.search_forward (Str.regexp re) s !offset);
            result := !result @ [Str.matched_string s] @ [];
        with Not_found -> ignore (offset := String.length s)
    done;
    result;;
    
let (=-) s re = 
    let result = ref [] in
    let offset = ref 0 in
    while ((String.length s) > !offset) do
        try
            ignore (Str.search_forward (Str.regexp re) s !offset);
            offset := Str.match_end ();
            result := !result @ [Str.matched_string s] @ [];
        with Not_found -> ignore (offset := String.length s)
    done;
    result;;

let digits = "123456789";;
let yeslap = digits =+ "[1234567890][1234567890][1234567890]";;
let nonlap = digits =- "[1234567890][1234567890][1234567890]";;

print_string "Non-overlapping: ";
List.iter (fun v -> print_string (v ^ " ")) !nonlap;
print_string "\n";;
(* Non-overlapping: 123 456 789 *)

print_string "Overlapping: ";
List.iter (fun v -> print_string (v ^ " ")) !yeslap;
print_string "\n";;
(* Overlapping: 123 234 345 456 567 678 789 *)
(*-----------------------------*)
let index = ref 0;;
let string = "And little lambs eat ivy";;
try
    index := Str.search_forward (Str.regexp "l[^s]*s") string 0;
with Not_found -> ();;
    
print_string ("(" ^ (String.sub string 0 !index) ^ ") ");
print_string ("(" ^ (Str.matched_string string) ^ ") ");
print_string ("(" ^ (Str.string_after string 16) ^ ")\n");;
(* (And ) (little lambs) ( eat ivy) *)

(* @@PLEAC@@_6.1 *)
#load "str.cma";;

(* The Str module doesn't modify strings in place; you always get
   a copy when you perform a substitution. *)
let dst = Str.global_replace (Str.regexp "this") "that" src

(* Strip to basename. *)
let progname = Str.replace_first (Str.regexp "^.*/") "" Sys.argv.(0)

(* Make All Words Title-Cased. *)
let capword =
  Str.global_substitute
    (Str.regexp "\\b.")
    (fun s -> String.uppercase (Str.matched_string s))
    words

(* /usr/man/man3/foo.1 changes to /usr/man/cat3/foo.1 *)
let catpage =
  Str.replace_first (Str.regexp "man\\([0-9]\\)") "cat\\1" manpage

(* Copy and substitute on all strings in a list. *)
let bindirs = ["/usr/bin"; "/bin"; "/usr/local/bin"]
let libdirs =
  List.map (fun s -> Str.replace_first (Str.regexp "bin") "lib" s)
    bindirs
(* ["/usr/lib"; "/lib"; "/usr/local/lib"] *)

(* @@PLEAC@@_6.2 *)
(* Str can do a simple character range match, but it isn't very
   practical for matching alphabetic characters in general. *)
#load "str.cma";;
let () =
  if Str.string_match (Str.regexp "^[A-Za-z]+$") var 0
  then print_endline "var is purely alphabetic"

(* With Pcre, you can use UTF8 support and match characters with
   the letter property. *)
#directory "+pcre";;
#load "pcre.cma";;
let () =
  if Pcre.pmatch ~rex:(Pcre.regexp ~flags:[`UTF8] "^\\pL+$") var
  then print_endline "var is purely alphabetic"

(* @@PLEAC@@_6.3 *)
#load "str.cma";;

(* Str's regexps lack a whitespace-matching pattern.
   Here is a substitute. *)
let whitespace_chars =
  String.concat ""
    (List.map (String.make 1)
       [
         Char.chr 9;  (* HT *)
         Char.chr 10; (* LF *)
         Char.chr 11; (* VT *)
         Char.chr 12; (* FF *)
         Char.chr 13; (* CR *)
         Char.chr 32; (* space *)
       ])
let space = "[" ^ whitespace_chars ^ "]"
let non_space = "[^" ^ whitespace_chars ^ "]"

(* as many non-whitespace characters as possible *)
let regexp = Str.regexp (non_space ^ "+")

(* as many letters, apostrophes, and hyphens *)
let regexp = Str.regexp "[A-Za-z'-]+"

(* usually best *)
let regexp = Str.regexp "\\b\\([A-Za-z]+\\)\\b"

(* fails at ends or w/ punctuation *)
let regexp = Str.regexp (space ^ "\\([A-Za-z]+\\)" ^ space)

(* @@PLEAC@@_6.4 *)
#!/usr/bin/ocaml
(* resname - change all "foo.bar.com" style names in the input stream
   into "foo.bar.com [204.148.40.9]" (or whatever) instead *)

#directory "+pcre";;
#load "pcre.cma";;
#load "unix.cma";;

let regexp =
  Pcre.regexp ~flags:[`EXTENDED] "
    (                     # capture the hostname in substring 1
      (?:                 # these parens for grouping only
        (?! [-_]  )       # lookahead for neither underscore nor dash
        [\\w-] +          # hostname component
        \\.               # and the domain dot
      ) +                 # now repeat that whole thing a bunch of times
      [A-Za-z]            # next must be a letter
      [\\w-] +            # now trailing domain part
    )                     # end of substring 1 capture
  "

let process line =
  print_endline
    (Pcre.substitute_substrings
       ~rex:regexp
       ~subst:(fun subs ->
                 let name = Pcre.get_substring subs 1 in
                 let addr =
                   try
                     Unix.string_of_inet_addr
                       (Unix.gethostbyname name).Unix.h_addr_list.(0)
                   with Not_found -> "???" in
                 name ^ " [" ^ addr ^ "]")
       line)

let () =
  try
    while true do
      let line = read_line () in
      process line
    done
  with End_of_file -> ()

(*-----------------------------*)

let vars = Hashtbl.create 0
let () =
  Hashtbl.replace vars "name" "Bob";
  Hashtbl.replace vars "flavor" "rhubarb"

let () =
  print_endline
    (Pcre.substitute_substrings
       ~rex:(Pcre.regexp ~flags:[`EXTENDED] "
               \\#                #   a pound sign
               (\\w+)             #   the variable name
               \\#                #   another pound sign
             ")
       ~subst:(fun subs -> Hashtbl.find vars (Pcre.get_substring subs 1))
       "Hello, #name#, would you like some #flavor# pie?")

(* @@PLEAC@@_6.5 *)
#load "str.cma";;

let want = 3
let count = ref 0
let pond = "One fish two fish red fish blue fish"
let regexp = Str.regexp_case_fold "\\([a-z]+\\)[ ]+fish\\b"

exception Found of string
let () =
  let start = ref 0 in
  try
    while true do
      ignore (Str.search_forward regexp pond !start);
      start := !start + String.length (Str.matched_string pond);
      incr count;
      if !count = want then raise (Found (Str.matched_group 1 pond))
    done
  with
    | Found color ->
        Printf.printf "The third fish is a %s one.\n" color
    | Not_found ->
        Printf.printf "Only found %d fish!\n" !count

(* The third fish is a red one. *)

(*-----------------------------*)

let colors =
  let start = ref 0 in
  let fish = ref [] in
  begin
    try
      while true do
        ignore (Str.search_forward regexp pond !start);
        start := !start + (String.length (Str.matched_string pond));
        fish := (Str.matched_group 1 pond) :: !fish
      done;
    with Not_found -> ()
  end;
  Array.of_list (List.rev !fish)

let () =
  Printf.printf "The third fish in the pond is %s.\n" colors.(2)

(* The third fish in the pond is red. *)

(*-----------------------------*)

let evens =
  let colors' = ref [] in
  Array.iteri
    (fun i color -> if i mod 2 = 1 then colors' := color :: !colors')
    colors;
  List.rev !colors'
let () =
  Printf.printf "Even numbered fish are %s.\n" (String.concat " " evens)

(* Even numbered fish are two blue. *)

(*-----------------------------*)

let () =
  let count = ref 0 in
  print_endline
    (Str.global_substitute
       (Str.regexp_case_fold "\\b\\([a-z]+\\)\\([ ]+fish\\b\\)")
       (fun s ->
          incr count;
          if !count = 4
          then "sushi" ^ Str.matched_group 2 s
          else Str.matched_group 1 s ^ Str.matched_group 2 s)
       pond)

(* One fish two fish red fish sushi fish *)

(*-----------------------------*)

let pond = "One fish two fish red fish blue fish swim here."
let regexp = Str.regexp_case_fold "\\b\\([a-z]+\\)[ ]+fish\\b"
let colors =
  let rec loop start acc =
    try
      ignore (Str.search_forward regexp pond start);
      loop
        (start + String.length (Str.matched_string pond))
        (Str.matched_group 1 pond :: acc)
    with Not_found ->
      acc in
  loop 0 []
let color = List.hd colors
let () = Printf.printf "Last fish is %s.\n" color

(* Last fish is blue. *)

(* @@PLEAC@@_6.6 *)
#!/usr/bin/ocaml
(* killtags - very bad html tag killer *)
#load "str.cma";;
let regexp = Str.regexp "<[^>]*>"
let () =
  List.iter
    (fun filename ->
       let lines = ref [] in
       let in_channel = open_in filename in
       try
         begin
           try while true do lines := input_line in_channel :: !lines done
           with End_of_file -> ()
         end;
         let contents = String.concat "\n" (List.rev !lines) in
         print_endline
           (String.concat ""
              (List.map
                 (function
                    | Str.Text s -> s
                    | _ -> "")
                 (Str.full_split regexp contents)));
         close_in in_channel
       with e ->
         close_in in_channel;
         raise e)
    (List.tl (Array.to_list Sys.argv))

(*-----------------------------*)

#!/usr/bin/ocaml
(* headerfy - change certain chapter headers to html *)
#load "str.cma";;

let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

let paragraph_stream_of_channel channel =
  let lines = line_stream_of_channel channel in
  let rec next para_lines i =
    match Stream.peek lines, para_lines with
      | None, [] -> None
      | Some "", [] -> Stream.junk lines; next para_lines i
      | Some "", _
      | None, _ -> Some (String.concat "\n" (List.rev para_lines))
      | Some line, _ -> Stream.junk lines; next (line :: para_lines) i in
  Stream.from (next [])

let regexp = Str.regexp "^Chapter[\r\n\t ]+[0-9]+[\r\n\t ]*:[^\r\n]*"

let headerfy chunk =
  String.concat ""
    (List.map
       (function
          | Str.Text s -> s
          | Str.Delim s -> "<H1>" ^ s ^ "</H1>")
       (Str.full_split regexp chunk))

let () =
  List.iter
    (fun filename ->
       let in_channel = open_in filename in
       try
         Stream.iter
           (fun para ->
              print_endline (headerfy para);
              print_newline ())
           (paragraph_stream_of_channel in_channel);
         close_in in_channel
       with e ->
         close_in in_channel;
         raise e)
    (List.tl (Array.to_list Sys.argv))

(* @@PLEAC@@_6.7 *)
#load "str.cma";;
let chunks =
  let lines = ref [] in
  begin
    try while true do lines := input_line stdin :: !lines done
    with End_of_file -> ()
  end;
  let contents = String.concat "\n" (List.rev !lines) in
  Str.full_split (Str.regexp "^\\.\\(Ch\\|Se\\|Ss\\)$") contents
let () =
  Printf.printf
    "I read %d chunks.\n"
    (List.length chunks)

(* @@PLEAC@@_6.8 *)
#load "str.cma";;

(* Creates a stream that produces ranges of items from another stream.
   Production of items starts when when (start_test count item) returns
   true and stops when (finish_test count item) returns true. Multiple
   ranges will be produced if start_test returns true again. The count
   starts at 1. Ranges are inclusive; the item that causes finish_test
   to return true will be produced. *)
let stream_range start_test finish_test stream =
  let active = ref false in
  let count = ref 1 in
  let rec next i =
    match Stream.peek stream with
      | None -> None
      | Some item ->
          if not !active then
            begin
              if start_test !count item
              then (active := true; next i)
              else (Stream.junk stream; incr count; next i)
            end
          else
            begin
              if finish_test !count item then active := false;
              Stream.junk stream;
              incr count;
              Some item
            end in
  Stream.from next

(* Creates a stream that produces items between a pair of indices.
   If start = 2 and finish = 4, items 2, 3, and 4 will be produced.
   The first item is number 1. *)
let stream_range_numbers start finish stream =
  stream_range
    (fun count _ -> count = start)
    (fun count _ -> count = finish)
    stream

(* Creates a stream that produces strings between a pair of regexps.
   The regexp will be tested using Str.string_match. *)
let stream_range_patterns start finish stream =
  stream_range
    (fun _ line -> Str.string_match start line 0)
    (fun _ line -> Str.string_match finish line 0)
    stream

(* Produce a stream of lines from an input channel. *)
let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

(* Print lines 15 through 17 inclusive. *)
let () =
  Stream.iter
    print_endline
    (stream_range_numbers 15 17
       (line_stream_of_channel (open_in datafile)))

(* Print out all <XMP> .. </XMP> displays from HTML doc. *)
let () =
  Stream.iter
    print_endline
    (stream_range_patterns
       (Str.regexp ".*<XMP>")
       (Str.regexp ".*</XMP>")
       (line_stream_of_channel stdin))

(*-----------------------------*)

let in_header = ref true
let in_body = ref false
let () =
  Stream.iter
    (fun line ->
       if !in_header && line = ""
       then (in_header := false; in_body := true)
       else
         begin
           (* do something with line *)
         end)
    (line_stream_of_channel stdin)

(*-----------------------------*)

module StringSet = Set.Make(String)
let seen = ref StringSet.empty
let email_regexp = Str.regexp "\\([^<>(),; \t]+@[^<>(),; \t]+\\)"
let () =
  Stream.iter
    (fun line ->
       List.iter
         (function
            | Str.Delim email ->
                if not (StringSet.mem email !seen)
                then
                  begin
                    seen := StringSet.add email !seen;
                    print_endline email;
                  end
            | _ -> ())
         (Str.full_split email_regexp line))
    (stream_range_patterns
       (Str.regexp "^From:?[ \t]")
       (Str.regexp "^$")
       (line_stream_of_channel stdin))

(* @@PLEAC@@_6.9 *)
#load "str.cma";;

let regexp_string_of_glob s =
  let i, buffer = ref (-1), Buffer.create (String.length s + 8) in
  let read () =
    incr i;
    if !i < String.length s
    then Some s.[!i]
    else None in
  let write = Buffer.add_string buffer in
  let rec parse_glob () =
    match read () with
      | Some '*' -> write ".*"; parse_glob ()
      | Some '?' -> write "."; parse_glob ()
      | Some '[' -> parse_bracket ""
      | Some c -> write (Str.quote (String.make 1 c)); parse_glob ()
      | None -> ()
  and parse_bracket text =
    match read () with
      | Some '!' when text = "" -> parse_bracket "^"
      | Some ']' -> write ("[" ^ text ^ "]"); parse_glob ()
      | Some c -> parse_bracket (text ^ (String.make 1 c))
      | None -> write (Str.quote ("[" ^ text)) in
  write "^";
  parse_glob ();
  write "$";
  Buffer.contents buffer

let regexp_of_glob s =
  Str.regexp (regexp_string_of_glob s)

let regexp_of_glob_case_fold s =
  Str.regexp_case_fold (regexp_string_of_glob s)

(* @@PLEAC@@_6.10 *)
#load "str.cma";;

let popstates = ["CO"; "ON"; "MI"; "WI"; "MN"]

(* Naive version: Compile a regexp each time it is needed. *)
let popgrep1 () =
  try
    begin
      while true do
        let line = input_line stdin in
        try
          List.iter
            (fun state ->
               if (Str.string_match
                     (Str.regexp (".*\\b" ^ (Str.quote state) ^ "\\b"))
                     line 0)
               then (print_endline line; raise Exit))
            popstates
        with Exit -> ()
      done
    end
  with End_of_file -> ()

(* First optimization: Compile the regexps in advance. *)
let popgrep2 () =
  let popstate_regexps =
    List.map
      (fun state ->
         Str.regexp (".*\\b" ^ (Str.quote state) ^ "\\b"))
      popstates in
  try
    begin
      while true do
        let line = input_line stdin in
        try
          List.iter
            (fun regexp ->
               if (Str.string_match regexp line 0)
               then (print_endline line; raise Exit))
            popstate_regexps
        with Exit -> ()
      done
    end
  with End_of_file -> ()

(* Second optimization: Build a single regexp for all states. *)
let popgrep3 () =
  let popstates_regexp =
    Str.regexp
      (".*\\b\\("
       ^ (String.concat "\\|" (List.map Str.quote popstates))
       ^ "\\)\\b") in
  try
    begin
      while true do
        let line = input_line stdin in
        if Str.string_match popstates_regexp line 0
        then print_endline line
      done
    end
  with End_of_file -> ()

(* Speed tests with a 15,000 line input file: *)
let () = popgrep1 ()         (* time: 13.670s *)
let () = popgrep2 ()         (* time:  0.264s *)
let () = popgrep3 ()         (* time:  0.123s *)

(* @@PLEAC@@_6.11 *)
#load "str.cma";;
let () =
  while true do
    print_string "Pattern? ";
    flush stdout;
    let pattern = input_line stdin in
    try ignore (Str.regexp pattern)
    with Failure message ->
      Printf.printf "INVALID PATTERN: %s\n" message
  done

(*-----------------------------*)

let is_valid_pattern pattern =
  try ignore (Str.regexp pattern); true
  with Failure _ -> false

(*-----------------------------*)

#!/usr/bin/ocaml
(* paragrep - trivial paragraph grepper *)
#load "str.cma";;

let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

let paragraph_stream_of_channel channel =
  let lines = line_stream_of_channel channel in
  let rec next para_lines i =
    match Stream.peek lines, para_lines with
      | None, [] -> None
      | Some "", [] -> Stream.junk lines; next para_lines i
      | Some "", _
      | None, _ -> Some (String.concat "\n" (List.rev para_lines))
      | Some line, _ -> Stream.junk lines; next (line :: para_lines) i in
  Stream.from (next [])

let paragrep pat files =
  let regexp =
    begin
      try Str.regexp pat
      with Failure msg ->
        Printf.eprintf "%s: Bad pattern %s: %s\n" Sys.argv.(0) pat msg;
        exit 1
    end in
  let count = ref 0 in
  List.iter
    (fun file ->
       let channel =
         if file = "-"
         then stdin
         else open_in file in
       try
         Stream.iter
           (fun para ->
              incr count;
              try
                ignore (Str.search_forward regexp para 0);
                Printf.printf "%s %d: %s\n\n" file !count para
              with Not_found -> ())
           (paragraph_stream_of_channel channel);
         close_in channel
       with e ->
         close_in channel;
         raise e)
    files

let () =
  match List.tl (Array.to_list Sys.argv) with
    | pat :: [] -> paragrep pat ["-"]
    | pat :: files -> paragrep pat files
    | [] -> Printf.eprintf "usage: %s pat [files]\n" Sys.argv.(0)

(*-----------------------------*)

let safe_pat = Str.quote pat

(* @@PLEAC@@_6.12 *)
(* OCaml does not provide a way to change the locale, and PCRE does
   not appear to be sensitive to the default locale. Regardless, Str
   does not support locales, and PCRE only matches ASCII characters
   for \w and friends. This example instead demonstrates the use of
   PCRE's UTF-8 support to match words, and it does not use locales. *)

#directory "+pcre";;
#load "pcre.cma";;

(* encoded as UTF-8 *)
let name = "andreas k\xc3\xb6nig"

(* the original regexp which is not Unicode-aware *)
let ascii_regexp = Pcre.regexp "\\b(\\w+)\\b"

(* a revised regexp which tests for Unicode letters and numbers *)
let utf8_regexp = Pcre.regexp ~flags:[`UTF8] "([\\pL\\pN]+)"

let () =
  List.iter
    (fun (enc, regexp) ->
       Printf.printf "%s names: %s\n" enc
         (String.concat " "
            (List.map
               String.capitalize
               (List.flatten
                  (Array.to_list
                     (Array.map
                        Array.to_list
                        (Pcre.extract_all
                           ~full_match:false
                           ~rex:regexp
                           name)))))))
    ["ASCII", ascii_regexp; "UTF-8", utf8_regexp]

(*
  ASCII names: Andreas K Nig
  UTF-8 names: Andreas König
*)

(* @@PLEAC@@_6.13 *)
(* Calculates the Levenshtein, or edit distance, between two strings. *)
let levenshtein s t =
  let n = String.length s in
  let m = String.length t in
  match (m, n) with
    | (m, 0) -> m
    | (0, n) -> n
    | (m, n) ->
        let d = Array.init (m + 1) (fun x -> x) in
        let x = ref 0 in
        for i = 0 to n - 1 do
          let e = ref (i + 1) in
          for j = 0 to m - 1 do
            let cost = if s.[i] = t.[j] then 0 else 1 in
            x :=
              min
                (d.(j + 1) + 1)      (* insertion *)
                (min
                   (!e + 1)          (* deletion *)
                   (d.(j) + cost));  (* substitution *)
            d.(j) <- !e;
            e := !x
          done;
          d.(m) <- !x
        done;
        !x

(* Determines if two strings are an approximate match. *)
let amatch ?(percentage=20) s t =
  levenshtein s t * 100 / String.length s <= percentage

let () =
  let dict = open_in "/usr/dict/words" in
  try
    while true do
      let word = input_line dict in
      if amatch "balast" word
      then print_endline word
    done
  with End_of_file -> close_in dict

(*
  ballast
  blast
*)

(* @@PLEAC@@_6.14 *)
#directory "+pcre";;
#load "pcre.cma";;

let s = "12 345 hello 6 7world89 10"
let rex = Pcre.regexp "(\\d+)"

let () =
  let subs = ref (Pcre.exec ~rex s) in
  try
    while true do
      Printf.printf "Found %s\n" (Pcre.get_substring !subs 1);
      subs := Pcre.next_match ~rex !subs
    done
  with Not_found -> ()

(*-----------------------------*)

let () =
  let n = "   49 here" in
  let n = Pcre.replace ~pat:"\\G " ~templ:"0" n in
  print_endline n

(* 00049 here *)

(*-----------------------------*)

let s = "3,4,5,9,120"
let rex = Pcre.regexp "\\G,?(\\d+)"

let () =
  let subs = ref (Pcre.exec ~rex s) in
  try
    while true do
      Printf.printf "Found number %s\n" (Pcre.get_substring !subs 1);
      subs := Pcre.next_match ~rex !subs
    done
  with Not_found -> ()

(*-----------------------------*)

let s = "The year 1752 lost 10 days on the 3rd of September"

let rex = Pcre.regexp "(\\d+)"
let subs = ref (Pcre.exec ~rex s)

let () =
  try
    while true do
      Printf.printf "Found number %s\n" (Pcre.get_substring !subs 1);
      subs := Pcre.next_match ~rex !subs
    done
  with Not_found -> ()

let () =
  let rex = Pcre.regexp "\\G(\\S+)" in
  subs := Pcre.next_match ~rex !subs;
  Printf.printf "Found %s after the last number.\n"
    (Pcre.get_substring !subs 1)

(*
  Found number 1752
  Found number 10
  Found number 3
  Found rd after the last number.
*)

(*-----------------------------*)

let () =
  match Pcre.get_substring_ofs !subs 1 with
    | (start, finish) ->
        Printf.printf
          "The position in 's' is %d..%d\n" start finish

(* The position in 's' is 35..37 *)

(* @@PLEAC@@_6.15 *)
let s = "Even <TT>vi</TT> can edit <TT>troff</TT> effectively."

(* The Str library does not support non-greedy matches. In many cases,
   you can turn a non-greedy match into a greedy one, however: *)

#load "str.cma";;

let () = print_endline (Str.global_replace (Str.regexp "<.*>") "" s)
(* Even  effectively. *)
let () = print_endline (Str.global_replace (Str.regexp "<[^>]*>") "" s)
(* Even vi can edit troff effectively. *)

(* If you need non-greedy matches, you'll want to use PCRE instead: *)

#directory "+pcre";;
#load "pcre.cma";;

let () = print_endline (Pcre.replace ~pat:"<.*?>" ~templ:"" s)
(* Even vi can edit troff effectively. *)

(* Non-greedy matches don't always work the way you expect: *)

let s = "<b><i>this</i> and <i>that</i> are important</b> Oh, <b><i>me too!</i></b>"

let rex = Pcre.regexp "<b><i>(.*?)</i></b>"
let () = print_endline (Pcre.extract ~rex s).(1)
(* this</i> and <i>that</i> are important</b> Oh, <b><i>me too! *)

(* One solution is to use a non-grouping negative lookahead assertion: *)

let rex = Pcre.regexp "<b><i>((?:(?!</b>|</i>).)*)</i></b>"
let () = print_endline (Pcre.extract ~rex s).(1)
(* me too! *)

(* If performance is important, here is a faster technique: *)

let rex = Pcre.regexp ~flags:[`DOTALL; `EXTENDED] "
    <b><i>
    [^<]*  # stuff not possibly bad, and not possibly the end.
    (?:
 # at this point, we can have '<' if not part of something bad
     (?!  </?[ib]>  )   # what we can't have
     <                  # okay, so match the '<'
     [^<]*              # and continue with more safe stuff
    ) *
    </i></b>
"

let () = print_endline (Pcre.extract ~rex s).(0)
(* <b><i>me too!</i></b> *)

(* @@PLEAC@@_6.16 *)
#directory "+pcre";;
#load "pcre.cma";;

let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

let paragraph_stream_of_channel channel =
  let lines = line_stream_of_channel channel in
  let rec next para_lines i =
    match Stream.peek lines, para_lines with
      | None, [] -> None
      | Some "", [] -> Stream.junk lines; next para_lines i
      | Some "", _
      | None, _ -> Some (String.concat "\n" (List.rev para_lines))
      | Some line, _ -> Stream.junk lines; next (line :: para_lines) i in
  Stream.from (next [])

let find_dup_words files =
  let rex = Pcre.regexp ~flags:[`CASELESS; `EXTENDED] "
      \\b            # start at a word boundary (begin letters)
      (\\S+)         # find chunk of non-whitespace
      \\b            # until another word boundary (end letters)
      (
          \\s+       # separated by some whitespace
          \\1        # and that very same chunk again
          \\b        # until another word boundary
      ) +            # one or more sets of those
  " in
  let count = ref 0 in
  List.iter
    (fun file ->
       let channel = if file = "-" then stdin else open_in file in
       try
         Stream.iter
           (fun para ->
              incr count;
              try
                let subs = ref (Pcre.exec ~rex para) in
                while true do
                  Printf.printf "dup word '%s' at paragraph %d.\n"
                    (Pcre.get_substring !subs 1)
                    !count;
                  flush stdout;
                  subs := Pcre.next_match ~rex !subs;
                done
              with Not_found -> ())
           (paragraph_stream_of_channel channel);
         close_in channel
       with e ->
         close_in channel;
         raise e)
    files

let () =
  match List.tl (Array.to_list Sys.argv) with
    | [] -> find_dup_words ["-"]
    | files -> find_dup_words files

(*-----------------------------*)

(*
  This is a test
  test of the duplicate word finder.
*)

(* dup word 'test' at paragraph 1. *)

(*-----------------------------*)

let a = "nobody"
let b = "bodysnatcher"
let () =
  try
    let subs =
      Pcre.exec
        ~pat:"^(\\w+)(\\w+) \\2(\\w+)$"
        (a ^ " " ^ b) in
    Printf.printf "%s overlaps in %s-%s-%s\n"
      (Pcre.get_substring subs 2)
      (Pcre.get_substring subs 1)
      (Pcre.get_substring subs 2)
      (Pcre.get_substring subs 3)
  with Not_found ->
    ()

(* body overlaps in no-body-snatcher *)

(*-----------------------------*)

#!/usr/bin/ocaml
(* prime_pattern -- find prime factors of argument using pattern matching *)
#directory "+pcre";;
#load "pcre.cma";;

let arg = try int_of_string Sys.argv.(1) with _ -> 0
let n = ref (String.make arg 'o')
let rex = Pcre.regexp "^(oo+?)\\1+$"
let templ = "o"
let () =
  try
    while true do
      let pat = Pcre.get_substring (Pcre.exec ~rex !n) 1 in
      Printf.printf "%d " (String.length pat);
      n := Pcre.replace ~pat ~templ !n
    done
  with Not_found ->
    Printf.printf "%d\n" (String.length !n)

(*-----------------------------*)

exception Found of (int * int * int)
let () =
  try
    match
      Pcre.extract
        ~full_match:false
        ~pat:"^(o*)\\1{11}(o*)\\2{14}(o*)\\3{15}$"
        (String.make 281 'o')
    with
      | [| x; y; z |] -> raise (Found
                                  (String.length x,
                                   String.length y,
                                   String.length z))
      | _ -> raise Not_found
  with
    | Found (x, y, z) ->
        Printf.printf "One solution is: x=%d; y=%d; z=%d.\n"
          x y z
    | Not_found ->
        Printf.printf "No solution.\n"

(* One solution is: x=17; y=3; z=2. *)

(*-----------------------------*)

~pat:"^(o+)\\1{11}(o+)\\2{14}(o+)\\3{15}$"
(* One solution is: x=17; y=3; z=2. *)

~pat:"^(o*?)\\1{11}(o*)\\2{14}(o*)\\3{15}$"
(* One solution is: x=0; y=7; z=11. *)

~pat:"^(o+?)\\1{11}(o*)\\2{14}(o*)\\3{15}$"
(* One solution is: x=1; y=3; z=14. *)

(* @@PLEAC@@_6.17 *)
#directory "+pcre";;
#load "pcre.cma";;

let pat = input_line config_channel
let () = if Pcre.pmatch ~pat data then (* ... *) ()

(*-----------------------------*)

(* alpha OR beta *)
let regexp = Pcre.regexp "alpha|beta"

(* alpha AND beta *)
let regexp = Pcre.regexp ~flags:[`DOTALL] "^(?=.*alpha)(?=.*beta)"

(* alpha AND beta, no overlap *)
let regexp = Pcre.regexp ~flags:[`DOTALL] "alpha.*beta|beta.*alpha"

(* NOT pat *)
let regexp = Pcre.regexp ~flags:[`DOTALL] "^(?:(?!pat).)*$"

(* NOT bad BUT good *)
let regexp = Pcre.regexp ~flags:[`DOTALL] "(?=(?:(?!bad).)*$)good"

(*-----------------------------*)

let () =
  if not (Pcre.pmatch ~rex:regexp text)
  then something ()

(*-----------------------------*)

let () =
  if (Pcre.pmatch ~rex:rexexp1 text) && (Pcre.pmatch ~rex:rexexp2 text)
  then something ()

(*-----------------------------*)

let () =
  if (Pcre.pmatch ~rex:rexexp1 text) || (Pcre.pmatch ~rex:rexexp2 text)
  then something ()

(*-----------------------------*)

#!/usr/bin/ocaml
(* minigrep - trivial grep *)
#directory "+pcre";;
#load "pcre.cma";;

let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

let minigrep pat files =
  let rex =
    try Pcre.regexp pat
    with Pcre.BadPattern (msg, _) ->
      Printf.eprintf "%s: Bad pattern %s: %s\n" Sys.argv.(0) pat msg;
      exit 1 in
  let process file =
    let channel = if file = "-" then stdin else open_in file in
    try
      Stream.iter
        (fun line -> if Pcre.pmatch ~rex line then print_endline line)
        (line_stream_of_channel channel);
      close_in channel
    with e ->
      close_in channel;
      raise e in
  List.iter process files

let () =
  match List.tl (Array.to_list Sys.argv) with
    | pat :: [] -> minigrep pat ["-"]
    | pat :: files -> minigrep pat files
    | [] -> Printf.eprintf "usage: %s pat [files]\n" Sys.argv.(0)

(*-----------------------------*)

let string = "labelled"

let () =
  Printf.printf "%b\n"
    (Pcre.pmatch
       ~rex:(Pcre.regexp ~flags:[`DOTALL] "^(?=.*bell)(?=.*lab)")
       string)

let () =
  Printf.printf "%b\n"
    (Pcre.pmatch ~pat:"bell" string && Pcre.pmatch ~pat:"lab" string)

let () =
  if (Pcre.pmatch
        ~rex:(Pcre.regexp ~flags:[`DOTALL; `EXTENDED] "
             ^              # start of string
            (?=             # zero-width lookahead
                .*          # any amount of intervening stuff
                bell        # the desired bell string
            )               # rewind, since we were only looking
            (?=             # and do the same thing
                .*          # any amount of intervening stuff
                lab         # and the lab part
            )")
        string)
  then print_endline "Looks like Bell Labs might be in Murray Hill!"

let () =
  Printf.printf "%b\n"
    (Pcre.pmatch ~pat:"(?:^.*bell.*lab)|(?:^.*lab.*bell)" string)

let brand = "labelled"
let () =
  if (Pcre.pmatch
        ~rex:(Pcre.regexp ~flags:[`DOTALL; `EXTENDED] "
        (?:                 # non-capturing grouper
            ^ .*?           # any amount of stuff at the front
              bell          # look for a bell
              .*?           # followed by any amount of anything
              lab           # look for a lab
          )                 # end grouper
    |                       # otherwise, try the other direction
        (?:                 # non-capturing grouper
            ^ .*?           # any amount of stuff at the front
              lab           # look for a lab
              .*?           # followed by any amount of anything
              bell          # followed by a bell
          )                 # end grouper
      ") brand)
  then print_endline "Our brand has bell and lab separate."

let map = "a map of the world"
let () =
  Printf.printf "%b\n"
    (Pcre.pmatch
       ~rex:(Pcre.regexp ~flags:[`DOTALL] "^(?:(?!waldo).)*$")
       map)

let () =
  if (Pcre.pmatch
        ~rex:(Pcre.regexp ~flags:[`DOTALL; `EXTENDED] "
        ^                   # start of string
        (?:                 # non-capturing grouper
            (?!             # look ahead negation
                waldo       # is he ahead of us now?
            )               # is so, the negation failed
            .               # any character (cuzza /s)
        ) *                 # repeat that grouping 0 or more
        $                   # through the end of the string
      ") map)
  then print_endline "There's no waldo here!"

(*-----------------------------*)

% w | minigrep '^(?!.*ttyp).*tchrist'

(*-----------------------------*)

Pcre.regexp ~flags:[`EXTENDED] "
    ^                       # anchored to the start
    (?!                     # zero-width look-ahead assertion
        .*                  # any amount of anything (faster than .*?)
        ttyp                # the string you don't want to find
    )                       # end look-ahead negation; rewind to start
    .*                      # any amount of anything (faster than .*?)
    tchrist                 # now try to find Tom
"

(*-----------------------------*)

% w | grep tchrist | grep -v ttyp

(*-----------------------------*)

% grep -i 'pattern' files
% minigrep '(?i)pattern' files

(* @@PLEAC@@_6.18 *)
#load "str.cma";;

(* Regexp text for an EUC-JP character *)
let eucjp =
  (String.concat "\\|"
     (* EUC-JP encoding subcomponents: *)
     [
       (* ASCII/JIS-Roman (one-byte/character) *)
       "[\x00-\x7F]";

       (* half-width katakana (two bytes/char) *)
       "\x8E[\xA0-\xDF]";

       (* JIS X 0212-1990 (three bytes/char) *)
       "\x8F[\xA1-\xFE][\xA1-\xFE]";

       (* JIS X 0208:1997 (two bytes/char) *)
       "[\xA1-\xFE][\xA1-\xFE]";
     ])

(* Match any number of EUC-JP characters preceding Tokyo *)
let regexp = Str.regexp ("\\(\\(" ^ eucjp ^ "\\)*\\)\\(\xC5\xEC\xB5\xFE\\)")

(* Search from the beginning for a match *)
let () =
  if Str.string_match regexp string 0
  then print_endline "Found Tokyo"

(* Replace Tokyo with Osaka *)
let () =
  let buffer = Buffer.create (String.length string) in
  let start = ref 0 in
  while Str.string_match regexp string !start do
    Buffer.add_string buffer (Str.matched_group 1 string);
    Buffer.add_string buffer osaka; (* Assuming osaka is defined *)
    start := Str.match_end ();
  done;
  if !start < String.length string
  then Buffer.add_substring buffer string
    !start (String.length string - !start);
  print_endline (Buffer.contents buffer)

(* Split a multi-byte string into characters *)
let () =
  (* One character per list element *)
  let chars =
    Array.map
      (function
         | Str.Delim c -> c
         | Str.Text c -> failwith ("invalid char: " ^ c))
      (Array.of_list
         (Str.full_split
            (Str.regexp eucjp)
            string)) in
  let length = Array.length chars in
  for i = 0 to length - 1 do
    if String.length chars.(i) = 1 then
      begin
        (* Do something interesting with this one-byte character *)
      end
    else
      begin
        (* Do something interesting with this multi-byte character *)
      end
  done;
  (* Glue list back together *)
  let line = String.concat "" (Array.to_list chars) in
  print_endline line

(* Determine if an entire string is valid EUC-JP *)
let is_eucjp s =
  Str.string_match
    (Str.regexp ("\\(" ^ eucjp ^ "\\)*$")) s 0

(* Assuming a similar string has been defined for Shift-JIS *)
let is_sjis s =
  Str.string_match
    (Str.regexp ("\\(" ^ sjis ^ "\\)*$")) s 0

(* Convert from EUC-JP to Unicode, assuming a Hashtbl named
   euc2uni is defined with the appropriate character mappings *)
let () =
  let chars =
    Array.map
      (function
         | Str.Delim c -> c
         | Str.Text c -> failwith ("invalid char: " ^ c))
      (Array.of_list
         (Str.full_split
            (Str.regexp eucjp)
            string)) in
  let length = Array.length chars in
  for i = 0 to length - 1 do
    if Hashtbl.mem euc2uni chars.(i)
    then
      begin
        chars.(i) <- (Hashtbl.find euc2uni chars.(i))
      end
    else
      begin
        (* deal with unknown EUC->Unicode mapping here *)
      end
  done;
  let line = String.concat "" (Array.to_list chars) in
  print_endline line

(* @@PLEAC@@_6.19 *)
#load "str.cma";;

(* Not foolproof, but works in most common cases. *)
let regexp =
  Str.regexp_case_fold
    "\\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\\.[A-Z][A-Z][A-Z]?[A-Z]?\\b"

let () =
  try
    while true do
      print_string "Email: ";
      flush stdout;
      let line = input_line stdin in
      try
        let start = ref 0 in
        while true do
          start := Str.search_forward regexp line !start;
          let string = Str.matched_string line in
          start := !start + String.length string;
          print_string "Found: ";
          print_endline string;
        done
      with Not_found -> ()
    done
  with End_of_file -> ()

(* @@PLEAC@@_6.20 *)
#load "str.cma";;

let () =
  try
    while true do
      print_string "Action: ";
      flush stdout;
      let answer = input_line stdin in
      let regexp = Str.regexp_string_case_fold answer in
      if Str.string_match regexp "SEND" 0
      then print_endline "Action is send"
      else if Str.string_match regexp "STOP" 0
      then print_endline "Action is stop"
      else if Str.string_match regexp "ABORT" 0
      then print_endline "Action is abort"
      else if Str.string_match regexp "LIST" 0
      then print_endline "Action is list"
      else if Str.string_match regexp "EDIT" 0
      then print_endline "Action is edit"
    done
  with End_of_file -> ()

(*-----------------------------*)

(* assumes that invoke_editor, deliver_message, *)
(* file and pager are defined somewhere else. *)
let actions =
  [
    "edit", invoke_editor;
    "send", deliver_message;
    "list", (fun () -> ignore (Sys.command (pager ^ " " ^ file)));
    "abort", (fun () -> print_endline "See ya!"; exit 0);
  ]

let errors = ref 0

let () =
  try
    while true do
      print_string "Action: ";
      flush stdout;
      let answer = input_line stdin in
      (* trim leading white space *)
      let answer = Str.replace_first (Str.regexp "^[ \t]+") "" answer in
      (* trim trailing white space *)
      let answer = Str.replace_first (Str.regexp "[ \t]+$") "" answer in
      let regexp = Str.regexp_string_case_fold answer in
      let found = ref false in
      List.iter
        (fun (action, handler) ->
           if Str.string_match regexp action 0
           then (found := true; handler ()))
        actions;
      if not !found
      then (incr errors; print_endline ("Unknown command: " ^ answer))
    done
  with End_of_file -> ()

(* @@PLEAC@@_6.21 *)
#!/usr/bin/ocaml
(* urlify - wrap HTML links around URL-like constructs *)
#directory "+pcre";;
#load "pcre.cma";;

let urls = "(http|telnet|gopher|file|wais|ftp)"
let ltrs = "\\w"
let gunk = "/#~:.?+=&%@!\\-"
let punc = ".:?\\-"
let any  = ltrs ^ gunk ^ punc

let rex = Pcre.regexp ~flags:[`CASELESS; `EXTENDED]
  (Printf.sprintf "
      \\b                   # start at word boundary
      (                     # begin $1  {
       %s        :          # need resource and a colon
       [%s] +?              # followed by one or more
                            #  of any valid character, but
                            #  be conservative and take only
                            #  what you need to....
      )                     # end   $1  }
      (?=                   # look-ahead non-consumptive assertion
       [%s]*                # either 0 or more punctuation
       [^%s]                #   followed by a non-url char
       |                    # or else
       $                    #   then end of the string
      )
" urls any punc any)

let templ = "<A HREF=\"$1\">$1</A>"

let () =
  try
    while true do
      let line = input_line stdin in
      print_endline (Pcre.replace ~rex ~templ line)
    done
  with End_of_file ->
    ()

(* @@PLEAC@@_6.22 *)
% tcgrep -ril '^From: .*kate' ~/mail

(*-----------------------------*)

#!/usr/bin/ocaml
(* tcgrep: rewrite of tom christiansen's rewrite of grep *)
#load "unix.cma";;

(* http://ocaml.info/home/ocaml_sources.html#pcre-ocaml *)
#directory "+pcre";;
#load "pcre.cma";;

(* http://alain.frisch.fr/soft.html#Getopt *)
#directory "+getopt";;
#load "getopt.cma";;

(* Initialize globals. *)
let me = Pcre.replace ~pat:".*/" Sys.argv.(0)
let matches = ref 0
let errors = ref 0
let grand_total = ref 0
let mult = ref false
let compress = [".z", "zcat"; ".gz", "zcat"; ".Z", "zcat"]

(* Prints usage and exits. *)
let usage () =
  Printf.eprintf "usage: %s [flags] [files]

Standard grep options:
        i   case insensitive
        n   number lines
        c   give count of lines matching
        C   ditto, but >1 match per line possible
        w   word boundaries only
        s   silent mode
        x   exact matches only
        v   invert search sense (lines that DON'T match)
        h   hide filenames
        e   expression (for exprs beginning with -)
        f   file with expressions
        l   list filenames matching

Specials:
        1   1 match per file
        H   highlight matches
        u   underline matches
        r   recursive on directories or dot if none
        t   process directories in 'ls -t' order
        p   paragraph mode (default: line mode)
        P   ditto, but specify separator, e.g. -P '%%'
        a   all files, not just plain text files (not implemented)
        q   quiet about failed file and dir opens
        T   trace files as opened

May use a TCGREP environment variable to set default options.
" me;
  exit 255

(* Produces a stream of lines from an input channel. *)
let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

(* Produces a stream of chunks from an input channel given a delimiter. *)
let delimited_stream_of_channel delim channel =
  let lines = line_stream_of_channel channel in
  let rec next para_lines i =
    match Stream.peek lines, para_lines with
      | None, [] -> None
      | Some delim', [] when delim' = delim ->
          Stream.junk lines; next para_lines i
      | Some delim', _ when delim' = delim ->
          Some (String.concat "\n" (List.rev para_lines))
      | None, _ ->
          Some (String.concat "\n" (List.rev para_lines))
      | Some line, _ -> Stream.junk lines; next (line :: para_lines) i in
  Stream.from (next [])

(* An empty delimiter corresponds to an empty line, so we can create
   a paragraph stream in terms of the previous function. *)
let paragraph_stream_of_channel = delimited_stream_of_channel ""

(* By default, the stream builder will produce lines. This can be changed
   by the -p and -P options. *)
let stream_of_channel = ref line_stream_of_channel

(* Type for command-line options and their values. *)
type opt = OBool of bool | OStr of string

(* Set an option. *)
let opt_set opt c =
  Hashtbl.replace opt c (OBool true)

(* Test an option. *)
let opt_test opt c =
  try
    match Hashtbl.find opt c with
      | OBool b -> b
      | OStr "" -> false
      | OStr _ -> true
  with Not_found ->
    false

(* Convert an option to a string. *)
let opt_str opt c =
  try
    match Hashtbl.find opt c with
      | OBool b -> string_of_bool b
      | OStr s -> s
  with Not_found ->
    ""

(* Gets terminal escape characters. *)
let tput cap =
  let ch = Unix.open_process_in ("tput " ^ cap) in
  try
    let result = input_line ch in
    ignore (Unix.close_process_in ch);
    result
  with
    | End_of_file ->
        ignore (Unix.close_process_in ch);
        ""
    | e ->
        ignore (Unix.close_process_in ch);
        raise e

(* Splits a filename into its base and extension. *)
let splitext name =
  try
    let base = Filename.chop_extension name in
    let i = String.length base in
    let ext = String.sub name i (String.length name - i) in
    base, ext
  with Invalid_argument _ ->
    name, ""

(* Parses command-line arguments. *)
let parse_args () =
  let opt = Hashtbl.create 0 in
  let args = ref [] in

  let optstring = "incCwsxvhe:f:l1HurtpP:aqT" in
  let optstream = Stream.of_string optstring in

  (* Prepare options for Getopt. *)
  let opts =
    let str_setter c =
      (c, Getopt.nolong,
       None,
       Some (fun s -> Hashtbl.replace opt c (OStr s))) in
    let int_setter c =
      (c, Getopt.nolong,
       Some (fun () -> Hashtbl.replace opt c (OBool true)),
       None) in
    let rec loop acc =
      match Stream.peek optstream with
        | Some c ->
            (Stream.junk optstream;
             match Stream.peek optstream with
               | Some ':' ->
                   Stream.junk optstream;
                   loop (str_setter c :: acc)
               | _ ->
                   loop (int_setter c :: acc))
        | None -> List.rev acc in
    loop [] in

  (* Handle TCGREP environment variable. *)
  let cmdline = ref (List.tl (Array.to_list Sys.argv)) in
  Array.iter
    (fun env ->
       if (String.length env > 7
           && String.sub env 0 7 = "TCGREP=")
       then
         begin
           let s = String.sub env 7 (String.length env - 7) in
           let s = if s.[0] <> '-' then "-" ^ s else s in
           cmdline := s :: !cmdline
         end)
    (Unix.environment ());
  let cmdline = Array.of_list !cmdline in

  (* Parse command-line options using Getopt. *)
  begin
    try
      Getopt.parse
        opts (fun arg -> args := arg :: !args)
        cmdline 0 (Array.length cmdline - 1);
      args := List.rev !args
    with Getopt.Error e ->
      prerr_endline e;
      usage ()
  end;

  (* Read patterns from file or command line. *)
  let patterns =
    if opt_test opt 'f'
    then
      begin
        let in_channel =
          try open_in (opt_str opt 'f')
          with e ->
            Printf.eprintf "%s: can't open %s: %s\n"
              me (opt_str opt 'f') (Printexc.to_string e);
            exit 255 in
        try
          let acc = ref [] in
          Stream.iter
            (fun pat -> acc := pat :: !acc)
            (line_stream_of_channel in_channel);
          close_in in_channel;
          List.rev !acc
        with e ->
          close_in in_channel;
          Printf.eprintf "%s: error reading %s: %s\n"
            me (opt_str opt 'f') (Printexc.to_string e);
          exit 255
      end
    else if opt_test opt 'e'
    then [opt_str opt 'e']
    else [match !args with h :: t -> (args := t; h) | [] -> usage ()] in

  (* Terminal escape characters for highlighting options. *)
  let highlight =
    if opt_test opt 'H'
    then tput "smso" ^ "$1" ^ tput "rmso"
    else if opt_test opt 'u'
    then tput "smul" ^ "$1" ^ tput "rmul"
    else "$1" in

  (* Regular expression flags to use. *)
  let flags = ref [] in
  if opt_test opt 'i' then flags := `CASELESS :: !flags;

  (* Options for paragraph modes. *)
  if opt_test opt 'p'
  then stream_of_channel := paragraph_stream_of_channel;
  if opt_test opt 'P'
  then stream_of_channel := delimited_stream_of_channel (opt_str opt 'P');

  (* Word boundary option. *)
  let patterns =
    if opt_test opt 'w'
    then List.map (fun pat -> "\\b" ^ pat ^ "\\b") patterns
    else patterns in

  (* Exact match option. *)
  let patterns =
    if opt_test opt 'x'
    then List.map (fun pat -> "^" ^ pat ^ "$") patterns
    else patterns in

  (* Options that imply other options. *)
  if opt_test opt 'l' then opt_set opt '1';
  if opt_test opt 'u' then opt_set opt 'H';
  if opt_test opt 'C' then opt_set opt 'c';
  if opt_test opt 'c' then opt_set opt 's';
  if opt_test opt 's' && not (opt_test opt 'c') then opt_set opt '1';

  (* Compile the regular expression patterns. *)
  let rexes =
    List.map
      (fun pat ->
         try Pcre.regexp ~flags:!flags ("(" ^ pat ^ ")")
         with Pcre.BadPattern (msg, _) ->
           Printf.eprintf "%s: bad pattern %s: %s\n" me pat msg;
           exit 255)
      patterns in

  (* Increments the matches variable by the number of matches
     (or non-matches) in the given line. *)
  let count_matches line =
    if opt_test opt 'v'
    then fun rex ->
      (if not (Pcre.pmatch ~rex line) then incr matches)
    else if opt_test opt 'C'
    then fun rex ->
      (matches := !matches + (try Array.length (Pcre.extract_all ~rex line)
                              with Not_found -> 0))
    else fun rex ->
      (if Pcre.pmatch ~rex line then incr matches) in

  (* Counts matches in a line and returns the line with any
     necessary highlighting. *)
  let matcher line =
    List.iter (count_matches line) rexes;
    if opt_test opt 'H'
    then
      List.fold_left
        (fun line rex ->
           Pcre.replace ~rex ~templ:highlight line)
        line rexes
    else line in

  (* List of files or directories to process. *)
  let files =
    match !args with
      | [] -> if opt_test opt 'r' then ["."] else ["-"]
      | [arg] -> [arg]
      | args -> (mult := true; args) in

  (* Overrides for options that affect the multiple-file flag. *)
  if opt_test opt 'h' then mult := false;
  if opt_test opt 'r' then mult := true;

  (* Return the three values to be processed by matchfiles. *)
  opt, matcher, files

(* Used to break out of loops and abort processing of the current file. *)
exception NextFile

(* Runs given matcher on a list of files using the specified options. *)
let rec matchfiles opt matcher files =
  (* Handles a single directory. *)
  let matchdir dir =
    if not (opt_test opt 'r')
    then
      begin
        if opt_test opt 'T'
        then (Printf.eprintf "%s: \"%s\" is a directory, but no -r given\n"
                me dir;
              flush stderr)
      end
    else
      begin
        let files =
          try Some (Sys.readdir dir)
          with e ->
            if not (opt_test opt 'q')
            then (Printf.eprintf "%s: can't readdir %s: %s\n"
                    me dir (Printexc.to_string e);
                  flush stderr);
            incr errors;
            None in
        match files with
          | Some files ->
              let by_mtime a b =
                compare
                  (Unix.stat (Filename.concat dir b)).Unix.st_mtime
                  (Unix.stat (Filename.concat dir a)).Unix.st_mtime in
              if opt_test opt 't'
              then Array.sort by_mtime files;
              matchfiles opt matcher
                (Array.to_list
                   (Array.map
                      (Filename.concat dir)
                      files))
          | None -> ()
      end in

  (* Handles a single file. *)
  let matchfile file =
    (* Keep a running total of matches for this file. *)
    let total = ref 0 in

    (* Keep track of the current line number. *)
    let line_num = ref 0 in

    (* Shadow close_in to properly close process channels for compressed
       files and avoid closing stdin. *)
    let process_open = ref false in
    let close_in channel =
      if !process_open
      then ignore (Unix.close_process_in channel)
      else if channel != stdin then close_in channel in

    (* Process a line (or paragraph, with -p or -P) of input. *)
    let matchline line =
       incr line_num;
       matches := 0;
       let line = matcher line in
       if !matches > 0
       then
         begin
           total := !total + !matches;
           grand_total := !grand_total + !matches;
           if opt_test opt 'l'
           then (print_endline file; raise NextFile)
           else if not (opt_test opt 's')
           then (Printf.printf "%s%s%s%s\n"
                   (if !mult
                    then file ^ ":"
                    else "")
                   (if opt_test opt 'n'
                    then (string_of_int !line_num
                          ^ (if opt_test opt 'p' || opt_test opt 'P'
                             then ":\n"
                             else ":"))
                    else "")
                   line
                   (if opt_test opt 'p' || opt_test opt 'P'
                    then "\n" ^ String.make 20 '-'
                    else "");
                 flush stdout);
           if opt_test opt '1' then raise NextFile
         end in

    (* Get a channel for the file, starting a decompression process if
       necessary. If None, the file will be skipped. *)
    let maybe_channel =
      if file = "-"
      then (if Unix.isatty Unix.stdin && not (opt_test opt 'q')
            then (Printf.eprintf "%s: reading from stdin\n" me;
                  flush stderr);
            Some stdin)
      else if not (Sys.file_exists file)
      then (if not (opt_test opt 'q')
            then (Printf.eprintf "%s: file \"%s\" does not exist\n"
                    me file;
                  flush stderr);
            incr errors;
            None)
      else if List.mem_assoc (snd (splitext file)) compress
      then (process_open := true;
            try Some (Unix.open_process_in
                        (List.assoc (snd (splitext file)) compress
                         ^ " < " ^ file))
            with e ->
              if not (opt_test opt 'q')
              then (Printf.eprintf "%s: %s: %s\n" me file
                      (Printexc.to_string e);
                    flush stderr);
              incr errors;
              None)
      else (try Some (open_in file)
            with e ->
              if not (opt_test opt 'q')
              then (Printf.eprintf "%s: %s: %s\n" me file
                      (Printexc.to_string e);
                    flush stderr);
              incr errors;
              None) in

    (* Run matcher on the open channel, then close the channel. *)
    match maybe_channel with
      | None -> ()
      | Some channel ->
          begin
            try
              if opt_test opt 'T'
              then (Printf.eprintf "%s: checking %s\n" me file;
                    flush stderr);
              Stream.iter matchline (!stream_of_channel channel);
              close_in channel
            with
              | NextFile ->
                  close_in channel
              | e ->
                  close_in channel;
                  raise e
          end;
          if opt_test opt 'c'
          then (Printf.printf "%s%d\n"
                  (if !mult then file ^ ":" else "")
                  !total;
                flush stdout) in

  (* Handle each of the specified files and directories. *)
  List.iter
    (fun file ->
       if file = "-"
       then matchfile file
       else if try Sys.is_directory file with _ -> false
       then matchdir file
       else matchfile file)
    files

(* Parse command line arguments, run matcher, and set result status. *)
let opt, matcher, files = parse_args ()
let () =
  matchfiles opt matcher files;
  if !errors > 0 then exit 2;
  if !grand_total > 0 then exit 0;
  exit 1

(* @@PLEAC@@_6.23 *)
#directory "+pcre";;
#load "pcre.cma";;

(*-----------------------------*)

Pcre.pmatch
  ~rex:(Pcre.regexp
          ~flags:[`CASELESS]
          "^m*(d?c{0,3}|c[dm])(l?x{0,3}|x[lc])(v?i{0,3}|i[vx])$")
  input

(*-----------------------------*)

Pcre.replace
  ~pat:"(\\S+)(\\s+)(\\S+)"
  ~templ:"$3$2$1"
  input

(*-----------------------------*)

Pcre.extract
  ~full_match:false
  ~pat:"(\\w+)\\s*=\\s*(.*)\\s*$"
  input

(*-----------------------------*)

Pcre.pmatch
  ~pat:".{80,}"
  input

(*-----------------------------*)

Pcre.extract
  ~full_match:false
  ~pat:"(\\d+)/(\\d+)/(\\d+) (\\d+):(\\d+):(\\d+)"
  input

(*-----------------------------*)

Pcre.replace
  ~pat:"/usr/bin"
  ~templ:"/usr/local/bin"
  input

(*-----------------------------*)

Pcre.substitute_substrings
  ~pat:"%([0-9A-Fa-f][0-9A-Fa-f])"
  ~subst:(fun subs ->
            let c = Pcre.get_substring subs 1 in
            String.make 1 (Char.chr (int_of_string ("0x" ^ c))))
  input

(*-----------------------------*)

Pcre.replace
  ~rex:(Pcre.regexp
          ~flags:[`DOTALL; `EXTENDED] "
            /\\*  # Match the opening delimiter
            .*?   # Match a minimal number of characters
            \\*/  # Match the closing delimiter
          ")
  input

(*-----------------------------*)

Pcre.replace ~pat:"^\\s+" input
Pcre.replace ~pat:"\\s+$" input

(*-----------------------------*)

Pcre.replace ~pat:"\\\\n" ~templ:"\n" input

(*-----------------------------*)

Pcre.replace ~pat:"^.*::" input

(*-----------------------------*)

Pcre.extract
  ~full_match:false
  ~pat:"^([01]?\\d\\d|2[0-4]\\d|25[0-5])\\.([01]?\\d\\d|2[0-4]\\d|25[0-5])\\.\
         ([01]?\\d\\d|2[0-4]\\d|25[0-5])\\.([01]?\\d\\d|2[0-4]\\d|25[0-5])$"
  input

(*-----------------------------*)

Pcre.replace ~pat:"^.*/" input

(*-----------------------------*)

let termcap = ":co#80:li#24:"
let cols =
  try int_of_string (Pcre.extract ~pat:":co#(\\d+):" termcap).(1)
  with Not_found | Failure "int_of_string" -> 80

(*-----------------------------*)

let name =
  Pcre.replace
    ~pat:" /\\S+/"
    ~templ:" "
    (" " ^ String.concat " " (Array.to_list Sys.argv))

(*-----------------------------*)

#load "unix.cma";;
let () =
  let ch = Unix.open_process_in "uname -a" in
  let os = input_line ch in
  ignore (Unix.close_process_in ch);
  if not (Pcre.pmatch ~rex:(Pcre.regexp ~flags:[`CASELESS] "linux") os)
  then print_endline "This isn't Linux"

(*-----------------------------*)

Pcre.replace ~pat:"\n\\s+" ~templ:" " input

(*-----------------------------*)

let nums =
  Array.map
    (fun group -> float_of_string group.(1))
    (Pcre.extract_all
       ~pat:"(\\d+\\.?\\d*|\\.\\d+)"
       input)

(*-----------------------------*)

let capwords =
  Array.map
    (fun group -> group.(1))
    (Pcre.extract_all
       ~pat:"(\\b[^\\Wa-z0-9_]+\\b)"
       input)

(*-----------------------------*)

let lowords =
  Array.map
    (fun group -> group.(1))
    (Pcre.extract_all
       ~pat:"(\\b[^\\WA-Z0-9_]+\\b)"
       input)

(*-----------------------------*)

let icwords =
  Array.map
    (fun group -> group.(1))
    (Pcre.extract_all
       ~pat:"(\\b[^\\Wa-z0-9_][^\\WA-Z0-9_]*\\b)"
       input)

(*-----------------------------*)

let links =
  Array.map
    (fun group -> group.(1))
    (Pcre.extract_all
       ~rex:(Pcre.regexp
               ~flags:[`DOTALL; `CASELESS]
               "<A[^>]+?HREF\\s*=\\s*[\"']?([^'\" >]+?)[ '\"]?>")
       input)

(*-----------------------------*)

let initial =
  try (Pcre.extract ~pat:"^\\S+\\s+(\\S)\\S*\\s+\\S" input).(1)
  with Not_found -> ""

(*-----------------------------*)

Pcre.replace ~pat:"\"([^\"]*)\"" ~templ:"``$1''" input

(*-----------------------------*)

let sentences =
  Array.map
    (fun group -> group.(1))
    (Pcre.extract_all
       ~pat:"(\\S.*?\\pP)(?=  |\\Z)"
       (Pcre.replace ~pat:" {3,}" ~templ:"  "
          (Pcre.replace ~pat:"\n" ~templ:" "
             (Pcre.replace ~pat:"(\\pP\n)" ~templ:"$1  "
                input))))

(*-----------------------------*)

Pcre.extract ~full_match:false ~pat:"(\\d{4})-(\\d\\d)-(\\d\\d)" input

(*-----------------------------*)

Pcre.pmatch
  ~pat:"^[01]?[- .]?(\\([2-9]\\d{2}\\)|[2-9]\\d{2})[- .]?\\d{3}[- .]?\\d{4}$"
  input

(*-----------------------------*)

Pcre.pmatch
  ~rex:(Pcre.regexp
          ~flags:[`CASELESS]
          "\\boh\\s+my\\s+gh?o(d(dess(es)?|s?)|odness|sh)\\b")
  input

(*-----------------------------*)

let lines =
  Array.map
    (fun group -> group.(1))
    (Pcre.extract_all
       ~pat:"([^\010\013]*)(\010\013?|\013\010?)"
       input)


(* @@PLEAC@@_7.0 *)
#load "str.cma";;

(* Print all lines that contain the word "blue" in the input file
   /usr/local/widgets/data to stdout. *)
let () =
  let in_channel = open_in "/usr/local/widgets/data" in
  try
    while true do
      let line = input_line in_channel in
      try
        ignore (Str.search_forward (Str.regexp_string "blue") line 0);
        print_endline line
      with Not_found -> ()
    done
  with End_of_file ->
    close_in in_channel

(*-----------------------------*)

let () =
  let regexp = Str.regexp ".*[0-9]" in
  try
    while true do
      (* reads from stdin *)
      let line = input_line stdin in
      (* writes to stderr *)
      if not (Str.string_match regexp line 0)
      then prerr_endline "No digit found.";
      (* writes to stdout *)
      Printf.printf "Read: %s\n" line;
      flush stdout
    done
  with End_of_file ->
    close_out stdout

(*-----------------------------*)

(* Write to an output file the usual way. *)
let () =
  let logfile = open_out "/tmp/log" in
  output_string logfile "Countdown initiated...\n";
  close_out logfile;
  print_endline "You have 30 seconds to reach minimum safety distance."

(* Write to an output file using redirection. *)
#load "unix.cma";;
let () =
  let logfile = open_out "/tmp/log" in
  let old_descr = Unix.dup Unix.stdout in
  (* switch to logfile for output *)
  Unix.dup2 (Unix.descr_of_out_channel logfile) Unix.stdout;
  print_endline "Countdown initiated...";
  (* return to original output *)
  Unix.dup2 old_descr Unix.stdout;
  print_endline "You have 30 seconds to reach minimum safety distance."

(* @@PLEAC@@_7.1 *)
(* open file "path" for reading only *)
let source =
  try open_in path
  with Sys_error msg -> failwith ("Couldn't read from " ^ msg)

(* open file "path" for writing only *)
let sink =
  try open_out path
  with Sys_error msg -> failwith ("Couldn't write to " ^ msg)

(*-----------------------------*)

#load "unix.cma";;

(* open file "path" for reading only *)
let source =
  try Unix.openfile path [Unix.O_RDONLY] 0o644
  with Unix.Unix_error (code, func, param) ->
    failwith (Printf.sprintf "Couldn't open %s for reading: %s"
                path (Unix.error_message code))

(* open file "path" for writing only *)
let sink =
  try Unix.openfile path [Unix.O_WRONLY; Unix.O_CREAT] 0o644
  with Unix.Unix_error (code, func, param) ->
    failwith (Printf.sprintf "Couldn't open %s for writing: %s"
                path (Unix.error_message code))

(*-----------------------------*)

(* open file "path" for reading and writing *)
let fh =
  try Unix.openfile filename [Unix.O_RDWR] 0o644
  with Unix.Unix_error (code, func, param) ->
    failwith (Printf.sprintf "Couldn't open %s for read and write: %s"
                filename (Unix.error_message code))

(*-----------------------------*)

(* open file "path" read only *)
let fh = open_in path
let fh = Unix.openfile path [Unix.O_RDONLY] 0o644

(*-----------------------------*)

(* open file "path" write only, create it if it does not exist *)
let fh = open_out path
let fh = Unix.openfile path [Unix.O_WRONLY; Unix.O_TRUNC; Unix.O_CREAT] 0o600

(*-----------------------------*)

(* open file "path" write only, fails if file exists *)
let fh = Unix.openfile path [Unix.O_WRONLY; Unix.O_EXCL; Unix.O_CREAT] 0o600

(*-----------------------------*)

(* open file "path" for appending *)
let fh =
  open_out_gen [Open_wronly; Open_append; Open_creat] 0o600 path
let fh =
  Unix.openfile path [Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT] 0o600

(*-----------------------------*)

(* open file "path" for appending only when file exists *)
let fh = Unix.openfile path [Unix.O_WRONLY; Unix.O_APPEND] 0o600

(*-----------------------------*)

(* open file "path" for reading and writing *)
let fh = Unix.openfile path [Unix.O_RDWR] 0o600

(*-----------------------------*)

(* open file "path" for reading and writing,
   create a new file if it does not exist *)
let fh = Unix.openfile path [Unix.O_RDWR; Unix.O_CREAT] 0o600

(*-----------------------------*)

(* open file "path" for reading and writing, fails if file exists *)
let fh = Unix.openfile path [Unix.O_RDWR; Unix.O_EXCL; Unix.O_CREAT] 0o600

(* @@PLEAC@@_7.2 *)
(* Nothing different needs to be done with OCaml *)

(* @@PLEAC@@_7.3 *)
#load "str.cma";;
#load "unix.cma";;

let expanduser =
  let regexp = Str.regexp "^~\\([^/]*\\)" in
  let replace s =
    match Str.matched_group 1 s with
      | "" ->
          (try Unix.getenv "HOME"
           with Not_found ->
             (try Unix.getenv "LOGDIR"
              with Not_found ->
                (Unix.getpwuid (Unix.getuid ())).Unix.pw_dir))
      | user -> (Unix.getpwnam user).Unix.pw_dir in
  Str.substitute_first regexp replace

(*-----------------------------*)

    ~user
    ~user/blah
    ~
    ~/blah

(* @@PLEAC@@_7.4 *)
#load "unix.cma";;

open Unix

(* Raises an exception on failure. *)
let file = openfile filename [ O_RDONLY ] 0o640

exception ErrString of string

let file =
  try openfile filename [ O_RDONLY ] 0o640
  with Unix_error (e, f, n) ->
    raise (ErrString
             (Printf.sprintf "Could not open %s for read: %s"
                n (error_message e)))

(* @@PLEAC@@_7.5 *)
(* Open a new temporary file for writing. Filename.open_temp_file
   safeguards against race conditions and returns both the filename
   and an output channel. *)
let name, out_channel = Filename.open_temp_file "prefix-" ".suffix"

(* Install an at_exit handler to remove the temporary file when this
   program exits. *)
let () = at_exit (fun () -> Sys.remove name)

(*-----------------------------*)

#load "unix.cma";;

let () =
  (* Open a temporary file for reading and writing. *)
  let name = Filename.temp_file "prefix-" ".suffix" in
  let descr = Unix.openfile name [Unix.O_RDWR] 0o600 in

  (* Write ten lines of output. *)
  let out_channel = Unix.out_channel_of_descr descr in
  for i = 1 to 10 do
    Printf.fprintf out_channel "%d\n" i
  done;
  flush out_channel;

  (* Seek to the beginning and read the lines back in. *)
  let in_channel = Unix.in_channel_of_descr descr in
  seek_in in_channel 0;
  print_endline "Tmp file has:";
  let rec loop () =
    print_endline (input_line in_channel);
    loop () in
  try loop() with End_of_file -> ();

  (* Close the underlying file descriptor and remove the file. *)
  Unix.close descr;
  Sys.remove name

(* @@PLEAC@@_7.6 *)
#load "str.cma";;

let main data =
  List.iter
    (fun line ->
       (* process the line *)
       ())
    (Str.split (Str.regexp "\n") data)

let () = main "\
your data goes here
"

(* @@PLEAC@@_7.7 *)
#load "str.cma";;

let parse_args () =
  match List.tl (Array.to_list Sys.argv) with
    | [] -> ["-"]
    | args -> args

let run_filter func args =
  List.iter
    (fun arg ->
       let in_channel =
         match arg with
           | "-" -> stdin
           | arg -> open_in arg in
       try
         begin
           try
             while true do
               func (input_line in_channel)
             done
           with End_of_file -> ()
         end;
         close_in in_channel
       with e ->
         close_in in_channel;
         raise e)
    args

let () =
  run_filter
    (fun line ->
       (* do something with the line *)
       ())
    (parse_args ())

(*-----------------------------*)

(* arg demo 1: Process optional -c flag *)
let chop_first = ref false
let args =
  match parse_args () with
    | "-c" :: rest -> chop_first := true; rest
    | args -> args

(* arg demo 2: Process optional -NUMBER flag *)
let columns = ref None
let args =
  match parse_args () with
    | arg :: rest
      when Str.string_match (Str.regexp "^-\\([0-9]+\\)$") arg 0 ->
        columns := Some (int_of_string (Str.matched_group 1 arg));
        rest
    | args -> args

(* arg demo 3: Process clustering -a, -i, -n, or -u flags *)
let append = ref false
let ignore_ints = ref false
let nostdout = ref false
let unbuffer = ref false
let args =
  let rec parse_flags = function
    | "" -> ()
    | s ->
        (match s.[0] with
           | 'a' -> append      := true
           | 'i' -> ignore_ints := true
           | 'n' -> nostdout    := true
           | 'u' -> unbuffer    := true
           | _ ->
               Printf.eprintf "usage: %s [-ainu] [filenames] ...\n"
                 Sys.argv.(0);
               flush stderr;
               exit 255);
        parse_flags (String.sub s 1 (String.length s - 1)) in
  List.rev
    (List.fold_left
       (fun acc ->
          function
            | "" -> acc
            | s when s.[0] = '-' ->
                parse_flags (String.sub s 1 (String.length s - 1));
                acc
            | arg -> arg :: acc)
       []
       (parse_args ()))

(*-----------------------------*)

(* findlogin - print all lines containing the string "login" *)

let () =
  run_filter
    (fun line ->
       if Str.string_match (Str.regexp ".*login.*") line 0
       then print_endline line)
    (parse_args ())

(*-----------------------------*)

(* lowercase - turn all lines into lowercase *)

let () =
  run_filter
    (fun line -> print_endline (String.lowercase line))
    (parse_args ())

(*-----------------------------*)

(* countchunks - count how many words are used *)

let chunks = ref 0
let () =
  run_filter
    (fun line ->
       if line <> "" && line.[0] == '#'
       then ()
       else chunks := !chunks
         + List.length (Str.split (Str.regexp "[ \t]+") line))
    (parse_args ());
  Printf.printf "Found %d chunks\n" !chunks

(* @@PLEAC@@_7.8 *)
(* Modify a file in place. *)
let modify func old new' =
  let old_in = open_in old in
  let new_out = open_out new' in
  begin
    try
      while true do
        let line = input_line old_in in
        func new_out line
      done
    with End_of_file -> ()
  end;
  close_in old_in;
  close_out new_out;
  Sys.rename old (old ^ ".orig");
  Sys.rename new' old

(* Insert lines at line 20. *)
let () =
  let count = ref 0 in
  modify
    (fun out line ->
       incr count;
       if !count = 20
       then (output_string out "Extra line 1\n";
             output_string out "Extra line 2\n");
       output_string out line;
       output_string out "\n")
    old new'

(* Delete lines 20..30. *)
let () =
  let count = ref 0 in
  modify
    (fun out line ->
       incr count;
       if !count < 20 || !count > 30
       then (output_string out line;
             output_string out "\n"))
    old new'

(* @@PLEAC@@_7.9 *)
(* An equivalent of Perl's -i switch does not exist in OCaml. *)

(* @@PLEAC@@_7.10 *)
#load "str.cma";;
#load "unix.cma";;

(* Modify a file in place. *)
let modify func file =
  let in' = open_in file in
  let lines = ref [] in
  begin
    try
      while true do
        let line = input_line in' in
        lines := func line :: !lines
      done
    with End_of_file -> ()
  end;
  close_in in';
  let lines = List.rev !lines in
  let out = open_out file in
  List.iter
    (fun line ->
       output_string out line;
       output_string out "\n")
    lines;
  close_out out

(* Replace DATE with the current date. *)
let () =
  let tm = Unix.localtime (Unix.time ()) in
  let date = Printf.sprintf "%02d/%02d/%04d"
    (tm.Unix.tm_mon + 1)
    tm.Unix.tm_mday
    (tm.Unix.tm_year + 1900) in
  modify
    (Str.global_replace (Str.regexp "DATE") date)
    infile

(* @@PLEAC@@_7.11 *)
#load "unix.cma";;

let descr = Unix.openfile path [Unix.O_RDWR] 0o664

let () =
  Unix.lockf descr Unix.F_LOCK 0;
  (* update file, then ... *)
  Unix.close descr

let () =
  try Unix.lockf descr Unix.F_TLOCK 0
  with Unix.Unix_error (error, _, _) ->
    Printf.eprintf
      "can't immediately write-lock the file (%s), blocking ...\n"
      (Unix.error_message error);
    flush stderr;
    Unix.lockf descr Unix.F_LOCK 0

(*-----------------------------*)

#load "unix.cma";;

let descr = Unix.openfile "numfile" [Unix.O_RDWR; Unix.O_CREAT] 0o664

let () =
  Unix.lockf descr Unix.F_LOCK 0;
  (* Now we have acquired the lock, it's safe for I/O *)
  let num =
    try int_of_string (input_line (Unix.in_channel_of_descr descr))
    with _ -> 0 in
  ignore (Unix.lseek descr 0 Unix.SEEK_SET);
  Unix.ftruncate descr 0;
  let out = Unix.out_channel_of_descr descr in
  output_string out (string_of_int (num + 1));
  output_string out "\n";
  flush out;
  Unix.close descr

(* @@PLEAC@@_7.12 *)
(* OCaml automatically flushes after calling these functions: *)
let () =
  print_endline "I get flushed.";
  print_newline (); (* Me too! *)
  prerr_endline "So do I.";
  prerr_newline () (* As do I. *)

(* The Printf functions allow a format specifier of "%!" to trigger
   an immediate flush. *)
let () = Printf.printf "I flush %s%! and %s!\n%!" "here" "there"

(*-----------------------------*)

(* seeme - demo stdio output buffering *)
#load "unix.cma";;
let () =
  output_string stdout "Now you don't see it...";
  Unix.sleep 2;
  print_endline "now you do"

(*-----------------------------*)

(* A channel can be explicitly flushed: *)
let () = flush stderr

(* All channels can be flushed at once (errors are ignored): *)
let () = flush_all ()

(* Closing a channel flushes automatically: *)
let () =
  output_string stdout "I get written.\n";
  close_out stdout

(* Calls to exit result in a flush_all, and exit is always called at
   termination even if an error occurs. *)
let () =
  output_string stderr "Bye!\n";
  exit 0

(* @@PLEAC@@_7.13 *)
#load "unix.cma";;

let () =
  (* list all file descriptors to poll *)
  let readers = [file_descr1; file_descr2; file_descr3] in
  let ready, _, _ = Unix.select readers [] [] 0.0 in
  (* input waiting on the filehandles in "ready" *)
  ()

(*-----------------------------*)

let () =
  let in_channel = Unix.in_channel_of_descr file_descr in
  let found, _, _ = Unix.select [file_descr] [] [] 0.0 (* just check *) in
  match found with
    | [] -> ()
    | _ ->
        let line = input_line in_channel in
        Printf.printf "I read %s\n%!" line

(* @@PLEAC@@_7.14 *)
#load "unix.cma";;

(* Pass the O_NONBLOCK flag when calling Unix.openfile. *)
let file_descr =
  try Unix.openfile "/dev/cua0" [Unix.O_RDWR; Unix.O_NONBLOCK] 0o666
  with Unix.Unix_error (code, func, param) ->
    Printf.eprintf "Can't open modem: %s\n" (Unix.error_message code);
    exit 2

(*-----------------------------*)

(* If the file descriptor already exists, use Unix.set_nonblock. *)
let () = Unix.set_nonblock file_descr

(*-----------------------------*)

(* In non-blocking mode, calls that would block throw exceptions. *)
let () =
  let chars_written =
    try
      Some (Unix.single_write file_descr buffer 0 (String.length buffer))
    with
      | Unix.Unix_error (Unix.EAGAIN, _, _)
      | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> None in
  match chars_written with
    | Some n when n = String.length buffer ->
        (* successfully wrote *)
        ()
    | Some n ->
        (* incomplete write *)
        ()
    | None ->
        (* would block *)
        ()

let () =
  let chars_read =
    try
      Some (Unix.read file_descr buffer 0 buffer_size)
    with
      | Unix.Unix_error (Unix.EAGAIN, _, _)
      | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> None in
  match chars_read with
    | Some n ->
        (* successfully read n bytes from file_descr *)
        ()
    | None ->
        (* would block *)
        ()

(* @@PLEAC@@_7.15 *)
#load "unix.cma";;

(* OCaml does not expose the FIONREAD ioctl call. It's better to use
   non-blocking reads anyway. There is the following function in
   Pervasives which gives you the length of an input channel, but it
   works by doing a seek so it only works on regular files: *)

let () =
  let length = in_channel_length in_channel in
  (* ... *)
  ()

(* @@PLEAC@@_7.16 *)
(* Channels and file descriptors are ordinary, first-class values in
   OCaml. No special contortions are necessary to store them in data
   structures, pass them as arguments, etc. *)

(* @@PLEAC@@_7.17 *)
module FileCache = struct
  let isopen = Hashtbl.create 0
  let maxopen = ref 16

  let resize () =
    if Hashtbl.length isopen >= !maxopen
    then
      begin
        let newlen = !maxopen / 3 in
        let items = ref [] in
        Hashtbl.iter
          (fun filename (chan, count) ->
             items := (count, filename, chan) :: !items)
          isopen;
        let items = Array.of_list !items in
        Array.sort compare items;
        let pivot = Array.length items - newlen in
        for i = 0 to Array.length items - 1 do
          let (count, filename, chan) = items.(i) in
          if i < pivot
          then (close_out chan;
                Hashtbl.remove isopen filename)
          else (Hashtbl.replace isopen filename (chan, 0))
        done
      end

  let output ?(mode=[Open_creat; Open_append]) ?(perm=0o640) filename data =
    let (chan, count) =
      try Hashtbl.find isopen filename
      with Not_found ->
        resize ();
        (open_out_gen mode perm filename, 0) in
    output_string chan data;
    flush chan;
    Hashtbl.replace isopen filename (chan, count + 1)

  let close filename =
    try
      match Hashtbl.find isopen filename with (chan, _) ->
        close_out chan;
        Hashtbl.remove isopen filename
    with Not_found -> ()
end

(*-----------------------------*)

(* splitwulog - split wuftpd log by authenticated user *)
#load "str.cma";;
let outdir = "/var/log/ftp/by-user"
let regexp = Str.regexp " "
let () =
  try
    while true do
      let line = input_line stdin in
      let chunks = Array.of_list (Str.split regexp line) in
      let user = chunks.(Array.length chunks - 5) in
      let path = Filename.concat outdir user in
      FileCache.output path (line ^ "\n")
    done
  with End_of_file -> ()

(* @@PLEAC@@_7.18 *)
(* Save your channels in a list and iterate through them normally. *)
let () =
  List.iter
    (fun channel ->
       output_string channel stuff_to_print)
    channels

(* For convenience, you can define a helper function and use currying. *)
let write data channel = output_string channel data
let () = List.iter (write stuff_to_print) channels

(*-----------------------------*)

(* Open a pipe to "tee". Requires a Unix environment. *)
#load "unix.cma";;
let () =
  let channel =
    Unix.open_process_out "tee file1 file2 file3 >/dev/null" in
  output_string channel "whatever\n";
  ignore (Unix.close_process_out channel)

(*-----------------------------*)

(* Redirect standard output to a tee. *)
let () =
  let reader, writer = Unix.pipe () in
  match Unix.fork () with
    | 0 ->
        Unix.close writer;
        Unix.dup2 reader Unix.stdin;
        Unix.close reader;
        Unix.execvp "tee" [| "tee"; "file1"; "file2"; "file3" |]
    | pid ->
        Unix.close reader;
        Unix.dup2 writer Unix.stdout;
        Unix.close writer
let () =
  print_endline "whatever";
  close_out stdout;
  ignore (Unix.wait ())

(* @@PLEAC@@_7.19 *)
(* An abstraction barrier exists between file descriptor numbers and
   file_descr values, but Ocamlnet provides functions in the Netsys
   module to map between the two. *)
#load "unix.cma";;
#directory "+netsys";;
#load "netsys.cma";;

(* Open the descriptor itself. *)
let file_descr = Netsys.file_descr_of_int fdnum
let in_channel = Unix.in_channel_of_descr file_descr

(* Open a copy of the descriptor. *)
let file_descr = Unix.dup (Netsys.file_descr_of_int fdnum)
let in_channel = Unix.in_channel_of_descr file_descr

(* After processing... *)
let () = close_in in_channel

(* @@PLEAC@@_7.20 *)
#load "unix.cma";;

let () =
  (* Take copies of the file descriptors. *)
  let oldout = Unix.dup Unix.stdout in
  let olderr = Unix.dup Unix.stderr in

  (* Redirect stdout and stderr. *)
  let output =
    Unix.openfile
      "/tmp/program.out"
      [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC]
      0o666 in
  Unix.dup2 output Unix.stdout;
  Unix.close output;
  let copy = Unix.dup Unix.stdout in
  Unix.dup2 copy Unix.stderr;
  Unix.close copy;

  (* Run the program. *)
  ignore (Unix.system joe_random_process);

  (* Close the redirected file handles. *)
  Unix.close Unix.stdout;
  Unix.close Unix.stderr;

  (* Restore stdout and stderr. *)
  Unix.dup2 oldout Unix.stdout;
  Unix.dup2 olderr Unix.stderr;

  (* Avoid leaks by closing the independent copies. *)
  Unix.close oldout;
  Unix.close olderr

(* @@PLEAC@@_7.21 *)
drivelock.ml:

#!/usr/bin/ocaml
(* drivelock - demo LockDir module *)
#use "netlock.ml";;
let die msg = prerr_endline msg; exit 1
let () =
  Sys.set_signal Sys.sigint
    (Sys.Signal_handle (fun _ -> die "outta here"));
  LockDir.debug := true;
  let path =
    try Sys.argv.(1)
    with Invalid_argument _ ->
      die ("usage: " ^ Sys.argv.(0) ^ " <path>") in
  (try LockDir.nflock ~naptime:2 path
   with LockDir.Error _ ->
     die ("couldn't lock " ^ path ^ " in 2 seconds"));
  Unix.sleep 100;
  LockDir.nunflock path

(*-----------------------------*)

netlock.ml:

#load "unix.cma";;

(* module to provide very basic filename-level *)
(* locks.  No fancy systems calls.  In theory, *)
(* directory info is sync'd over NFS.  Not *)
(* stress tested. *)

module LockDir :
sig

  exception Error of string

  val debug : bool ref
  val check : int ref
  val nflock : ?naptime:int -> string -> unit
  val nunflock : string -> unit

end = struct

  exception Error of string

  let debug = ref false
  let check = ref 1

  module StringSet = Set.Make(String)
  let locked_files = ref StringSet.empty

  (* helper function *)
  let name2lock pathname =
    let dir = Filename.dirname pathname in
    let file = Filename.basename pathname in
    let dir = if dir = "." then Sys.getcwd () else dir in
    let lockname = Filename.concat dir (file ^ ".LOCKDIR") in
    lockname

  let nflock ?(naptime=0) pathname =
    let lockname = name2lock pathname in
    let whosegot = Filename.concat lockname "owner" in
    let start = Unix.time () in
    let missed = ref 0 in

    (* if locking what I've already locked, raise exception *)
    if StringSet.mem pathname !locked_files
    then raise (Error (pathname ^ " already locked"));

    Unix.access (Filename.dirname pathname) [Unix.W_OK];

    begin
      try
        while true do
          try
            Unix.mkdir lockname 0o777;
            raise Exit
          with Unix.Unix_error (e, _, _) ->
            incr missed;
            if !missed > 10
            then raise (Error
                          (Printf.sprintf "can't get %s: %s"
                             lockname (Unix.error_message e)));
            if !debug
            then
              begin
                let owner = open_in whosegot in
                let lockee = input_line owner in
                close_in owner;
                Printf.eprintf "%s[%d]: lock on %s held by %s\n%!"
                  Sys.argv.(0) (Unix.getpid ()) pathname lockee
              end;
            Unix.sleep !check;
            if naptime > 0 && Unix.time () > start +. float naptime
            then raise Exit
        done
      with Exit -> ()
    end;

    let owner =
      try
        open_out_gen [Open_wronly; Open_creat; Open_excl] 0o666 whosegot
      with Sys_error e ->
        raise (Error ("can't create " ^ e)) in
    Printf.fprintf owner "%s[%d] on %s\n"
      Sys.argv.(0) (Unix.getpid ()) (Unix.gethostname ());
    close_out owner;
    locked_files := StringSet.add pathname !locked_files

  (* free the locked file *)
  let nunflock pathname =
    let lockname = name2lock pathname in
    let whosegot = Filename.concat lockname "owner" in
    Unix.unlink whosegot;
    if !debug then Printf.eprintf "releasing lock on %s\n%!" lockname;
    locked_files := StringSet.remove pathname !locked_files;
    Unix.rmdir lockname

  (* anything forgotten? *)
  let () =
    at_exit
      (fun () ->
         StringSet.iter
           (fun pathname ->
              let lockname = name2lock pathname in
              let whosegot = Filename.concat lockname "owner" in
              Printf.eprintf "releasing forgotten %s\n%!" lockname;
              Unix.unlink whosegot;
              Unix.rmdir lockname)
           !locked_files)
end

(* @@PLEAC@@_7.22 *)
(* The "fcntl" system call is not available in the OCaml standard library.
   You would have to drop down to C in order to lock regions of a file as
   described in the original Perl recipe. *)


(* @@PLEAC@@_8.0 *)
let () =
  try
    while true do
      let line = input_line datafile in
      let size = String.length line in
      Printf.printf "%d\n" size             (* output size of line *)
    done
  with End_of_file -> ()

(*-----------------------------*)

let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

let output_size line =
  Printf.printf "%d\n" (String.length line) (* output size of line *)

let () =
  Stream.iter output_size (line_stream_of_channel datafile)

(*-----------------------------*)

let lines =
  let xs = ref [] in
  Stream.iter
    (fun x -> xs := x :: !xs)
    (line_stream_of_channel datafile);
  List.rev !xs

(*-----------------------------*)

let slurp_channel channel =
  let buffer_size = 4096 in
  let buffer = Buffer.create buffer_size in
  let string = String.create buffer_size in
  let chars_read = ref 1 in
  while !chars_read <> 0 do
    chars_read := input channel string 0 buffer_size;
    Buffer.add_substring buffer string 0 !chars_read
  done;
  Buffer.contents buffer

let slurp_file filename =
  let channel = open_in_bin filename in
  let result =
    try slurp_channel channel
    with e -> close_in channel; raise e in
  close_in channel;
  result

let whole_file = slurp_file filename

(*-----------------------------*)

let () =
  (* Onetwothree *)
  List.iter (output_string handle) ["One"; "two"; "three"];

  (* Sent to default output handle *)
  print_string "Baa baa black sheep\n"

(*-----------------------------*)

let buffer = String.make 4096 '\000'
let rv = input handle buffer 0 4096
(* rv is the number of bytes read, *)
(* buffer holds the data read *)

(*-----------------------------*)

#load "unix.cma";;
let () =
  Unix.ftruncate descr length;
  Unix.truncate (Printf.sprintf "/tmp/%d.pid" (Unix.getpid ())) length

(*-----------------------------*)

let () =
  let pos = pos_in datafile in
  Printf.printf "I'm %d bytes from the start of datafile.\n" pos

(*-----------------------------*)

let () =
  seek_in in_channel pos;
  seek_out out_channel pos

#load "unix.cma";;
let () =
  Unix.lseek descr 0     Unix.SEEK_END; (* seek to the end    *)
  Unix.lseek descr pos   Unix.SEEK_SET; (* seek to pos        *)
  Unix.lseek descr (-20) Unix.SEEK_CUR; (* seek back 20 bytes *)

(*-----------------------------*)

#load "unix.cma";;
let () =
  let written =
    Unix.write datafile mystring 0 (String.length mystring) in
  let read =
    Unix.read datafile mystring 5 256 in
  if read <> 256 then Printf.printf "only read %d bytes, not 256\n" read

(*-----------------------------*)

#load "unix.cma";;
let () =
  (* don't change position *)
  let pos = Unix.lseek handle 0 Unix.SEEK_CUR in
  (* ... *)
  ()

(* @@PLEAC@@_8.1 *)
let () =
  let buffer = Buffer.create 16 in
  let rec loop () =
    let line = input_line chan in
    if line <> "" && line.[String.length line - 1] = '\\'
    then (Buffer.add_string
            buffer (String.sub line 0 (String.length line - 1));
          loop ())
    else Buffer.add_string buffer line;
    let line = Buffer.contents buffer in
    Buffer.clear buffer;
    (* process full record in line here *)
    loop () in
  try loop () with End_of_file -> ()

(* @@PLEAC@@_8.2 *)
#load "unix.cma";;

let () =
  let proc = Unix.open_process_in ("wc -l < " ^ file) in
  let count = int_of_string (input_line proc) in
  ignore (Unix.close_process_in proc);
  (* count now holds the number of lines read *)
  ()

(*-----------------------------*)

let () =
  let count = ref 0 in
  let chan = open_in file in
  (try
     while true do
       ignore (input_line chan);
       incr count
     done
   with End_of_file -> close_in chan);
  (* !count now holds the number of lines read *)
  ()

(*-----------------------------*)

#load "str.cma";;

let () =
  let delim = Str.regexp "[ \n\r\t]*$" in
  let count = ref 0 in
  let in_para = ref false in
  let chan = open_in file in
  (try
     while true do
       if Str.string_match delim (input_line chan) 0
       then in_para := false
       else begin
         if not !in_para then incr count;
         in_para := true
       end
     done
   with End_of_file -> close_in chan);
  (* !count now holds the number of paragraphs read *)
  ()

(* @@PLEAC@@_8.3 *)
let word_stream_of_channel channel =
  (* Thanks to Mac Mason for figuring this out. *)
  let buffer = (Scanf.Scanning.from_channel channel) in
  Stream.from
    (fun count ->
       try
         match Scanf.bscanf buffer " %s " (fun x -> x) with
           | "" -> None
           | s -> Some s
       with End_of_file ->
         None)

(*-----------------------------*)

let () =
  Stream.iter
    (fun chunk ->
       (* do something with chunk *)
       ())
    (word_stream_of_channel stdin)

(*-----------------------------*)

(* Make a word frequency count *)
let seen = Hashtbl.create 0
let () =
  Stream.iter
    (fun word ->
       Hashtbl.replace seen word
         (try Hashtbl.find seen word + 1
          with Not_found -> 1))
    (word_stream_of_channel stdin)

(* output hash in a descending numeric sort of its values *)
let () =
  let words = ref [] in
  Hashtbl.iter (fun word _ -> words := word :: !words) seen;
  List.iter
    (fun word ->
       Printf.printf "%5d %s\n" (Hashtbl.find seen word) word)
    (List.sort
       (fun a b -> compare (Hashtbl.find seen b) (Hashtbl.find seen a))
       !words)

(*-----------------------------*)

(* Line frequency count *)

let line_stream_of_channel channel =
  Stream.from
    (fun _ -> try Some (input_line channel) with End_of_file -> None)

let seen = Hashtbl.create 0
let () =
  Stream.iter
    (fun line ->
       Hashtbl.replace seen line
         (try Hashtbl.find seen line + 1
          with Not_found -> 1))
    (line_stream_of_channel stdin)

let () =
  let lines = ref [] in
  Hashtbl.iter (fun line _ -> lines := line :: !lines) seen;
  List.iter
    (fun line ->
       Printf.printf "%5d %s\n" (Hashtbl.find seen line) line)
    (List.sort
       (fun a b -> compare (Hashtbl.find seen b) (Hashtbl.find seen a))
       !lines)

(* @@PLEAC@@_8.4 *)
let lines = ref []
let () =
  try
    while true do
      lines := input_line chan :: !lines
    done
  with End_of_file -> ()
let () =
  List.iter
    (fun line ->
       (* do something with line *)
       ())
    !lines

(* @@PLEAC@@_8.5 *)
#load "unix.cma";;

let sometime = 1

let () =
  let chan = open_in file in
  while Sys.file_exists file do
    (try
       let line = input_line chan in
       (* ... *)
       ()
     with End_of_file ->
       Unix.sleep sometime)
  done;
  close_in chan

(* @@PLEAC@@_8.6 *)
let () =
  Random.self_init ();
  let count = ref 1 in
  let line = ref "" in
  try
    while true do
      let next = input_line stdin in
      if Random.int !count < 1 then line := next;
      incr count
    done
  with End_of_file ->
    (* !line is the random line *)
    ()

(* @@PLEAC@@_8.7 *)
(* assumes the fisher_yates_shuffle function from Chapter 4 *)
let shuffle list =
  let array = Array.of_list list in
  fisher_yates_shuffle array;
  Array.to_list array

let () =
  Random.self_init ();
  let lines = ref [] in
  (try
     while true do
       lines := (input_line input) :: !lines
     done
   with End_of_file -> ());
  let reordered = shuffle !lines in
  List.iter
    (fun line ->
       output_string output line;
       output_char output '\n')
    reordered

(* @@PLEAC@@_8.8 *)
(* Read lines until the desired line number is found. *)
let () =
  let line = ref "" in
  for i = 1 to desired_line_number do line := input_line handle done;
  print_endline !line

(* Read lines into an array. *)
let () =
  let lines = ref [] in
  (try while true do lines := input_line handle :: !lines done
   with End_of_file -> ());
  let lines = Array.of_list (List.rev !lines) in
  let line = lines.(desired_line_number) in
  print_endline line

(* Build an index file containing line offsets. *)
let build_index data_file index_file =
  set_binary_mode_out index_file true;
  let offset = ref 0 in
  try
    while true do
      ignore (input_line data_file);
      output_binary_int index_file !offset;
      offset := pos_in data_file
    done
  with End_of_file ->
    flush index_file

(* Read a line using the index file. *)
let line_with_index data_file index_file line_number =
  set_binary_mode_in index_file true;
  let size = 4 in
  let i_offset = size * (line_number - 1) in
  seek_in index_file i_offset;
  let d_offset = input_binary_int index_file in
  seek_in data_file d_offset;
  input_line data_file

(*-----------------------------*)

#!/usr/bin/ocaml
(* print_line-v1 - linear style *)

let () =
  if Array.length Sys.argv <> 3
  then (prerr_endline "usage: print_line FILENAME LINE_NUMBER"; exit 255);

  let filename = Sys.argv.(1) in
  let line_number = int_of_string Sys.argv.(2) in
  let infile =
    try open_in filename
    with Sys_error e -> (prerr_endline e; exit 255) in
  let line = ref "" in
  begin
    try
      for i = 1 to line_number do line := input_line infile done
    with End_of_file ->
      Printf.eprintf "Didn't find line %d in %s\n" line_number filename;
      exit 255
  end;
  print_endline !line

(*-----------------------------*)

#!/usr/bin/ocaml
(* print_line-v2 - index style *)
#load "unix.cma";;
(* build_index and line_with_index from above *)
let () =
  if Array.length Sys.argv <> 3
  then (prerr_endline "usage: print_line FILENAME LINE_NUMBER"; exit 255);

  let filename = Sys.argv.(1) in
  let line_number = int_of_string Sys.argv.(2) in
  let orig =
    try open_in filename
    with Sys_error e -> (prerr_endline e; exit 255) in

  (* open the index and build it if necessary *)
  (* there's a race condition here: two copies of this *)
  (* program can notice there's no index for the file and *)
  (* try to build one.  This would be easily solved with *)
  (* locking *)
  let indexname = filename ^ ".index" in
  let idx = Unix.openfile indexname [Unix.O_CREAT; Unix.O_RDWR] 0o666 in
  build_index orig (Unix.out_channel_of_descr idx);

  let line =
    try
      line_with_index orig (Unix.in_channel_of_descr idx) line_number
    with End_of_file ->
      Printf.eprintf "Didn't find line %d in %s\n" line_number filename;
      exit 255 in
  print_endline line

(* @@PLEAC@@_8.9 *)
(* given "record" with field separated by "pattern",
   extract "fields". *)
#load "str.cma";;
let regexp = Str.regexp pattern
let fields = Str.split_delim regexp record

(* same as above using PCRE library, available at:
   http://www.ocaml.info/home/ocaml_sources.html#pcre-ocaml *)
#directory "+pcre";;
#load "pcre.cma";;
let fields = Pcre.split ~pat:pattern record

(*-----------------------------*)

# Str.full_split (Str.regexp "[+-]") "3+5-2";;
- : Str.split_result list =
[Str.Text "3"; Str.Delim "+"; Str.Text "5"; Str.Delim "-"; Str.Text "2"]

# Pcre.split ~pat:"([+-])" "3+5-2";;
- : string list = ["3"; "+"; "5"; "-"; "2"]

(*-----------------------------*)

let fields = Str.split_delim (Str.regexp ":") record
let fields = Str.split_delim (Str.regexp "[ \n\r\t]+") record
let fields = Str.split_delim (Str.regexp " ") record

let fields = Pcre.split ~pat:":" record
let fields = Pcre.split ~pat:"\\s+" record
let fields = Pcre.split ~pat:" " record

(* @@PLEAC@@_8.10 *)
#load "unix.cma";;

let () =
  let descr = Unix.openfile file [Unix.O_RDWR] 0o666 in
  let in_channel = Unix.in_channel_of_descr descr in
  let position = ref 0 in
  let last_position = ref 0 in
  begin
    try
      while true do
        ignore (input_line in_channel);
        last_position := !position;
        position := pos_in in_channel;
      done
    with End_of_file -> ()
  end;
  Unix.ftruncate descr !last_position;
  Unix.close descr

(* @@PLEAC@@_8.11 *)
set_binary_mode_in in_channel true
set_binary_mode_out out_channel true

(*-----------------------------*)

let () =
  let gifname = "picture.gif" in
  let gif = open_in gifname in
  set_binary_mode_in gif true;
  (* now DOS won't mangle binary input from "gif" *)
  set_binary_mode_out stdout true;
  (* now DOS won't mangle binary output to "stdout" *)
  let buff = String.make 8192 '\000' in
  let len = ref (-1) in
  while !len <> 0 do
    len := input gif buff 0 8192;
    output stdout buff 0 !len
  done

(* @@PLEAC@@_8.12 *)
let () =
  let address = recsize * recno in
  seek_in fh address;
  really_input fh buffer 0 recsize

(*-----------------------------*)

let () =
  let address = recsize * (recno - 1) in
  (* ... *)
  ()

(* @@PLEAC@@_8.13 *)
let () =
  let address = recsize * recno in
  seek_in in_channel address;
  let buffer = String.create recsize in
  really_input in_channel buffer 0 recsize;
  close_in in_channel;
  (* update fields, then *)
  seek_out out_channel address;
  output_string out_channel buffer;
  close_out out_channel

(*-----------------------------*)

#!/usr/bin/ocaml
(* weekearly -- set someone's login date back a week *)
#load "unix.cma";;

let sizeof = 4 + 12 + 16
let user =
  if Array.length Sys.argv > 1
  then Sys.argv.(1)
  else (try Sys.getenv "USER"
        with Not_found -> Sys.getenv "LOGNAME")

let address = (Unix.getpwnam user).Unix.pw_uid * sizeof

let () =
  let lastlog = open_in "/var/log/lastlog" in
  seek_in lastlog address;
  let line = String.make 12 ' ' in
  let host = String.make 16 ' ' in
  let time = input_binary_int lastlog in
  really_input lastlog line 0 12;
  really_input lastlog host 0 16;
  let buffer = String.create sizeof in
  really_input lastlog buffer 0 sizeof;
  close_in lastlog;

  let time = time - 24 * 7 * 60 * 60 in (* back-date a week *)

  let lastlog = open_out_gen [Open_wronly] 0o666 "/var/log/lastlog" in
  seek_out lastlog address;
  output_binary_int lastlog time;
  close_out lastlog

(* @@PLEAC@@_8.14 *)
let () =
  let in_channel = open_in_bin file in
  seek_in in_channel addr;
  let buffer = Buffer.create 0 in
  let ch = ref (input_char in_channel) in
  while !ch <> '\000' do
    Buffer.add_char buffer !ch;
    ch := input_char in_channel;
  done;
  close_in in_channel;
  let string = Buffer.contents buffer in
  print_endline string

(*-----------------------------*)

(* bgets - get a string from an address in a binary file *)
open Printf

let file, addrs =
  match Array.to_list Sys.argv with
    | _ :: file :: addrs when List.length addrs > 0 -> file, addrs
    | _ -> eprintf "usage: %s file addr ...\n" Sys.argv.(0); exit 0

let () =
  let in_channel = open_in_bin file in
  List.iter
    (fun addr ->
       let addr = int_of_string addr in
       seek_in in_channel addr;
       let buffer = Buffer.create 0 in
       let ch = ref (input_char in_channel) in
       while !ch <> '\000' do
         Buffer.add_char buffer !ch;
         ch := input_char in_channel;
       done;
       printf "%#x %#o %d \"%s\"\n"
         addr addr addr (Buffer.contents buffer))
    addrs;
  close_in in_channel

(*-----------------------------*)

(* strings - pull strings out of a binary file *)
#load "str.cma";;

let find_strings =
  let pat = "[\040-\176\r\n\t ]" in
  let regexp = Str.regexp (pat ^ pat ^ pat ^ pat ^ "+") in
  fun f input ->
    List.iter
      (function Str.Delim string -> f string | _ -> ())
      (Str.full_split regexp input)

let file =
  try Sys.argv.(1)
  with Invalid_argument _ ->
    Printf.eprintf "usage: %s file\n" Sys.argv.(0);
    exit 0

let () =
  let in_channel = open_in_bin file in
  try
    while true do
      let buffer = Buffer.create 0 in
      let ch = ref (input_char in_channel) in
      while !ch <> '\000' do
        Buffer.add_char buffer !ch;
        ch := input_char in_channel;
      done;
      find_strings print_endline (Buffer.contents buffer)
    done
  with End_of_file ->
    close_in in_channel

(* @@PLEAC@@_8.15 *)
(* Using the Bitstring library by Richard W.M. Jones.
   http://code.google.com/p/bitstring/ *)
let () =
  try
    while true do
      let bitstring = Bitstring.bitstring_of_chan_max file recordsize in
      let fields = unpack bitstring in
      (* ... *)
      ()
    done
  with Match_failure _ -> ()

(*-----------------------------*)

(* Layout based on /usr/include/bits/utmp.h for a Linux system. *)
let recordsize = 384
let unpack bits =
  bitmatch bits with
    | { ut_type : 16 : littleendian;
        _ : 16; (* padding *)
        ut_pid : 32 : littleendian;
        ut_line : 256 : string;
        ut_id : 32 : littleendian;
        ut_user : 256 : string;
        ut_host : 2048 : string;
        ut_exit : 32 : littleendian;
        ut_session : 32 : littleendian;
        ut_tv_sec : 32 : littleendian;
        ut_tv_usec : 32 : littleendian;
        ut_addr_v6 : 128 : string } ->
        (ut_type, ut_pid, ut_line, ut_id, ut_user, ut_host,
         ut_exit, ut_session, ut_tv_sec, ut_tv_usec, ut_addr_v6)

(* @@PLEAC@@_8.16 *)
#load "str.cma";;

let user_preferences = Hashtbl.create 0

let () =
  let comments = Str.regexp "#.*" in
  let leading_white = Str.regexp "^[ \t]+" in
  let trailing_white = Str.regexp "[ \t]+$" in
  let equals_delim = Str.regexp "[ \t]*=[ \t]*" in
  Stream.iter
    (fun s ->
       let s = Str.replace_first comments "" s in
       let s = Str.replace_first leading_white "" s in
       let s = Str.replace_first trailing_white "" s in
       (* anything left? *)
       if String.length s > 0 then
         match Str.bounded_split_delim equals_delim s 2 with
           | [var; value] -> Hashtbl.replace user_preferences var value
           | _ -> failwith s)
    (* defined in this chapter's introduction *)
    (line_stream_of_channel config)

(*-----------------------------*)

(* load variables from ocaml source - toplevel scripts only *)
#use ".progrc";;

(* @@PLEAC@@_8.17 *)
#load "unix.cma";;

let () =
  try
    let {Unix.st_dev = dev;
         st_ino = ino;
         st_kind = kind;
         st_perm = perm;
         st_nlink = nlink;
         st_uid = uid;
         st_gid = gid;
         st_rdev = rdev;
         st_size = size;
         st_atime = atime;
         st_mtime = mtime;
         st_ctime = ctime} = Unix.stat filename in
    (* ... *)
    ()
  with Unix.Unix_error (e, _, _) ->
    Printf.eprintf "no %s: %s\n" filename (Unix.error_message e);
    exit 0

(*-----------------------------*)

let () =
  let info =
    try Unix.stat filename
    with Unix.Unix_error (e, _, _) ->
      Printf.eprintf "no %s: %s\n" filename (Unix.error_message e);
      exit 0 in
  if info.Unix.st_uid = 0
  then Printf.printf "Superuser owns %s\n" filename;
  if info.Unix.st_atime > info.Unix.st_mtime
  then Printf.printf "%s has been read since it was written.\n" filename

(*-----------------------------*)

let is_safe path =
  let info = Unix.stat path in
  (* owner neither superuser nor me *)
  (* the real uid can be retrieved with Unix.getuid () *)
  if (info.Unix.st_uid <> 0) && (info.Unix.st_uid <> Unix.getuid ())
  then false
  else
    (* check whether the group or other can write file. *)
    (* use 0o066 to detect either reading or writing *)
    if info.Unix.st_perm land 0o022 = 0
    then true  (* no one else can write this *)
    else if info.Unix.st_kind <> Unix.S_DIR
    then false (* non-directories aren't safe *)
    else if info.Unix.st_perm land 0o1000 <> 0
    then true  (* but directories with the sticky bit (0o1000) are *)
    else false

(*-----------------------------*)

let is_verysafe path =
  let rec loop path parent =
    if not (is_safe path)
    then false
    else if path <> parent
    then loop parent (Filename.dirname parent)
    else true in
  loop path (Filename.dirname path)

(* @@PLEAC@@_8.18 *)
(*pp camlp4o -I /path/to/bitstring bitstring.cma pa_bitstring.cmo *)

(* tailwtmp - watch for logins and logouts; *)
(* uses linux utmp structure, from utmp(5)  *)

let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
                "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

let string_of_tm tm =
  Printf.sprintf "%s %s %2d %02d:%02d:%02d %04d"
    days.(tm.Unix.tm_wday)
    months.(tm.Unix.tm_mon)
    tm.Unix.tm_mday
    tm.Unix.tm_hour
    tm.Unix.tm_min
    tm.Unix.tm_sec
    (tm.Unix.tm_year + 1900)

let trim_asciiz s =
  try String.sub s 0 (String.index s '\000')
  with Not_found -> s

let () =
  let sizeof = 384 in
  let wtmp = open_in "/var/log/wtmp" in
  seek_in wtmp (in_channel_length wtmp);
  while true do
    let buffer = Bitstring.bitstring_of_chan_max wtmp sizeof in
    (bitmatch buffer with
       | { ut_type : 16 : littleendian;
           _ : 16; (* padding *)
           ut_pid : 32 : littleendian;
           ut_line : 256 : string;
           ut_id : 32 : littleendian;
           ut_user : 256 : string;
           ut_host : 2048 : string;
           ut_exit : 32 : littleendian;
           ut_session : 32 : littleendian;
           ut_tv_sec : 32 : littleendian;
           ut_tv_usec : 32 : littleendian;
           ut_addr_v6 : 128 : string } ->
           Printf.printf "%1d %-8s %-12s %10ld %-24s %-16s %5ld %-32s\n%!"
             ut_type (trim_asciiz ut_user) (trim_asciiz ut_line) ut_id
             (string_of_tm (Unix.localtime (Int32.to_float ut_tv_sec)))
             (trim_asciiz ut_host) ut_pid (Digest.to_hex ut_addr_v6)
       | { _ } -> ());
    if pos_in wtmp = in_channel_length wtmp
    then Unix.sleep 1
  done

(* @@PLEAC@@_8.19 *)
#!/usr/bin/ocaml
(* tctee - clone that groks process tees *)
#load "unix.cma";;

let ignore_ints = ref false
let append      = ref false
let unbuffer    = ref false
let nostdout    = ref false
let names       = ref []

let () =
  Arg.parse
    [
      "-a", Arg.Set append,      "Append to output files";
      "-i", Arg.Set ignore_ints, "Ignore interrupts";
      "-u", Arg.Set unbuffer,    "Unbuffered output";
      "-n", Arg.Set nostdout,    "No standard output";
    ]
    (fun name -> names := name :: !names)
    (Printf.sprintf "Usage: %s [-a] [-i] [-u] [-n] [filenames] ..."
       Sys.argv.(0));
  names := List.rev !names

let fhs = Hashtbl.create 0
let status = ref 0

let () =
  if not !nostdout then
    (* always go to stdout *)
    Hashtbl.replace fhs stdout "standard output";

  if !ignore_ints
  then
    List.iter
      (fun signal -> Sys.set_signal signal Sys.Signal_ignore)
      [Sys.sigint; Sys.sigterm; Sys.sighup; Sys.sigquit];

  List.iter
    (fun name ->
       if name.[0] = '|'
       then
         Hashtbl.replace fhs
           (Unix.open_process_out
              (String.sub name 1 (String.length name - 1)))
           name
       else
         begin
           let mode =
             if !append
             then [Open_wronly; Open_creat; Open_append]
             else [Open_wronly; Open_creat; Open_trunc] in
           try Hashtbl.replace fhs (open_out_gen mode 0o666 name) name
           with Sys_error e ->
             Printf.eprintf "%s: couldn't open %s: %s\n%!"
               Sys.argv.(0) name e;
             incr status
         end)
    !names;

  begin
    try
      while true do
        let line = input_line stdin in
        Hashtbl.iter
          (fun fh name ->
             try
               output_string fh line;
               output_string fh "\n";
               if !unbuffer then flush fh
             with Sys_error e ->
               Printf.eprintf "%s: couldn't write to %s: %s\n%!"
                 Sys.argv.(0) name e;
               incr status)
          fhs
      done
    with End_of_file -> ()
  end;

  Hashtbl.iter
    (fun fh name ->
       let close =
         if name.[0] = '|'
         then fun p -> ignore (Unix.close_process_out p)
         else close_out in
       try close fh
       with Sys_error e ->
         Printf.eprintf "%s: couldn't close %s: %s\n%!"
           Sys.argv.(0) name e;
         incr status)
    fhs;

  exit !status

(* @@PLEAC@@_8.20 *)
(* laston - find out when a given user last logged on *)

#load "str.cma";;
#load "unix.cma";;

open Printf
open Unix

let lastlog = open_in "/var/log/lastlog"
let sizeof = 4 + 12 + 16
let line = String.make 12 ' '
let host = String.make 16 ' '

let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
                "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

let format_time time =
  let tm = localtime time in
  sprintf "%s %s %2d %02d:%02d:%02d %04d"
    days.(tm.tm_wday)
    months.(tm.tm_mon)
    tm.tm_mday
    tm.tm_hour
    tm.tm_min
    tm.tm_sec
    (tm.tm_year + 1900)

let trim_asciiz s =
  try String.sub s 0 (String.index s '\000')
  with Not_found -> s

let () =
  Array.iter
    (fun user ->
       try
         let u =
           try getpwuid (int_of_string user)
           with Failure _ -> getpwnam user in
         seek_in lastlog (u.pw_uid * sizeof);
         let time = input_binary_int lastlog in
         really_input lastlog line 0 12;
         really_input lastlog host 0 16;
         let line = trim_asciiz line in
         let host = trim_asciiz host in
         printf "%-8s UID %5d %s%s%s\n"
           u.pw_name
           u.pw_uid
           (if time <> 0
            then format_time (float_of_int time)
            else "never logged in")
           (if line <> "" then " on " ^ line else "")
           (if host <> "" then " from " ^ host else "")
       with Not_found ->
         printf "no such uid %s\n" user)
    (Array.sub Sys.argv 1 (Array.length Sys.argv - 1))


(* @@PLEAC@@_9.0 *)
open Unix 

(* handle_unix_error generates a nice error message and exits *)
let entry = handle_unix_error stat "/usr/bin/vi"
let entry = handle_unix_error stat "/usr/bin/"
let entry = handle_unix_error fstat filedescr

(* without handle_unix_error an exception is raised for errors *)
let inode = stat "/usr/bin/vi"
let ctime = inode.st_ctime
let size = inode.st_size

(* don't know any equivalent in ocaml *)
(* maybe one could use file(1) (to know if it is an ASCII text file) *)
let dirhandle = handle_unix_error opendir "/usr/bin" in
begin
  try
    while true do
      let file = readdir dirhandle in
      Printf.printf "Inside /usr/bin is something called %s\n" file
    done
  with
    | End_of_file -> ()
end;
closedir dirhandle;;

(* @@PLEAC@@_9.1 *)
let (readtime, writetime) =
  let inode = stat filename in
  (inode.st_atime, inode.st_mtime);;

utimes filename newreadtime newwritetime;;

(*-----------------------------*)

let second_per_day = 60. *. 60. *. 24. in
let (atime, mtime) =
  let inode = stat filename in
  (inode.st_atime, inode.st_mtime) in
let newreadtime = atime -. 7. *. second_per_day
and newwritetime = mtime -. 7. *. second_per_day in
try 
  utimes filename newreadtime newwritetime 
with
  | Unix_error (er,_,_) ->
      Printf.eprintf 
        "couldn't backdate %s by a week w/ utime: %s\n"
        filename (error_message er);;

(*-----------------------------*)
let mtime = (stat file).st_mtime in
utimes file (time ()) mtime  ;;

(*-----------------------------*)

(* compile with ocamlc unix.cma uvi.ml -o uvi *)
open Unix

let main () =
  if (Array.length Sys.argv <> 2)
  then
    Printf.eprintf "Usage: uvi filename\n";
  let filename = Sys.argv.(1) in
  let atime,mtime = 
    let st = stat filename in
    (st.st_atime, st.st_mtime) in
  let editor =
    begin
      try
        Sys.getenv "editor"
      with
        | Not_found -> "vi"
    end in
  Sys.command (Printf.sprintf "%s %s" editor filename);
  utimes filename atime mtime in
main ();;
  
(*-----------------------------*)

(* @@PLEAC@@_9.2 *)
unlink filename;;                       (* use unix library *)
Sys.remove filename;;                   (* in the standard library *)

let error_flag = ref(None) in
let local_unlink filename =
  try
    unlink filename
  with
    | Unix_error (er,_,_) -> 
        error_flag := (Some er) in
List.iter local_unlink filenames;
match !error_flag with
  | Some er ->
      Printf.eprintf "Couldn't unlink all of";
      List.iter (Printf.eprintf " %s") filenames;
      Printf.eprintf ": %s\n" (error_message er)
  | None ();;


(*-----------------------------*)

let error_flag = ref(0) in
let local_unlink count filename =
  try
    unlink filename;
    count + 1
  with
    | Unix_error (er,_,_) -> 
        count in
let count = (List.fold_left local_unlink filenames 0) 
and len = List.length filenames in
if count <> len
then
  Printf.eprintf "Could only delete %i of %i file\n" count len;;

(*-----------------------------*)

(* @@PLEAC@@_9.3 *)
(*-----------------------------*)

(* Note : this doesn't use the unix library, only the standard one *)

let copy oldfile newfile =
  let infile = open_in oldfile
  and outfile = open_out newfile
  and blksize = 16384 in
  let buf = String.create blksize in
  let rec real_copy () =
    let byte_read = input infile buf 0 blksize in
    if byte_read <> 0 then
      begin
        (* Handle partialle write : nothing to do *)
        output outfile buf 0 byte_read;
        real_copy ()
      end in
  real_copy ();
  close_in infile;
  close_out outfile;;

(*-----------------------------*)
Sys.command ("cp " ^ oldfile ^ " " ^ newfile)   (* Unix *)
Sys.command (String.concat " " ["copy";oldfile;newfile]) (* Dos *)

(*-----------------------------*)

Unix.copy "datafile.dat" "datafile.bak";;

Sys.rename "datafile.dat" "datafile.bak";;

(*-----------------------------*)

(* @@PLEAC@@_9.4 *)
#load "unix.cma";;

(* Count the number of times a (dev, ino) pair is seen. *)
let seen = Hashtbl.create 0
let do_my_thing filename =
  let {Unix.st_dev=dev; st_ino=ino} = Unix.stat filename in
  Hashtbl.replace seen (dev, ino)
    (try Hashtbl.find seen (dev, ino) + 1
     with Not_found -> 1);
  if Hashtbl.find seen (dev, ino) = 1
  then
    begin
      (* do something with filename because we haven't
         seen it before. *)
    end

(*-----------------------------*)

(* Maintain a list of files for each (dev, ino) pair. *)
let seen = Hashtbl.create 0
let () =
  List.iter
    (fun filename ->
       let {Unix.st_dev=dev; st_ino=ino} = Unix.stat filename in
       Hashtbl.replace seen (dev, ino)
         (try filename :: Hashtbl.find seen (dev, ino)
          with Not_found -> [filename]))
    files
let () =
  Hashtbl.iter
    (fun (dev, ino) filenames ->
       Printf.printf "(%d, %d) => [%s]\n"
         dev ino (String.concat ", " filenames))
    seen

(* @@PLEAC@@_9.5 *)
(* Using Sys.readdir. *)
let () =
  Array.iter
    (fun file ->
       let path = Filename.concat dirname file in
       (* do something with path *)
       ())
    (Sys.readdir dirname)

(*-----------------------------*)

(* Using Unix.opendir, readdir, and closedir. Note that the "." and ".."
   directories are included in the result unlike with Sys.readdir. *)
#load "unix.cma";;

let () =
  let dir =
    try Unix.opendir dirname
    with Unix.Unix_error (e, _, _) ->
      Printf.eprintf "can't opendir %s: %s\n"
        dirname (Unix.error_message e);
      exit 255 in
  try
    while true do
      let file = Unix.readdir dir in
      let path = Filename.concat dirname file in
      (* do something with path *)
      ()
    done
  with End_of_file ->
    Unix.closedir dir

(*-----------------------------*)

(* Get a list of full paths to plain files. *)
let plainfiles dir =
  List.filter
    (fun path ->
       match Unix.lstat path with
         | {Unix.st_kind=Unix.S_REG} -> true
         | _ -> false)
    (List.map
       (Filename.concat dir)
       (Array.to_list (Sys.readdir dir)))

(* @@PLEAC@@_9.6 *)
(* See recipe 6.9 for a more powerful globber. *)
#load "str.cma";;

(* OCaml does not come with a globbing function. As a workaround, the
   following function builds a regular expression from a glob pattern.
   Only the '*' and '?' wildcards are recognized. *)
let regexp_of_glob pat =
  Str.regexp
    (Printf.sprintf "^%s$"
       (String.concat ""
          (List.map
             (function
                | Str.Text s -> Str.quote s
                | Str.Delim "*" -> ".*"
                | Str.Delim "?" -> "."
                | Str.Delim _ -> assert false)
             (Str.full_split (Str.regexp "[*?]") pat))))

(* Now we can build a very basic globber. Only the filename part will
   be used in the glob pattern, so directory wildcards will break in
   this simple example. *)
let glob pat =
  let basedir = Filename.dirname pat in
  let files = Sys.readdir basedir in
  let regexp = regexp_of_glob (Filename.basename pat) in
  List.map
    (Filename.concat basedir)
    (List.filter
       (fun file -> Str.string_match regexp file 0)
       (Array.to_list files))

(* Find all data files in the pleac directory. *)
let files = glob "pleac/*.data"

(*-----------------------------*)

(* Find and sort directories with numeric names. *)
let dirs =
  List.map snd                             (* extract pathnames *)
    (List.sort compare                     (* sort names numerically *)
       (List.filter                        (* path is a dir *)
          (fun (_, s) -> Sys.is_directory s)
          (List.map                        (* form (name, path) *)
             (fun s -> (int_of_string s, Filename.concat path s))
             (List.filter                  (* just numerics *)
                (fun s ->
                   try ignore (int_of_string s); true
                   with _ -> false)
                (Array.to_list
                   (Sys.readdir path)))))) (* all files *)

(* @@PLEAC@@_9.7 *)
let rec find_files f error root =
  Array.iter
    (fun filename ->
       let path = Filename.concat root filename in
       let is_dir =
         try Some (Sys.is_directory path)
         with e -> error root e; None in
       match is_dir with
         | Some true -> if f path then find_files f error path
         | Some false -> ignore (f path)
         | None -> ())
    (try Sys.readdir root with e -> error root e; [| |])

let process_file fn =
  (* Print the name of each directory and file found. *)
  Printf.printf "%s: %s\n"
    (if Sys.is_directory fn then "directory" else "file") fn;

  (* Prune directories named ".svn". *)
  not (Sys.is_directory fn && Filename.basename fn = ".svn")

let handle_error fn exc =
  Printf.eprintf "Error reading %s: %s\n" fn (Printexc.to_string exc)

let () =
  List.iter (find_files process_file handle_error) dirlist

(*-----------------------------*)

(* Add a trailing slash to the names of directories. *)
let () =
  List.iter
    (find_files
       (fun fn ->
          print_endline
            (if Sys.is_directory fn then (fn ^ "/") else fn);
          true)
       (fun _ _ -> ()))
    (match List.tl (Array.to_list Sys.argv) with
       | [] -> ["."]
       | dirs -> dirs)

(*-----------------------------*)

(* Sum the file sizes of a directory tree. *)
#load "unix.cma";;
let sum = ref 0
let () =
  List.iter
    (find_files
       (fun fn ->
          sum := !sum + (match Unix.stat fn
                         with {Unix.st_size=size} -> size);
          true)
       (fun _ _ -> ()))
    (match List.tl (Array.to_list Sys.argv) with
       | [] -> ["."]
       | dirs -> dirs);
  Printf.printf "%s contains %d bytes\n"
    (String.concat " " (List.tl (Array.to_list Sys.argv))) !sum

(*-----------------------------*)

(* Find the largest file in a directory tree. *)
#load "unix.cma";;
let saved_size = ref 0
let saved_name = ref ""
let () =
  List.iter
    (find_files
       (fun fn ->
          (match Unix.stat fn with
             | {Unix.st_size=size} ->
                 if size > !saved_size
                 then (saved_size := size; saved_name := fn));
          true)
       (fun _ _ -> ()))
    (match List.tl (Array.to_list Sys.argv) with
       | [] -> ["."]
       | dirs -> dirs);
  Printf.printf "Biggest file %s in %s is %d bytes long.\n"
    !saved_name
    (String.concat " " (List.tl (Array.to_list Sys.argv)))
    !saved_size

(*-----------------------------*)

(* Find the youngest file or directory. *)
#load "unix.cma";;
let saved_age = ref 0.
let saved_name = ref ""
let () =
  List.iter
    (find_files
       (fun fn ->
          (match Unix.stat fn with
             | {Unix.st_mtime=age} ->
                 if age > !saved_age
                 then (saved_age := age; saved_name := fn));
          true)
       (fun _ _ -> ()))
    (match List.tl (Array.to_list Sys.argv) with
       | [] -> ["."]
       | dirs -> dirs);
  match Unix.localtime !saved_age with
    | {Unix.tm_year=year; tm_mon=month; tm_mday=day} ->
        Printf.printf "%04d-%02d-%02d %s\n"
          (year + 1900) (month + 1) day
          !saved_name

(*-----------------------------*)

(* fdirs - find all directories *)
let () =
  List.iter
    (find_files
       (fun fn ->
          if Sys.is_directory fn then print_endline fn;
          true)
       (fun _ _ -> ()))
    (match List.tl (Array.to_list Sys.argv) with
       | [] -> ["."]
       | dirs -> dirs)

(* @@PLEAC@@_9.8 *)
(* rmtree - remove whole directory trees like rm -r *)
#load "unix.cma";;

let rec finddepth f roots =
  Array.iter
    (fun root ->
       (match Unix.lstat root with
          | {Unix.st_kind=Unix.S_DIR} ->
              finddepth f
                (Array.map (Filename.concat root) (Sys.readdir root))
          | _ -> ());
       f root)
    roots

let zap path =
  match Unix.lstat path with
    | {Unix.st_kind=Unix.S_DIR} ->
        Printf.printf "rmdir %s\n%!" path;
        Unix.rmdir path
    | _ ->
        Printf.printf "unlink %s\n%!" path;
        Unix.unlink path

let () =
  if Array.length Sys.argv < 2
  then (Printf.eprintf "usage: %s dir ..\n" Sys.argv.(0); exit 1);
  finddepth zap (Array.sub Sys.argv 1 (Array.length Sys.argv - 1))

(* @@PLEAC@@_9.9 *)
#load "unix.cma";;
let () = List.iter
  (fun file ->
     let newname = file in
     (* change newname *)
     Unix.rename file newname)
  names

(* rename - Larry's filename fixer *)
#load "unix.cma";;
#directory "+pcre";;
#load "pcre.cma";;
let () =
  match Array.to_list Sys.argv with
    | prog :: pat :: templ :: files ->
        let replace = Pcre.replace ~pat ~templ in
        List.iter
          (fun file ->
             let file' = replace file in
             Unix.rename file file')
          files
    | _ -> prerr_endline "Usage: rename pattern replacment [files]"

(*
  % rename '\.orig$' '' *.orig
  % rename '$' '.bad' *.f
  % rename '([^/]+)~$' '.#$1' /tmp/*~
  % find /tmp -name '*~' -exec rename '([^/]+)~$' '.#$1' {} \;
*)

(* @@PLEAC@@_9.10 *)
let splitext name =
  try
    let root = Filename.chop_extension name in
    let i = String.length root in
    let ext = String.sub name i (String.length name - i) in
    root, ext
  with Invalid_argument _ ->
    name, ""

let dir = Filename.dirname path
let file = Filename.basename path
let name, ext = splitext file

(* @@PLEAC@@_9.11 *)
#!/usr/bin/ocaml
(* symirror - build spectral forest of symlinks *)
#load "unix.cma";;

open Printf

let die msg = prerr_endline msg; exit 1

let () =
  if Array.length Sys.argv <> 3
  then die (sprintf "usage: %s realdir mirrordir" Sys.argv.(0))

let srcdir, dstdir = Sys.argv.(1), Sys.argv.(2)
let cwd = Unix.getcwd ()

let fix_relative path =
  if Filename.is_relative path
  then Filename.concat cwd path
  else path

let is_dir dir =
  try Some (Sys.is_directory dir)
  with Sys_error _ -> None

let () =
  match (is_dir srcdir, is_dir dstdir) with
    | (None, _) | (Some false, _) ->
        die (sprintf "%s: %s is not a directory" Sys.argv.(0) srcdir)
    | (_, Some false) ->
        die (sprintf "%s: %s is not a directory" Sys.argv.(0) dstdir)
    | (_, None) ->
        Unix.mkdir dstdir 0o7777        (* be forgiving *)
    | (Some _, Some _) ->
        ()                              (* cool *)

(* fix relative paths *)
let srcdir, dstdir = fix_relative srcdir, fix_relative dstdir

let rec find f roots =
  Array.iter
    (fun root ->
       f root;
       match Unix.lstat root with
         | {Unix.st_kind=Unix.S_DIR} ->
             find f (Array.map
                       (Filename.concat root)
                       (Sys.readdir root))
         | _ -> ())
    roots

let wanted name =
  if name <> Filename.current_dir_name
  then
    let {Unix.st_dev=dev; st_ino=ino; st_kind=kind; st_perm=perm} =
      Unix.lstat name in
    (* preserve directory permissions *)
    let perm = perm land 0o7777 in
    (* correct name *)
    let name =
      if String.length name > 2 && String.sub name 0 2 = "./"
      then String.sub name 2 (String.length name - 2)
      else name in
    if kind = Unix.S_DIR
    then
      (* make a real directory *)
      Unix.mkdir (Filename.concat dstdir name) perm
    else
      (* shadow everything else *)
      Unix.symlink
        (Filename.concat srcdir name)
        (Filename.concat dstdir name)

let () =
  Unix.chdir srcdir;
  find wanted [|"."|]

(* @@PLEAC@@_9.12 *)
#!/usr/bin/ocaml
(* lst - list sorted directory contents (depth first) *)
#load "unix.cma";;

open Unix
open Printf

let opt_m = ref false
let opt_u = ref false
let opt_c = ref false
let opt_s = ref false
let opt_r = ref false
let opt_i = ref false
let opt_l = ref false
let names = ref []

let () =
  Arg.parse
    [
      "-m", Arg.Set opt_m, "Use mtime (modify time) [DEFAULT]";
      "-u", Arg.Set opt_u, "Use atime (access time)";
      "-c", Arg.Set opt_c, "Use ctime (inode change time)";
      "-s", Arg.Set opt_s, "Use size for sorting";
      "-r", Arg.Set opt_r, "Reverse sort";
      "-i", Arg.Set opt_i, "Read pathnames from stdin";
      "-l", Arg.Set opt_l, "Long listing";
    ]
    (fun name -> names := name :: !names)
    (sprintf
       "Usage: %s [-m] [-u] [-c] [-s] [-r] [-i] [-l] [dirs ...]
 or    %s -i [-m] [-u] [-c] [-s] [-r] [-l] < filelist"
       Sys.argv.(0) Sys.argv.(0));
  names :=
    match !names with
      | [] when not !opt_i -> ["."]
      | names -> names

let die msg = prerr_endline msg; exit 1

let () =
  let int_of_bool = function true -> 1 | false -> 0 in
  if (int_of_bool !opt_c
      + int_of_bool !opt_u
      + int_of_bool !opt_s
      + int_of_bool !opt_m) > 1
  then die "can only sort on one time or size"

let idx = fun {st_mtime=t} -> t
let idx = if !opt_u then fun {st_atime=t} -> t else idx
let idx = if !opt_c then fun {st_ctime=t} -> t else idx
let idx = if !opt_s then fun {st_size=s} -> float s else idx
let time_idx = if !opt_s then fun {st_mtime=t} -> t else idx

let rec find f roots =
  Array.iter
    (fun root ->
       f root;
       match lstat root with
         | {st_kind=S_DIR} ->
             find f (Array.map
                       (Filename.concat root)
                       (Sys.readdir root))
         | _ -> ())
    roots

let time = Hashtbl.create 0
let stat = Hashtbl.create 0

(* get stat info on the file, saving the desired *)
(* sort criterion (mtime, atime, ctime, or size) *)
(* in the time hash indexed by filename.         *)
(* if they want a long list, we have to save the *)
(* entire stat structure in stat.                *)
let wanted name =
  try
    let sb = Unix.stat name in
    Hashtbl.replace time name (idx sb);
    if !opt_l then Hashtbl.replace stat name sb
  with Unix_error _ -> ()

(* cache user number to name conversions *)
let user =
  let user = Hashtbl.create 0 in
  fun uid ->
    Hashtbl.replace user uid
      (try (getpwuid uid).pw_name
       with Not_found -> ("#" ^ string_of_int uid));
    Hashtbl.find user uid

(* cache group number to name conversions *)
let group =
  let group = Hashtbl.create 0 in
  fun gid ->
    Hashtbl.replace group gid
      (try (getgrgid gid).gr_name
       with Not_found -> ("#" ^ string_of_int gid));
    Hashtbl.find group gid

let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
                "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

let format_time time =
  let tm = localtime time in
  sprintf "%s %s %2d %02d:%02d:%02d %04d"
    days.(tm.tm_wday)
    months.(tm.tm_mon)
    tm.tm_mday
    tm.tm_hour
    tm.tm_min
    tm.tm_sec
    (tm.tm_year + 1900)

let () =
  if !opt_i
  then
    begin
      begin
        try
          while true do
            names := (input_line Pervasives.stdin) :: !names
          done
        with End_of_file -> ()
      end;
      List.iter wanted (List.rev !names)
    end
  else find wanted (Array.of_list (List.rev !names))

(* sort the files by their cached times, youngest first *)
let skeys =
  List.sort
    (fun a b -> compare (Hashtbl.find time b) (Hashtbl.find time a))
    (Hashtbl.fold (fun k v a -> k :: a) time [])

(* but flip the order if -r was supplied on command line *)
let skeys = if !opt_r then List.rev skeys else skeys

let () =
  List.iter
    (fun skey ->
       if !opt_l
       then
         let sb = Hashtbl.find stat skey in
         printf "%6d %04o %6d %8s %8s %8d %s %s\n"
           sb.st_ino
           (sb.st_perm land 0o7777)
           sb.st_nlink
           (user sb.st_uid)
           (group sb.st_gid)
           sb.st_size
           (format_time (time_idx sb))
           skey
       else
         print_endline skey)
    skeys


(* @@PLEAC@@_10.0 *)

(* A function is bound to a variable (as with everything) with the let keyword
*)

let hello () =
  incr greeted; (* global reference *)
  printf "hi there!\n";;

(* Other forms for declaring a function are as follows *)

let hello = 
  fun () -> 
    incr greeted; (* global reference *)
    printf "hi there!\n";;

let hello = 
  function () ->
    incr greeted; (* global reference *)
    printf "hi there!\n";;

(* The typical way of calling this function is *)

hello ();;

(* @@PLEAC@@_10.1 *)

(* All values passed to a function must be named in the paramater list to the
 * function *)

let hypotenuse side1 side2 =
  sqrt ((side1 ** 2.) +. (side2 ** 2.));;

(* Note, however, that if the parameters are defined/sent as a tuple then they
 * can be accessed in one of two equivalent ways *)

let hypotenuse (side1,side2) =
  sqrt ((side1 ** 2.) +. (side2 ** 2.));;

let hypotenuse sides =
  let side1,side2 = sides in
  sqrt ((side1 ** 2.) +. (side2 ** 2.));;

(* In both of these cases, however, we must pass the arguments as a tuple *)

print_float hypotenuse (3.,4.);;

(* since most data structures are immutable, one generally does not need to copy
 * the parameters into local variables *)

let nums = [1.4; 3.5; 6.7];;
let int_all l =
  List.map int_of_float l;;

(*
# let ints = int_all nums;;
val ints : int list = [1; 3; 6]

# nums;;
- : float list = [1.4; 3.5; 6.7]
*)

(* However, one needs to be careful when mutable data is passed in and
 * operations that alter that data are used *)

let nums = [|1.4; 3.5; 6.7 |];;
let int_all2 a =
  Array.iteri (fun i x -> a.(i) <- 10. *. x) a;
  a;;
let int_all3 a = 
  Array.map int_of_float a;;

(*
# let a2 = int_all2 nums;;
val a2 : int array = [|1; 3; 6|]

# nums;;
- : float array = [|1.4; 3.5; 6.7|]

# let a3 = times10 nums;;
val a3 : float array = [|14.; 35.; 67.|]

# nums;;
- : float array = [|14.; 35.; 67.|]
*)

(* To write functions that change their caller's variables, those variables must
 * be mutable structures, such as references *)
let nums = ref [1.4; 3.5; 6.7];;
let trunc_em l =
  l:= List.map floor !l;
  !l;;

(*

# let n2 = trunc_em nums;;
val n2 : float list = [1.; 3.; 6.]

# !nums;;
- : float list = [1.; 3.; 6.]
*)

(* @@PLEAC@@_10.2 *)

(* to declare a variable local to a function, simply use let inside the function
 * body *)

let somefunc () =
  let variable = ... in
  let another,anarray,ahash = ... in
  ... ;;

let check_x x =
  let y = "whatever" in
  run_check ();
  if condition then printf "got %s" x;;

let save_array arguments =
  global_list := arguments @ !global_list;;

(* @@PLEAC@@_10.3 *)

let mysub =
  let variable = ... in
  fun args -> ... ;;

(* To write a counter *)
let next_counter = 
  let counter = ref 0 in
  fun () -> 
    incr counter; 
    !counter;;

let next_counter,prev_counter = 
  let counter = ref 42 in
  (fun () -> incr counter; !counter),
  (fun () -> decr counter; !counter);;

(* @@PLEAC@@_10.4 *)
(* The names of functions are not available at runtime. However, using the
   camlp4 preprocessor, we can expose various pieces of static information.

   The "macro" parser provides the current file and location as __FILE__ and
   __LOCATION__, respectively. With a bit more customization, we can expose
   the current function name as well.

   To do this, we'll make a copy of camlp4/Camlp4Filters/Camlp4Profiler.ml
   from the OCaml sources and rename it to "Camlp4FuncNamer.ml". Then,
   we'll change the definition of "decorate_this_expr" to the following: *)

(*---------------------------*)

value decorate_this_expr e id =
  let _loc = Ast.loc_of_expr e in
  <:expr< let __FUNC__ = $`str:id$ in $e$ >>;

(*---------------------------*)

(* This has the effect of exposing the current function name as the
   string, __FUNC__, which we can use just like __FILE__. To build this
   syntax extension, use a command like the following: *)

ocamlc -c -pp camlp4rf -I /usr/lib/ocaml/3.10.2/camlp4 Camlp4FuncNamer.ml

(*---------------------------*)

(* Now, we'll write a simple test program called "main.ml": *)

(* Comment out this line to silence log messages. *)
DEFINE DEBUG

(* Default function name if Camlp4FuncNamer doesn't provide one. *)
let __FUNC__ = "<toplevel>"

(* Log macro with Printf formatting. *)
DEFINE LOG =
  IFDEF DEBUG THEN
    Printf.kprintf
      (Printf.eprintf "%s[%s]: %s\n%!" __FUNC__ __FILE__)
  ELSE
    Printf.kprintf (fun _ -> ())
  END

(* An example named function. *)
let test_function () =
  let str = "Hello, world!" in
  let num = 42 in
  LOG "str=\"%s\", num=%d" str num;
  print_endline "test complete"

(* Some code to run at the toplevel. *)
let () =
  LOG "not in a function";
  test_function ()

(*---------------------------*)

(* We can compile this program as follows: *)

ocamlc -pp "camlp4of Camlp4FuncNamer.cmo" \
    -I /usr/lib/ocaml/3.10.2/camlp4 \
    -o main main.ml

(* Running it, we get this output: *)

<toplevel>[main.ml]: not in a function
test_function[main.ml]: str="Hello, world!", num=42
test complete

(* @@PLEAC@@_10.5 *)
(* Because all OCaml variables represent pointers to their data, all function
 * arguments are implicitly passed by reference *)

array_diff array1 array2;;

let a = [| 1; 2 |];;
let b = [| 5; 8 |];;
let add_vec_pair x y =
  Array.init (Array.length x) (fun i -> x.(i) + y.(i));;

(*
# let c = add_vec_pair a b;;
val c : int array = [|6; 10|]
*)

(* @@PLEAC@@_10.6 *)
(* OCaml's type safety doesn't allow this kind of shenanigans unless you bring
 * union types into play -- but you still need to ensure that the return type of
 * all three contexts is the same *)

type 'a lORs =
    List of 'a list
  | Scalar of 'a
  | Void of unit ;;

let mysub arg =
  match arg with
    List l -> (* list context, do something with l *)
  | Scalar s -> (* scalar context, do something with s *)
  | Void _ -> (* void context, do something with nothing *);;

(* or equivalently *)
let mysub = function
    List l -> (* list context, do something with l *)
  | Scalar s -> s (* scalar context, do something with s *)
  | Void _ -> (* void context, do something with nothing *);;

mysub (Void ());;         (* void context *)
mysub (Scalar arg);;      (* scalar context *)
mysub (List arg);;        (* list context *)

(* @@PLEAC@@_10.7 *)
(* To name the arguments of a function, use labels *)
let thefunc ~increment ~finish ~start =
  ... ;;

(* It can be called like *)
thefunc ~increment:"20s" ~start:"+5m" ~finish:"+30m";;

(* Note that you can use different names for the labels and variables, and if
 * the application is total, the labels can be omitted *)
let divide ~numerator:x ~denominator:y = 
  x / y;;

(*
# divide ~denominator:2 ~numerator:100;;
 - : int = 50

# divide 20 4;;
 - : int = 5
*)

(* If you want to provide default values, you need to use optional arguments,
 * but this requires at least one unlabelled argument *)

let fraction ?(y = 2) x =
  x / y;;

(*
fraction 30 ~y:3;;
 - : int = 10

fraction 30;;
 - : int = 15
*)

(* @@PLEAC@@_10.8 *)
(* Use _, which matches any pattern and throws away the value it matches *)

let a,_,c = func ();;
let _,_,d = func ();;

(* @@PLEAC@@_10.9 *)
(* Just stick all of the values in a tuple and return it *)
let somefunc () =
  let arr = ... in
  let hash = ... in
    ...
    (arr,hash);;

let a,h = somefunc ();;

(* @@PLEAC@@_10.10 *)
(* Use an appropriate exception *)

let failing_routine () =
  ...
  raise Failure "Bad things happened...";;

try failing_routine () with
  Failure s -> printf "failing_routine failed because: %s\n" s;;

(* @@PLEAC@@_10.11 *)

(* This is pretty much unnecessary due to OCaml's type inference -- you will
 * know at compile time if you try to pass invalid arguments to a function *)

(* @@PLEAC@@_10.12 *)
(* To handle exceptions, which are thrown with the raise keword, wrap the
 * possibly exceptional call in a try ... with block.  You only need to do this
 * where appropriate *)

let slurp_to_list filename =
  (* Note, if filename does not exist in the current directory, it will raise a
   * Sys_error exception *)
  let ic = open_in filename and
  l = ref [] in
  let rec loop () =
    let line = input_line ic in
    l := line::!l;
    loop () in
  try loop () with End_of_file -> close_in ic; List.rev !l;;

let lfind name l =
  (* Note, if no elements in the list satisfy the predicate, List.find will
   * raise the Not_found exception *)
  List.find (fun x -> Str.string_match (Str.regexp ("$" ^ name)) x 0) l;;

let findSmurfette =
  try
    print_endline (lfind "Smurfette" (slurp_to_list "smurfs"))
  with
    Sys_error s -> prerr_endline ("Dammit! - " ^ s)
  | Not_found -> prerr_endline "Hmmm... Smurfette is not in smurfs";;

(* @@PLEAC@@_10.13 *)
(* To do this in OCaml -- which doesn't like global state in the first place --
 * you need to manually store the old value and replace it before exiting the
 * block *)

let age = ref 18;;
if condition then
  (
    let org_age = !age in
    age := 23;
    func ();
    age := org_age
  );;

(* for local handles, just create a new channel inside your block *)
let get_motd () =
  let motd = open_in "/etc/motd" in
  let retval = 
    ... in
  close_in motd;
  retval;;

(* @@PLEAC@@_10.14 *)

(* If you want to redefine a function... go ahead.  Functions are first class
 * members in OCaml *)

let f x y =
  x + y;;

f 5 7;;
(*  - : int = 12 *)

let f x y =
  x - y;;

f 5 7;;

(*  - : int = -2 *)

(* to do it temporarily, either save to old value and then restore it, or just
 * redefine it in the current block.  The old value will be restored when you
 * exit the scope of that block *)

let g = f
and f x y =
  x * y;;

f 5 7;;

(*  - : int = 35 *)

let f = g;;

f 5 7;;

(*  - : int = -2 *)

let g () = 
  let f x y =
    x / y in
  f 5 7;;

g ();;

(*  - : int = 0 *)

f 5 7;;

(*  - : int = -2 *)

(* @@PLEAC@@_10.15 *)
(* Since OCaml is statically typed, any attempt to call an undefined
   function will result in a compiler error. There is no way to capture
   and handle this event at runtime. *)

(* @@PLEAC@@_10.16 *)

(* Just define the inner function within the outer one *)
let outer x =
  let x = x + 35 in
  let inner () =
    x * 19 in
  x + inner ();;

(* @@PLEAC@@_10.17 *)

let slurp_to_string filename =
  let ic = open_in filename and
  buf = Buffer.create 4096 in
  let rec loop () =
    let line = input_line ic in
    Buffer.add_string buf line;
    Buffer.add_string buf "\n";
    loop () in
  try loop () with End_of_file -> close_in ic; Buffer.contents buf;;

(* Note: The following function does something slightly different than the Perl
 * version, as it returns a subject,message #,refrence to the message tuple
 * sorted by subject -> message number instead of just a list of messages sorted
 * by subject -> message number -- it's trivial to get just what the Perl
 * version does from this... *)

let sortedMail fn =
  let msglist = 
    (* I had to add this filtering step due to some wierd structure in my mbox
     * file. go figure... *)
    List.filter (fun s -> String.sub s 0 5 = "From:")
      (List.map (fun x -> "From" ^ x) 
        (Str.split (Str.regexp "^From") (slurp_to_string fn)))
  and counter = ref (-1) in
(*  let subjList = *)
    List.sort compare
      (List.map 
        (fun s -> 
          ignore (Str.search_forward 
            (* Not positive this regex is equivalent to the Perl version, but it
             * seems to work -- you can use the third party PCRE module if you
             * want to be positive *)
            (Str.regexp "^Subject:[ \t]*\(:?[Rr][Ee]:[ \t]*\)*\(.*\)") s 0);
          incr counter;
          (try (String.lowercase (Str.matched_group 2 s)) with Not_found -> ""),
           !counter,
           ref s)
        msglist);;

List.iter (fun (_,_,rm) -> print_endline !rm) (sortedMail "mbox");;

(* To sort by using a hashtable *)

let keys h =
  let k = Hashtbl.fold (fun k v b -> k::b) h [] in
  (* filter out duplicates *)
  List.fold_left (fun b x -> if List.mem x b then b else x::b) [] k;;

let sortedMailByHash fn =
  let msglist = 
    (* I had to add this filtering step due to some wierd structure in my mbox
     * file. go figure... *)
    List.filter (fun s -> String.sub s 0 5 = "From:")
      (List.map (fun x -> "From" ^ x) 
        (Str.split (Str.regexp "^From") (slurp_to_string fn)))
  and counter = ref (-1) in
  let h = Hashtbl.create (List.length msglist) in
(*  let subjList = *)
(*    List.sort compare *)
      (List.iter 
        (fun s -> 
          ignore (Str.search_forward 
            (* Not positive this regex is equivalent to the Perl version, but it
             * seems to work -- you can use the third party PCRE module if you
             * want to be positive *)
            (Str.regexp "^Subject:[ \t]*\(:?[Rr][Ee]:[ \t]*\)*\(.*\)") s 0);
          incr counter;
          let sub =
            try 
              (String.lowercase (Str.matched_group 2 s)) 
          with Not_found -> "" in
          Hashtbl.add h sub s))
        msglist;
      List.flatten 
        (List.map (fun x -> List.rev (Hashtbl.find_all h x)) 
          (List.sort (keys h)));;

List.iter (fun m -> print_endline m) (sortedMailByHash "mbox");;


(* @@PLEAC@@_11.0 *)
(* Create a reference to an integer *)
let aref = ref 0

let () =
  (* Assign to aref's contents *)
  aref := 3;

  (* Print the value that the reference "aref" refers to *)
  Printf.printf "%d\n" !aref;

  (* Since references are just records with a single field, "contents",
     the following operations have the same effect as above *)
  aref.contents <- 3;
  Printf.printf "%d\n" aref.contents;

  (* Fast increment and decrement operations are available for int refs *)
  incr aref; Printf.printf "after incr: %d\n" !aref;
  decr aref; Printf.printf "after decr: %d\n" !aref

(* Create a type for "person" records *)
type person = { name : string;
                address : string;
                birthday : int;
              }

let () =
  (* Create a "person" record *)
  let nat = { name     = "Leonhard Euler";
              address  = "1729 Ramunjan Lane\nMathword, PI 31416";
              birthday = 0x5bb5580;
            } in

  (* Display the person's name and address *)
  Printf.printf "\nname: %s\naddress: %s\n" nat.name nat.address;

  (* Same as above, using pattern-matching *)
  let {name=n; address=a} = nat in
  Printf.printf "\nname: %s\naddress: %s\n" n a

(* @@PLEAC@@_11.1 *)
(* The following two sections use lists instead of arrays since
   list refs can be enlarged and copied easily. Also, arrays are
   mutable in OCaml, whereas lists are immutable. *)

(* Create a reference to a list *)
let lref      = ref list
let anon_list = ref [9; 7; 5; 3; 1]
let anon_copy = ref !anon_list

let () =
  (* Add an item to the list *)
  anon_list := 11 :: !anon_list;

  (* Get the number of items from the list ref *)
  let num_items = List.length !anon_list in

  (* Print original data *)
  print_endline (String.concat ", "
                   (List.map (fun i -> string_of_int i) !anon_list));

  (* Sort it *)
  anon_list := List.sort compare !anon_list;

  (* Print sorted data *)
  print_endline (String.concat ", "
                   (List.map (fun i -> string_of_int i) !anon_list));

(* @@PLEAC@@_11.2 *)
(* Create a hash that maps strings to string lists *)
let (hash : (string, string list) Hashtbl.t) = Hashtbl.create 0

(* Define a function to add a string to the string list associated
   with a key in the hash creating the string list if necessary *)
let add hash key value =
  Hashtbl.replace hash key
    (try value :: Hashtbl.find hash key
     with Not_found -> [value])

let () =
  (* Populate the hash with some data *)
  add hash "fruit" "apple";
  add hash "fruit" "banana";
  add hash "wine" "merlot";
  add hash "cheese" "cheddar";
  add hash "cheese" "brie";
  add hash "cheese" "havarti";

  (* Iterate and print out the hash's contents *)
  Hashtbl.iter
    (fun key values ->
       Printf.printf "%s: %s\n" key
         (String.concat ", " values))
    hash

(* Hashtbl is somewhat unusual in that it allows multiple values for
   a given key. By using Hashtbl.add instead of Hashtbl.replace, and
   using strings as values instead of string lists, we can save some
   memory *)
let (hash : (string, string) Hashtbl.t) = Hashtbl.create 0
let () =
  Hashtbl.add hash "foo" "bar";
  Hashtbl.add hash "foo" "baz";
  Hashtbl.add hash "goo" "arc";
  Hashtbl.iter (Printf.printf "%s => %s\n") hash

(* @@PLEAC@@_11.3 *)
(* Hashtbls are mutable, so creating a reference to a hash is usually
   not necessary; it creates an *additional* level of indirection. *)
let href = ref hash
let anon_hash = ref (Hashtbl.create 0)
let () =
  (* Have some fun with locally-defined operators *)
  let ( => ) = Hashtbl.replace !anon_hash in
  ( "key1" => "value1"; "key2" => "value2" )
let anon_hash_copy = ref (Hashtbl.copy !href)

(* @@PLEAC@@_11.4 *)
(* Create a reference to a function *)
let fref = ref func
let fref = ref (fun () -> (* ... *) ())

(* Call the referent function *)
let () = !fref ()

(* Create a reference to an association list with function values. *)
let commands = ref []
let () =
  let ( => ) name func = commands := (name, func) :: !commands in
  (
    "happy" => joy;
    "sad"   => sullen;
    "done"  => (fun () -> print_endline "See ya!"; exit 0);
    "mad"   => angry;
  )

let () =
  while true do
    print_string "How are you? ";
    let string = read_line () in
    try
      let command = List.assoc string !commands in
      command ()
    with Not_found ->
      Printf.printf "No such command: %s\n" string
  done

(* Use closures to generate functions that count. *)

let counter_maker () =
  let start = ref 0 in
  fun () ->                             (* this is a closure *)
    let result = !start in              (* lexical from enclosing scope *)
    incr start; result

let counter1 = counter_maker ()
let counter2 = counter_maker ()

let () =
  for i = 0 to 4 do
    Printf.printf "%d\n" (counter1 ())
  done;
  Printf.printf "%d %d\n" (counter1 ()) (counter2 ())
  (*
    0
    1
    2
    3
    4
    5 0
  *)

(* Use closures to generate functions that keep track of time.
   Note that this example does not need references, since
   since functions are just ordinary values in OCaml. *)

#load "unix.cma";;

let timestamp () =
  let start_time = Unix.time () in
  fun () -> int_of_float (Unix.time () -. start_time)

let () =
  let early = timestamp () in
  Unix.sleep 20;
  let later = timestamp () in
  Unix.sleep 10;
  Printf.printf "It's been %d seconds since early.\n" (early ());
  Printf.printf "It's been %d seconds since later.\n" (later ());
  (*
    It's been 30 seconds since early.
    It's been 10 seconds since later.
  *)

(* @@PLEAC@@_11.5 *)
(* Environments are immutable in OCaml; there is no way to get a
   reference to a value. If you need a mutable cell, use "ref" as
   described in the introduction. If you need to refer to values
   by name strings, use a Hashtbl.t or similar data structure. *)

(* @@PLEAC@@_11.6 *)
(* Create a couple of integer references *)
let a = ref 0
let b = ref 0

(* Create an array of the references *)
let array_of_refs = [| a; b |]

let () =
  (* Set the value of an element *)
  array_of_refs.(1) := 12;              (* b := 12 *)

  (* Note that this is *not* the same as array mutation! If we were to do:
       array_of_refs.(1) <- ref 12
     (or drop the refs altogether) then we would no longer be aliasing "b".
  *)

  (* Get the value of an element *)
  Printf.printf "%d %d\n" !(array_of_refs.(1)) !b

let () =
  let (a, b, c, d) = (ref 1, ref 2, ref 3, ref 4) in (* initialize *)
  let array = [| a; b; c; d |] in                    (* refs to each value *)

  array.(2) := !(array.(2)) + 9;        (* !c is now 12 *)

  let tmp = array.(Array.length array - 1) in
  tmp := !tmp * 5;                      (* !d is now 20 *)

(* @@PLEAC@@_11.7 *)
(* Since record field names must be unique to their enclosing module,
   define a module to encapsulate the fields of the record type that
   will contain the "methods". *)
module Counter = struct
  type t = { next  : unit -> int;
             prev  : unit -> int;
             last  : unit -> int;
             get   : unit -> int;
             set   : int  -> unit;
             bump  : int  -> unit;
             reset : unit -> int }

  let make count =
    let start = count in
    let count = ref start in
    let prev () = decr count; !count in
    { next  = (fun () -> incr count; !count);
      prev  = prev; last = prev;
      get   = (fun () -> !count);
      set   = (fun count' -> count := count');
      bump  = (fun count' -> count := !count + count');
      reset = (fun () -> count := start; !count)
    }
end

(* Create and use a couple of counters. *)
let () =
  let c1 = Counter.make 20 in
  let c2 = Counter.make 77 in

  Printf.printf "next c1: %d\n" (c1.Counter.next ()); (* 21 *)
  Printf.printf "next c2: %d\n" (c2.Counter.next ()); (* 78 *)
  Printf.printf "next c1: %d\n" (c1.Counter.next ()); (* 22 *)
  Printf.printf "last c1: %d\n" (c1.Counter.prev ()); (* 21 *)
  Printf.printf "old  c2: %d\n" (c2.Counter.reset ()) (* 77 *)

(* Same as above, but using a "local open" to temporarily expose
   the record fields for convenience. *)
let () =
  let c1 = Counter.make 20 in
  let c2 = Counter.make 77 in
  let module Local = struct
    open Counter
    let () =
      Printf.printf "next c1: %d\n" (c1.next ()); (* 21 *)
      Printf.printf "next c2: %d\n" (c2.next ()); (* 78 *)
      Printf.printf "next c1: %d\n" (c1.next ()); (* 22 *)
      Printf.printf "last c1: %d\n" (c1.prev ()); (* 21 *)
      Printf.printf "old  c2: %d\n" (c2.reset ()) (* 77 *)
  end in ()

(* @@PLEAC@@_11.8 *)
(* There is no need to use references just to have a function that
   calls a method. Either write a lambda: *)

let mref = fun x y z -> obj#meth x y z

(* Or, just refer to the method directly: *)

let mref = obj#meth

(* Later... *)

let () = mref "args" "go" "here"

(* @@PLEAC@@_11.9 *)
#load "str.cma";;

type record = { name : string;
                empno : int;
                mutable title : string;
                mutable age : int;
                mutable salary : float;
                mutable pals : string list;
              }

let record = { name = "Jason";
               empno = 132;
               title = "deputy peon";
               age = 23;
               salary = 37000.00;
               pals = [ "Norbert"; "Rhys"; "Phineas" ]
             }

let () =
  Printf.printf "I am %s, and my pals are %s.\n"
    record.name
    (String.concat ", " record.pals)

let byname = Hashtbl.create 0

let () =
  (* store record *)
  Hashtbl.replace byname record.name record;

  (* later on, look up by name *)
  begin
    try
      let rp = Hashtbl.find byname "Aron" in
      Printf.printf "Aron is employee %d\n" rp.empno
    with Not_found ->
      (* raised if missing *)
      ()
  end;

  (* give jason a new pal *)
  let jason = Hashtbl.find byname "Jason" in
  jason.pals <- "Theodore" :: jason.pals;
  Printf.printf "Jason now has %d pals\n" (List.length jason.pals);

  Hashtbl.iter
    (fun name record ->
       Printf.printf "%s is employee number %d\n" name record.empno)
    byname

let employees = Hashtbl.create 0

let () =
  (* store record *)
  Hashtbl.replace employees record.empno record;

  (* lookup by id *)
  begin
    try
      let rp = Hashtbl.find employees 132 in
      Printf.printf "employee number 132 is %s\n" rp.name
    with Not_found ->
      ()
  end;

  let jason = Hashtbl.find byname "Jason" in
  jason.salary <- jason.salary *. 1.035

(* Return true if the string s contains the given substring. *)
let contains s substring =
  try ignore (Str.search_forward (Str.regexp_string substring) s 0); true
  with Not_found -> false

let () =
  (* A filter function for hash tables, written as a fold. *)
  let grep f hash =
    Hashtbl.fold
      (fun key value result ->
         if f value then value :: result else result)
      hash [] in

  (* Select records matching criteria. *)
  let peons =
    grep (fun employee -> contains employee.title "peon") employees in
  let tsevens =
    grep (fun employee -> employee.age = 27) employees in

  (* Go through all records. *)
  let records = Hashtbl.fold (fun _ v a -> v :: a) employees [] in
  List.iter
    (fun rp ->
       Printf.printf "%s is age %d.\n" rp.name rp.age)
    (List.sort (fun r1 r2 -> compare r1.age r2.age) records)

(* Create an array of lists of records by age. *)
let byage = Array.create 150 []
let () =
  Hashtbl.iter
    (fun _ employee ->
       byage.(employee.age) <- employee :: byage.(employee.age))
    employees

(* Print all employees by age. *)
let () =
  Array.iteri
    (fun age emps ->
       match emps with
         | [] -> ()
         | _ ->
             Printf.printf "Age %d: " age;
             List.iter (fun emp -> Printf.printf "%s " emp.name) emps;
             print_newline ())
    byage

(* Similar approach using List.map and String.concat. *)
let () =
  Array.iteri
    (fun age emps ->
       match emps with
         | [] -> ()
         | _ ->
             Printf.printf "Age %d: %s\n" age
               (String.concat ", " (List.map (fun r -> r.name) emps)))
    byage

(* @@PLEAC@@_11.10 *)
#load "str.cma";;

(* Define a list reference to contain our data. *)
let (list_of_records : (string, string) Hashtbl.t list ref) = ref []

(* Read records from standard input. *)
let () =
  let regexp = Str.regexp "\\([^:]+\\):[ \t]*\\(.*\\)" in
  let record = ref (Hashtbl.create 0) in
  begin
    try
      while true do
        let line = read_line () in
        if Str.string_match regexp line 0
        then
          let field = Str.matched_group 1 line in
          let value = Str.matched_group 2 line in
          Hashtbl.replace !record field value
        else
          (list_of_records := !record :: !list_of_records;
           record := Hashtbl.create 0)
      done
    with End_of_file ->
      if Hashtbl.length !record > 0
      then list_of_records := !record :: !list_of_records
  end

(* Write records to standard output. *)
let () =
  List.iter
    (fun record ->
       Hashtbl.iter
         (fun field value -> Printf.printf "%s: %s\n" field value)
         record;
       print_newline ())
    !list_of_records

(* @@PLEAC@@_11.11 *)
(* If you are in the OCaml toplevel, simply enter an expression to
   view its type and value. *)
# let reference = ref ( [ "foo", "bar" ],
                        3,
                        fun () -> print_endline "hello, world" );;
val reference : ((string * string) list * int * (unit -> unit)) ref =
  {contents = ([("foo", "bar")], 3, <fun>)}

(* From within your own programs, use the Std.print and Std.dump
   functions from the Extlib library, available at
   http://ocaml-lib.sourceforge.net/ *)
# Std.print reference;;
(([("foo", "bar")], 3, <closure>))
- : unit = ()
# Std.dump reference;;
- : string = "(([(\"foo\", \"bar\")], 3, <closure>))"

(* @@PLEAC@@_11.12 *)
(* Immutable data structures such as int, char, float, tuple, list, Set,
   and Map can be copied by assignment. *)
let v2 = v1
let r2 = ref !r1

(* Objects can be shallow-copied using Oo.copy. *)
let o2 = Oo.copy o1

(* Several built-in types include copy functions. *)
let a2 = Array.copy a1
let h2 = Hashtbl.copy h1
let s2 = String.copy s1

(* Any data structure can be deep-copied by running it through Marshal,
   though this is not very efficient. *)
let (copy : 'a -> 'a) =
  fun value ->
    Marshal.from_string
      (Marshal.to_string value [Marshal.Closures])
      0

(* @@PLEAC@@_11.13 *)
let () =
  (* Store a data structure to disk. *)
  let out_channel = open_out_bin "filename" in
  Marshal.to_channel out_channel data [];
  close_out out_channel;

  (* Load a data structure from disk. *)
  let in_channel = open_in_bin "filename" in
  let data = Marshal.from_channel in_channel in
  (* ... *)
  ();;

#load "unix.cma";;
let () =
  (* Store a data structure to disk, with exclusive locking. *)
  let out_channel = open_out_bin "filename" in
  Unix.lockf (Unix.descr_of_out_channel out_channel) Unix.F_LOCK 0;
  Marshal.to_channel out_channel data [];
  close_out out_channel;

  (* Load a data structure from disk, with shared locking. *)
  let in_channel = open_in_bin "filename" in
  Unix.lockf (Unix.descr_of_in_channel in_channel) Unix.F_RLOCK 0;
  let data = Marshal.from_channel in_channel in
  (* ... *)
  ()

(* @@PLEAC@@_11.14 *)
(* See recipes 14.8 and 14.9 for examples of (mostly) transparent
   persistence using DBM and Marshal in a type-safe manner. *)

(* @@PLEAC@@_11.15 *)
(* bintree - binary tree demo program *)

type 'a tree = { value : 'a;
                 left  : 'a tree option;
                 right : 'a tree option }

let rec string_of_tree tree =
  Printf.sprintf "{ value = %d; left = %s; right = %s }"
    tree.value
    (match tree.left with
       | None -> "None"
       | Some tree -> Printf.sprintf "Some (%s)" (string_of_tree tree))
    (match tree.right with
       | None -> "None"
       | Some tree -> Printf.sprintf "Some (%s)" (string_of_tree tree))

(* insert given value into proper point of
   provided tree.  If no tree provided,
   fill one in for our caller. *)
let rec insert tree value =
  match tree with
    | None -> { value = value; left = None; right = None }
    | Some tree ->
        if tree.value > value
        then { value = tree.value;
               left  = Some (insert tree.left value);
               right = tree.right }
        else if tree.value < value
        then { value = tree.value;
               left  = tree.left;
               right = Some (insert tree.right value) }
        else tree

(* recurse on left child,
   then show current value,
   then recurse on right child. *)
let rec in_order tree =
  match tree with
    | None -> ()
    | Some tree ->
        in_order tree.left;
        print_int tree.value;
        print_string " ";
        in_order tree.right

(* show current value,
   then recurse on left child,
   then recurse on right child. *)
let rec pre_order tree =
  match tree with
    | None -> ()
    | Some tree ->
        print_int tree.value;
        print_string " ";
        pre_order tree.left;
        pre_order tree.right

(* recurse on left child,
   then recurse on right child,
   then show current value. *)
let rec post_order tree =
  match tree with
    | None -> ()
    | Some tree ->
        post_order tree.left;
        post_order tree.right;
        print_int tree.value;
        print_string " "

(* find out whether provided value is in the tree.
   if so, return the node at which the value was found.
   cut down search time by only looking in the correct
   branch, based on current value. *)
let rec search tree value =
  match tree with
    | Some tree ->
        if tree.value = value
        then Some tree
        else search (if value < tree.value then tree.left else tree.right) value
    | None -> None

(* reference to the root of the tree *)
let root = ref None

(* first generate 20 random inserts *)
let () =
  Random.self_init ();
  for n = 0 to 19 do
    root := Some (insert !root (Random.int 1000))
  done

(* now dump out the tree all three ways *)
let () =
  print_string "Pre order: "; pre_order !root; print_newline ();
  print_string "In order: "; in_order !root; print_newline ();
  print_string "Post order: "; post_order !root; print_newline ()

(* prompt until EOF *)
let () =
  try
    while true do
      let line = read_line () in
      let num = int_of_string line in
      let found = search !root num in
      match found with
        | Some tree ->
            Printf.printf "Found %d at %s, %d\n"
              num
              (string_of_tree tree)
              tree.value
        | None ->
            Printf.printf "No %d in the tree\n" num
    done
  with End_of_file ->
    ()

(* @@PLEAC@@_12.0 *)
(* When an OCaml source file is compiled, it becomes a module. The name
   of the module is the capitalized form of the filename. For example,
   if the source file is "my_module.ml", the module name is "My_module".

   Modules can also be created explicitly within a source file. If
   "my_module.ml" contains "module Foo = struct ... end", a module named
   "My_module.Foo" will be created.

   Here is an example of the definition and use of two modules within a
   single source file: *)

module Alpha = struct
  let name = "first"
end

module Omega = struct
  let name = "last"
end

let () =
  Printf.printf "Alpha is %s, Omega is %s.\n"
    Alpha.name Omega.name

(* Alpha is first, Omega is last. *)

(*-----------------------------*)

(* The "#use" and "#load" commands are known as toplevel directives.
   They can only be used while interacting with the interpreter or from
   scripts that are run using the "ocaml" program. *)

(* "#use" loads a source file into the current scope. *)
#use "FileHandle.ml";;

(* "#load" loads a module from a compiled bytecode file. This has the
   same effect as including this file during bytecode compilation. *)
#load "FileHandle.cmo";;

(* "#load" can be used with libraries as well as modules. Bytecode
   libraries use an extension of ".cma". *)
#load "library.cma";;

(* The "open" statement can be used in any source file. It allows any
   values defined within a module to be used without being prefixed by
   the module name. *)
open FileHandle

(* Modules form a hierarchy; submodules can be opened in a similar
   fashion by prefixing them with the parent module's name. *)
open Cards.Poker

(* It is often convenient to use Gerd Stolpmann's "findlib" system,
   which makes it considerably easier to load libraries into the
   interpreter. *)

# #use "topfind";;
- : unit = ()
Findlib has been successfully loaded. Additional directives:
  #require "package";;      to load a package
  #list;;                   to list the available packages
  #camlp4o;;                to load camlp4 (standard syntax)
  #camlp4r;;                to load camlp4 (revised syntax)
  #predicates "p,q,...";;   to set these predicates
  Topfind.reset();;         to force that packages will be reloaded
  #thread;;                 to enable threads

- : unit = ()
# #require "extlib";;
/usr/lib/ocaml/3.10.2/extlib: added to search path
/usr/lib/ocaml/3.10.2/extlib/extLib.cma: loaded

(* The above use of "#require" has the same effect as typing the
   following: *)

#directory "+extlib";;
#load "extLib.cma";;

(* More information on the "findlib" system is available here:
   http://projects.camlcity.org/projects/findlib.html

   The "#directory" directive above is built into OCaml and allows
   you to add additional directories to the path that is searched
   when loading modules. You can use a prefix of '+' to indicate that
   the directory is under the standard library path, which is usually
   something like "/usr/lib/ocaml/3.10.2/".

   Modules can be easily aliased using assignment. This will also
   cause the interpreter to output the module's signature, which
   can be used as a quick reference. *)

# module S = ExtString.String;;
module S :
  sig
    val init : int -> (int -> char) -> string
    val find : string -> string -> int
    val split : string -> string -> string * string
    val nsplit : string -> string -> string list
    val join : string -> string list -> string
    ...
  end
# S.join;;
- : string -> string list -> string = <fun>

(* Many useful libraries can be found at The Caml Hump:
   http://caml.inria.fr/cgi-bin/hump.cgi *)

(* @@PLEAC@@_12.1 *)
(* Interfaces, also known as module types or signatures, are usually
   saved in files with the same name as the corresponding module but
   with a ".mli" extension. For instance, if the module is defined in
   "YourModule.ml", the interface will be in "YourModule.mli". *)

(* YourModule.mli *)
val version : string

(* YourModule.ml *)
let version = "1.00"

(* As with modules, interfaces can also be defined explicitly inside
   of a source file. *)

module type YourModuleSignature =
sig
  val version : string
end

module YourModule : YourModuleSignature =
struct
  let version = "1.00"
end

(* Signatures can also be anonymous. *)

module YourModule :
sig
  val version : string
end =
struct
  let version = "1.00"
end

(* @@PLEAC@@_12.2 *)
(* Due to static typing, missing modules are detected at compilation
   time, so this is not normally an error you can catch (or need to).
   When using ocaml interactively or as an interpreter, the "#load"
   directive can fail, resulting in a message like the following:

       Cannot find file <filename>.

   being printed to standard output. This is also not an error you can
   catch, and its occurrence will not stop the script from executing.
   It is possible to dynamically load modules and detect the failure of
   this operation with Dynlink. An example is given in the next recipe. *)

(* @@PLEAC@@_12.3 *)
(* Registry.ml *)
let (registry : (string, unit -> unit) Hashtbl.t) = Hashtbl.create 32

(* SomeModule.ml *)
let say_hello () = print_endline "Hello, world!"
let () = Hashtbl.replace Registry.registry "say_hello" say_hello

(* Main program *)
let filename = "SomeModule.cmo"
let funcname = "say_hello"
let () =
  Dynlink.init ();
  (try Dynlink.loadfile filename
   with Dynlink.Error e -> failwith (Dynlink.error_message e));
  (Hashtbl.find Registry.registry funcname) ()

(* Note that the Dynlink module currently supports dynamic loading of
   bytecode modules only. There is a project to add support for dynamic
   loading of native code which has been merged with OCaml's CVS HEAD.
   Details are available at http://alain.frisch.fr/natdynlink.html *)

(* @@PLEAC@@_12.4 *)
#load "str.cma";;
module Flipper :
sig
  val flip_boundary : string -> string
  val flip_words : string -> string
end =
struct
  let separatrix = ref " "  (* hidden by signature *)
  let flip_boundary sep =
    let prev_sep = !separatrix in
    separatrix := sep;
    prev_sep
  let flip_words line =
    let words = Str.split (Str.regexp_string !separatrix) line in
    String.concat !separatrix (List.rev words)
end

(* @@PLEAC@@_12.5 *)
(* This is very difficult to do in OCaml due to the lack of reflection
   capabilities. Determining the current module name is reasonably easy,
   however, by using the __FILE__ constant exposed by camlp4's macro
   extensions. *)

(*pp camlp4of *)
let __MODULE__ = String.capitalize (Filename.chop_extension __FILE__)
let () = Printf.printf "I am in module %s\n" __MODULE__

(* @@PLEAC@@_12.6 *)
(* Use the built-in function, "at_exit", to schedule clean-up handlers
   to run when the main program exits. *)

#load "unix.cma";;

let logfile = "/tmp/mylog"
let lf = open_out logfile

let logmsg msg =
  Printf.fprintf lf "%s %d: %s\n%!"
    Sys.argv.(0) (Unix.getpid ()) msg

(* Setup code. *)
let () =
  logmsg "startup"

(* Clean-up code. *)
let () =
  at_exit
    (fun () ->
       logmsg "shutdown";
       close_out lf)

(* @@PLEAC@@_12.7 *)
(* To add a directory to the module include path, pass the "-I" option
   to any of the compiler tools. For example, if you have a module in
   ~/ocamllib called Utils with a filename of utils.cmo, you can build
   against this module with the following: *)

$ ocamlc -I ~/ocamllib utils.cmo test.ml -o test

(* Within the toplevel interpreter, and from ocaml scripts, you can use
   the "#directory" directive to add directories to the include path: *)

#directory "/home/myuser/ocamllib";;
#load "utils.cmo";;

(* In both cases, prefixing the include directory with a '+' indicates
   that the directory should be found relative to the standard include
   path. *)

#directory "+pcre";;
#load "pcre.cma";;

(* If you have findlib installed, you can print out the include path by
   typing "ocamlfind printconf path" at the command line. *)

$ ocamlfind printconf path
/usr/local/lib/ocaml/3.10.2
/usr/lib/ocaml/3.10.2
/usr/lib/ocaml/3.10.2/METAS

(* Instead of keeping a directory of ".cmo" (or ".cmx") files, you may
   prefer to build a library (".cma" for bytecode, ".cmxa" for native).
   This will pack all of your modules into a single file that is easy to
   use during compilation: *)

$ ocamlc -a slicer.cmo dicer.cmo -o tools.cma
$ ocamlc tools.cma myprog.ml -o myprog

(* @@PLEAC@@_12.8 *)
(* The easiest way to prepare a library for distribution is to build with
   OCamlMakefile and include a META file for use with findlib.

   OCamlMakefile is available here:
   http://www.ocaml.info/home/ocaml_sources.html#OCamlMakefile

   findlib is available here:
   http://projects.camlcity.org/projects/findlib.html *)

(* Put the following in a file called "Makefile" and edit to taste: *)

OCAMLMAKEFILE = OCamlMakefile

RESULT = mylibrary
SOURCES = mylibrary.mli mylibrary.ml
PACKS = pcre

all: native-code-library byte-code-library
install: libinstall
uninstall: libuninstall

include $(OCAMLMAKEFILE)

(* Put the following in a file called "META" and edit to taste: *)

name = "mylibrary"
version = "1.0.0"
description = "My library"
requires = "pcre"
archive(byte) = "mylibrary.cma"
archive(native) = "mylibrary.cmxa"

(* Now you can build bytecode and native libraries with "make" and
   install them into the standard library location with "make install".
   If you make a change, you will have to "make uninstall" before you
   can "make install" again. Once a library is installed, it's simple
   to use: *)

$ ledit ocaml
        Objective Caml version 3.10.2

# #use "topfind";;
- : unit = ()
Findlib has been successfully loaded. Additional directives:
  #require "package";;      to load a package
  #list;;                   to list the available packages
  #camlp4o;;                to load camlp4 (standard syntax)
  #camlp4r;;                to load camlp4 (revised syntax)
  #predicates "p,q,...";;   to set these predicates
  Topfind.reset();;         to force that packages will be reloaded
  #thread;;                 to enable threads

- : unit = ()
# #require "mylibrary";;
/usr/lib/ocaml/3.10.2/pcre: added to search path
/usr/lib/ocaml/3.10.2/pcre/pcre.cma: loaded
/usr/local/lib/ocaml/3.10.2/mylibrary: added to search path
/usr/local/lib/ocaml/3.10.2/mylibrary/mylibrary.cma: loaded

(* To compile against your new library, use the "ocamlfind" tool as a
   front-end to "ocamlc" and "ocamlopt": *)

$ ocamlfind ocamlc -package mylibrary myprogram.ml -o myprogram
$ ocamlfind ocamlopt -package mylibrary myprogram.ml -o myprogram

(* @@PLEAC@@_12.9 *)
(* OCaml supports native compilation. If module load time is an issue,
   it's hard to find a better solution than "ocamlopt". If compilation
   is slow as well, try "ocamlopt.opt", which is the natively-compiled
   native compiler. *)

(* @@PLEAC@@_12.10 *)
(* This recipe is not relevant or applicable to OCaml. *)

(* @@PLEAC@@_12.11 *)
#load "unix.cma";;

(* The Unix module returns the time as a float. Using a local module
   definition and an "include", we can override this function to return
   an int32 instead. (This is a bit silly, but it illustrates the basic
   technique. *)
module Unix = struct
  include Unix
  let time () = Int32.of_float (time ())
end

(* Use the locally modified Unix.time function. *)
let () =
  let start = Unix.time () in
  while true do
    Printf.printf "%ld\n" (Int32.sub (Unix.time ()) start)
  done

(* Operators can also be locally modified. Here, we'll temporarily
   define '-' as int32 subtraction. *)
let () =
  let ( - ) = Int32.sub in
  let start = Unix.time () in
  while true do
    Printf.printf "%ld\n" (Unix.time () - start)
  done

(* @@PLEAC@@_12.12 *)
(* There are two built-in functions that raise standard exceptions.
   Many standard library functions use these. "invalid_arg" raises
   an Invalid_argument exception, which takes a string parameter: *)
let even_only n =
  if n land 1 <> 0 (* one way to test *)
  then invalid_arg (string_of_int n);
  (* ... *)
  ()

(* "failwith" raises a Failure exception, which also takes a string
   parameter (though it is typically used to identify the name of
   the function as opposed to the argument). *)
let even_only n =
  if n mod 2 <> 0 (* here's another *)
  then failwith "even_only";
  (* ... *)
  ()

(* In most cases, it is preferable to define your own exceptions. *)
exception Not_even of int
let even_only n =
  if n land 1 <> 0 then raise (Not_even n);
  (* ... *)
  ()

(* OCaml does not provide a facility for emitting warnings. You can
   write to stderr, which may be an acceptable substitute. *)
let even_only n =
  let n =
    if n land 1 <> 0 (* test whether odd number *)
    then (Printf.eprintf "%d is not even, continuing\n%!" n; n + 1)
    else n in
  (* ... *)
  ()

(* @@PLEAC@@_12.13 *)
(* Generally, it is best to use tables of functions, possibly with
   Dynlink, to delay the choice of module and function until runtime.
   It is however possible--though inelegant--to (ab)use the toplevel
   for this purpose. *)

open Printf

(* Toplevel evaluator. Not type-safe. *)
let () = Toploop.initialize_toplevel_env ()
let eval text = let lexbuf = (Lexing.from_string text) in
  let phrase = !Toploop.parse_toplevel_phrase lexbuf in
  ignore (Toploop.execute_phrase false Format.std_formatter phrase)
let get name = Obj.obj (Toploop.getvalue name)
let set name value = Toploop.setvalue name (Obj.repr value)

(* Some module and value names, presumably not known until runtime. *)
let modname = "Sys"
let varname = "ocaml_version"
let aryname = "argv"
let funcname = "getenv"

(* Use the toplevel to evaluate module lookups dynamically. *)
let () =
  eval (sprintf "let (value : string) = %s.%s;;" modname varname);
  print_endline (get "value");
  eval (sprintf "let (values : string array) = %s.%s;;" modname aryname);
  Array.iter print_endline (get "values");
  eval (sprintf "let (func : string -> string) = %s.%s;;" modname funcname);
  print_endline ((get "func") "HOME");

(* @@PLEAC@@_12.14 *)
(* There are several tools for translating C header files to OCaml
   bindings, many of which can be found at The Caml Hump:

   http://caml.inria.fr/cgi-bin/hump.en.cgi?sort=0&browse=42

   Of the available tools, "ocamlffi" (also known as simply "FFI") seems
   to work best at accomplishing the task of parsing header files, but
   it has not been maintained in many years and cannot handle the deep
   use of preprocessor macros in today's Unix headers. As a result, it is
   often necessary to create a header file by hand, and so long as this
   is required, better results can be achieved with Xavier Leroy's
   CamlIDL tool. CamlIDL can be found here:

   http://caml.inria.fr/pub/old_caml_site/camlidl/

   The following recipes will use CamlIDL. First, we'll wrap the Unix
   "gettimeofday" system call by writing the following to a file named
   "time.idl": *)

quote(C,"#include <sys/time.h>");

struct timeval {
    [int32] int tv_sec;
    [int32] int tv_usec;
};

struct timezone {
    int tz_minuteswest;
    int tz_dsttime;
};

int gettimeofday([out] struct timeval *tv, [in] struct timezone *tz);

(* We can now build three files, "time.ml", "time.mli", and
   "time_stubs.c", corresponding to the OCaml implementation, OCaml
   interface, and OCaml-to-C stubs, by running the following command: *)

$ camlidl -no-include time.idl

(* CamlIDL automatically translates the two structs defined in the IDL
   into OCaml record types and builds an external function reference
   for "gettimeofday", resulting in the following generated OCaml
   implementation in "time.ml": *)

(* File generated from time.idl *)

type timeval = {
  tv_sec: int32;
  tv_usec: int32;
}
and timezone = {
  tz_minuteswest: int;
  tz_dsttime: int;
}

external gettimeofday : timezone option -> int * timeval
        = "camlidl_time_gettimeofday"

(* Now, we can use "ocamlc -c" as a front-end to the C compiler to build
   the stubs, producing time_stubs.o. *)

$ ocamlc -c time_stubs.c

(* The OCaml source can be built and packed into a library along with
   the compiled stubs using "ocamlc -a": *)

$ ocamlc -a -custom -o time.cma time.mli time.ml time_stubs.o \
                -cclib -lcamlidl

(* Finally, we can write a simple test program to use our newly-exposed
   "gettimeofday" function. *)

(* test.ml *)
let time () =
  let res, {Time.tv_sec=seconds; tv_usec=microseconds} =
    Time.gettimeofday None in
  Int32.to_float seconds +. (Int32.to_float microseconds /. 1_000_000.)
let () = Printf.printf "%f\n" (time ())

(* Compiling this test program is straightforward. *)

$ ocamlc -o test time.cma test.ml

(* Running it produces the current time with millisecond precision. *)

$ ./test
1217173408.931277

(*---------------------------*)

(* The next two recipes will wrap the Unix "ioctl" function, allowing
   us to make a few low-level I/O system calls. To make things easier,
   we'll use the following Makefile (make sure you use tabs, not spaces,
   if you cut and paste this code): *)

all: jam winsz

jam: ioctl.cma jam.ml
        ocamlc -o jam ioctl.cma jam.ml

winsz: ioctl.cma winsz.ml
        ocamlc -o winsz ioctl.cma winsz.ml

ioctl.cma: ioctl.mli ioctl.ml ioctl_stubs.o
        ocamlc -a -custom -o ioctl.cma ioctl.mli ioctl.ml ioctl_stubs.o \
                -cclib -lcamlidl

ioctl_stubs.o: ioctl_stubs.c
        ocamlc -c ioctl_stubs.c

ioctl.mli ioctl.ml ioctl_stubs.c: ioctl.idl
        camlidl -no-include ioctl.idl

clean:
        rm -f *.cma *.cmi *.cmo *.c *.o ioctl.ml ioctl.mli jam winsz

(*---------------------------*)

(* ioctl.idl: *)

quote(C,"#include <sys/ioctl.h>");

enum ioctl {
    TIOCSTI,
    TIOCGWINSZ,
};

int ioctl([in] int fd,
          [in] enum ioctl request,
          [in, out, string] char *argp);

(*---------------------------*)

(* jam - stuff characters down STDIN's throat *)

(* Simulate input on a given terminal. *)
let jam ?(tty=0) s =
  String.iter
    (fun c -> ignore (Ioctl.ioctl tty Ioctl.TIOCSTI (String.make 1 c))) s

(* Stuff command-line arguments into STDIN. *)
let () = jam (String.concat " " (List.tl (Array.to_list (Sys.argv))))

(*---------------------------*)

(* winsz - find x and y for chars and pixels *)

(* Decode a little-endian short integer from a string and offset. *)
let decode_short s i =
  Char.code s.[i] lor Char.code s.[i + 1] lsl 8

(* Read and display the window size. *)
let () =
  let winsize = String.make 8 '\000' in
  ignore (Ioctl.ioctl 0 Ioctl.TIOCGWINSZ winsize);
  let row = decode_short winsize 0 in
  let col = decode_short winsize 2 in
  let xpixel = decode_short winsize 4 in
  let ypixel = decode_short winsize 6 in
  Printf.printf "(row,col) = (%d,%d)" row col;
  if xpixel <> 0 || ypixel <> 0
  then Printf.printf "  (xpixel,ypixel) = (%d,%d)" xpixel ypixel;
  print_newline ()

(* @@PLEAC@@_12.15 *)
(* Building libraries with C code is much easier with the aid of
   OCamlMakefile. The following Makefile is all it takes to build
   the "time" library from the previous recipe: *)

OCAMLMAKEFILE = OCamlMakefile

RESULT = time
SOURCES = time.idl
NOIDLHEADER = yes