(* -*- 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
*)
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 = *)
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 = *)
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 =
# "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 -> "" ^ s ^ "
")
(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 <![CDATA[ .. ]]> displays from HTML doc. *)
let () =
Stream.iter
print_endline
(stream_range_patterns
(Str.regexp ".*<![CDATA[")
(Str.regexp ".*]]>")
(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 vi can edit troff 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";;