Ocaml/FAQ/Classes Objects and Ties

(* The simplest object possible. This object has no data, no methods,
   and does not belong to any class. *)
let obj = object end
 
(* The simplest class possible, and an instance of it. *)
class encoder = object end
let obj = new encoder
 
(* A class living inside of a module. *)
module Data = struct
  class encoder = object end
end
let obj = new Data.encoder
 
(* An object with data and a method. *)
let obj = object
  val data = [3; 5]
  method at n = List.nth data n
end
let () =
  (* Display the object's identity (an integer) and call a method. *)
  Printf.printf "%d %d\n" (Oo.id obj) (obj#at 1)
 
(* A module containing a class with data and a method. *)
module Human = struct
  class ['a] cannibal data = object
    val data : 'a list = data
    method at n = List.nth data n
  end
end
let () =
  let obj = new Human.cannibal [3; 5] in
  Printf.printf "%d %d\n" (Oo.id obj) (obj#at 1)
 
(* Method calls are indicated by the '#' operator. *)
let encoded = obj#encode "data"
 
(* There is no notion of a class method in OCaml.
   Use a module-level function instead. *)
let encoded = Data.Encoder.encode "data"
 
(* Using the "class" keyword is much like defining a function. *)
class klass (initial_name : string) = object
  val mutable my_name = initial_name
  method name = my_name
  method set_name name = my_name <- name
end
let () =
  let obj = new klass "Class" in
  print_endline obj#name;
  obj#set_name "Clown";
  print_endline obj#name
 
(* Initialization can be performed prior to object creation. *)
class random n =
  let rng = Random.State.make_self_init () in
object
  method next () = Random.State.int rng n
end
let () =
  let r = new random 10 in
  Printf.printf "Three random numbers: %d, %d, %d.\n"
    (r#next ()) (r#next ()) (r#next ())
 
(* Initialization can also be performed after object creation.
   Note the "self" parameter, which can be used much like the
   "this" reference in other OO languages. *)
class late_initializer name = object (self)
  val my_name = name
  method prepare_name () = String.capitalize my_name
  initializer Printf.printf "%s is ready\n" (self#prepare_name ())
end
let obj = new late_initializer "object"
 
(* Methods are curried just like functions. This allows them to
   be used just like functions in many cases. It is customary for
   methods to take at least one argument (even if it is unit)
   unless they represent an object's attribute. *)
module Human = struct
  class cannibal (name : string) = object
    val mutable name = name
    method name = name
    method feed who = print_endline ("Feeding " ^ who)
    method move where = print_endline ("Moving to " ^ where)
    method die () = print_endline "Dying"
  end
end
let () =
  let lector = new Human.cannibal "Hannibal" in
  let feed, move, die = lector#feed, lector#move, lector#die in
  Printf.printf "Cannibal's name is %s\n" lector#name;
  feed "Zak";
  move "New York";
  die ()

#load "unix.cma";;
 
class klass args = object (self)
  val mutable start = 0.
  val mutable age = 0
  val extra = Hashtbl.create 0
 
  (* Private method to initialize fields. Sets start to
     the current time, and age to 0. If called with arguments,
     init interprets them as key+value pairs to initialize the
     hashtable "extra" with. *)
  method private init () =
    start <- Unix.time ();
    List.iter
      (fun (k, v) -> Hashtbl.replace extra k v)
      args
 
  initializer
    self#init ()
end

(* The Gc.finalise function can be used to create finalizers,
   which are like destructors but run at garbage collection time,
   for any value, not just objects. You can still use a method if
   you want: *)
 
class klass =
object (self)
  initializer
    Gc.finalise (fun self -> self#destroy ()) self
  method destroy () =
    Printf.printf "klass %d is dying\n" (Oo.id self)
end
let () =
  ignore (new klass);
  Gc.full_major ()
 
(* The "destroy" method above is public. If you want to keep it
   hidden, you can create a finalizer in a let-binding instead: *)
 
class klass =
  let destroy obj =
    Printf.printf "klass %d is dying\n" (Oo.id obj) in
object (self)
  initializer Gc.finalise destroy self
end

(* Using a get and set method. *)
class person = object
  val mutable name = ""
  method name = name
  method set_name name' = name <- name'
end
 
(* Using a single method that does both get and set. *)
class person = object
  val mutable age = 0
 
  (* Unit argument required due to optional argument. *)
  method age ?set () =
    match set with Some age' -> (age <- age'; age) | None -> age
end
 
(* Sample call of get and set: happy birthday! *)
let () =
  let obj = new person in
  ignore (obj#age ~set:(obj#age () + 1) ())
 
(* This class converts input when the name is set. *)
#load "str.cma";;
class person =
  let funny_chars = Str.regexp ".*[^\n\r\t A-Za-z0-9'-]" in
  let numbers = Str.regexp ".*[0-9]" in
  let not_blank = Str.regexp ".*[^\n\r\t ]" in
  let multiword = Str.regexp ".*[^\n\r\t ]+[\n\r\t ]+[^\n\r\t ]" in
object
  val mutable name = ""
  method name = name
  method set_name name' =
    if Str.string_match funny_chars name' 0
    then failwith "funny characters in name"
    else if Str.string_match numbers name' 0
    then failwith "numbers in name"
    else if not (Str.string_match not_blank name' 0)
    then failwith "name is blank"
    else if not (Str.string_match multiword name' 0)
    then failwith "prefer multiword name"
    else name <- String.capitalize name'
end
 
(* A typical class with attributes and methods. *)
class person = object
  (* Instance variables *)
  val mutable name = ""
  val mutable age = 0
  val mutable peers = []
 
  (* Accessors *)
  method name = name
  method set_name name' = name <- name'
  method age = age
  method set_age age' = age <- age'
  method peers = peers
  method set_peers peers' = peers <- peers'
 
  (* Behavioral methods *)
  method exclaim () =
    Printf.sprintf "Hi, I'm %s age %d, working with %s"
      name age (String.concat ", " peers)
  method happy_birthday () =
    age <- age + 1
end

(* There are no class methods in OCaml. Use a module instead. *)
module Person = struct
  let _body_count = ref 0
  let population () = !_body_count
  let destroy person = decr _body_count
  class person = object (self)
    initializer
      incr _body_count;
      Gc.finalise destroy self
  end
end
 
(* Later, the user can say this: *)
let () =
  let people = ref [] in
  for i = 1 to 10 do people := new Person.person :: !people done;
  Printf.printf "There are %d people alive.\n" (Person.population ())
  (* There are 10 people alive. *)
 
(* A class with an attribute that changes all instances when set. *)
module FixedArray = struct
  let _bounds = ref 7  (* default *)
  let max_bounds () = !_bounds
  let set_max_bounds max = _bounds := max
  class fixed_array = object
    method max_bounds = !_bounds
    method set_max_bounds bounds' = _bounds := bounds'
  end
end
let () =
  (* Set for whole class *)
  FixedArray.set_max_bounds 100;
  let alpha = new FixedArray.fixed_array in
  Printf.printf "Bound on alpha is %d\n" alpha#max_bounds;
  (* 100 *)
  let beta = new FixedArray.fixed_array in
  beta#set_max_bounds 50;
  Printf.printf "Bound on alpha is %d\n" alpha#max_bounds;
  (* 50 *)
 
(* To make the bounds read only, just remove the set method. *)

(* Immediate objects can be used like records, and their types are
   inferred automatically. Unlike with records, object fields names
   do not have to be unique to a module, which can be convenient. *)
let p = object
  method name = "Jason Smythe"
  method age = 13
  method peers = [| "Wilbur"; "Ralph"; "Fred" |]
end
(* val p : < age : int; name : string; peers : string array > = <obj> *)
 
(* Fetch various values, including the zeroth friend. *)
let () =
  Printf.printf "At age %d, %s's first friend is %s.\n"
    p#age p#name p#peers.(0)
(* At age 13, Jason Smythe's first friend is Wilbur. *)
 
(*---------------------------*)
 
(* Immediate objects can be nested. *)
let folks = object
  method head = object
    method name = "John"
    method age = 34
  end
end
(* val folks : < head : < age : int; name : string > > = <obj> *)
let () =
  Printf.printf "%s's age is %d\n"
    folks#head#name folks#head#age
(* John's age is 34 *)
 
(*---------------------------*)
 
(* If you want to maintain an invariant, it's better to use a class. *)
exception Unreasonable_age of int
class person init_name init_age = object (self)
  val mutable name = ""
  val mutable age = 0
  method name = name
  method age = age
  method set_name name' = name <- name'
  method set_age age' =
    if age' > 150 then raise (Unreasonable_age age') else age <- age'
  initializer
    self#set_name init_name;
    self#set_age init_age
end

(* Objects can be cloned with Oo.copy. *)
let ob1 = new some_class
(* later on *)
let ob2 = Oo.copy ob1
 
(* Objects can also be cloned using the functional update syntax. *)
class person (name : string) (age : int) = object
  val name = name
  val age = age
  method name = name
  method age = age
  method with_name name' = {< name = name' >}
  method with_age age' = {< age = age' >}
  method copy () = {< >}
end

(* Create a hashtable mapping method names to method calls. *)
let methods = Hashtbl.create 3
let () =
  Hashtbl.replace methods "run"   (fun obj -> obj#run ());
  Hashtbl.replace methods "start" (fun obj -> obj#start ());
  Hashtbl.replace methods "stop"  (fun obj -> obj#stop ())
 
(* Call the three methods on the object by name. *)
let () =
  List.iter
    (fun m -> (Hashtbl.find methods m) obj)
    ["start"; "run"; "stop"]
 
(* You can alias a method as long as it takes at least one argument. *)
let () =
  let meth = obj#run in
  (* ... *)
  meth ()

(* OCaml has no runtime type information and therefore no "instanceof"
   operator. One alternative would be to provide methods to query for
   an object's class. *)
class widget (name : string) = object
  method name = name
  method is_widget = true
  method is_gadget = false
end
class gadget name = object
  inherit widget name
  method is_gadget = true
end
 
(* Another solution would be to use the visitor pattern. *)
class widget (name : string) = object (self)
  method name = name
  method accept (v : visitor) = v#visit_widget (self :> widget)
end
and gadget name = object (self)
  inherit widget name
  method accept (v : visitor) = v#visit_gadget (self :> gadget)
end
and visitor ~visit_widget ~visit_gadget = object
  method visit_widget = (visit_widget : widget -> unit)
  method visit_gadget = (visit_gadget : gadget -> unit)
end
let () =
  let visitor = new visitor
    ~visit_gadget: (fun gadget ->
                      Printf.printf "Found gadget: %s\n" gadget#name)
    ~visit_widget: (fun widget ->
                      Printf.printf "Found widget: %s\n" widget#name) in
  List.iter
    (fun obj -> obj#accept visitor)
    [new widget "a"; new gadget "b"; new widget "c"]
 
(* Yet another solution would be to rethink your design in terms of
   variants and pattern matching. *)

class person = object (self)
  val mutable name = ""
  val mutable age = 0
  method name = name
  method age = age
  method set_name name' = name <- name'
  method set_age age' = age <- age'
end
 
(*-----------------------------*)
 
let () =
  let dude = new person in
  dude#set_name "Jason";
  dude#set_age 23;
  Printf.printf "%s is age %d\n" dude#name dude#age
 
(*-----------------------------*)
 
class employee = object (self)
  inherit person
end
 
(*-----------------------------*)
 
let () =
  let empl = new employee in
  empl#set_name "Jason";
  empl#set_age 23;
  Printf.printf "%s is age %d\n" empl#name empl#age

class person (name : string) (age : int) = object
  val mutable name = name
  val mutable age = age
  method name = name
  method age = age
  method set_name name' = name <- name'
  method set_age age' = age <- age'
end
 
class liar name age = object
  (* Call superclass constructor and alias superclass as "super". *)
  inherit person name age as super
  (* Call overridden "age" method. *)
  method age = super#age - 10
end

(* Use Jacques Garrigue's pa_oo syntax extension, available at:
   http://www.math.nagoya-u.ac.jp/~garrigue/code/ocaml.html *)
 
(*pp camlp4o pa_oo.cmo *)
class person () = object (self)
  val mutable name = "" with accessor
  val mutable age = 0 with accessor
  val mutable parent = None with reader
  method spawn () = {< parent = Some self >}
end
 
let () =
  let dad = new person () in
  dad#name <- "Jason";
  dad#age <- 23;
  let kid = dad#spawn () in
  kid#name <- "Rachel";
  kid#age <- 2;
  Printf.printf "Kid's parent is %s\n"
    (match kid#parent with
       | Some parent -> parent#name
       | None -> "unknown")

(* Use prefixes in instance variable names so we can tell them apart. *)
class person () = object
  val mutable person_age = 0
  method age = person_age
  method set_age age' = person_age <- age'
end
 
(* Now we can access both instance variables as needed. *)
class employee () = object
  inherit person ()
  val mutable employee_age = 0
  method age = employee_age
  method set_age age' = employee_age <- age'
  method person_age = person_age
  method set_person_age age' = person_age <- age'
end

(* OCaml features a generational garbage collector that can handle
   circular references, so you do not need to do anything special to
   safely dispose of circular data structures. The "DESTROY" method
   has been omitted from this translation since it is unnecessary.
 
   Option types are used heavily due to the imperative style of the
   original recipe, which makes this code somewhat verbose. *)
 
(* A polymorphic, circular data structure. *)
class ['a] ring () = object (self)
  val mutable dummy = (None : 'a ring_node option)
  val mutable count = 0
 
  (* Initialize dummy now that a reference to self is available. *)
  initializer
    (let node = new ring_node () in
     node#set_prev (Some node);
     node#set_next (Some node);
     dummy <- Some node)
 
  (* Return the number of values in the ring. *)
  method count = count
 
  (* Insert a value into the ring structure. *)
  method insert value =
    let node = new ring_node () in
    node#set_value (Some value);
    (match dummy with
       | Some ring_dummy ->
           node#set_next ring_dummy#next;
           (match ring_dummy#next with
              | Some ring_dummy_next ->
                  ring_dummy_next#set_prev (Some node)
              | None -> assert false);
           ring_dummy#set_next (Some node);
           node#set_prev (Some ring_dummy);
           count <- count + 1
       | None -> assert false)
 
  (* Find a value in the ring. *)
  method search value =
    match dummy with
      | Some ring_dummy ->
          (match ring_dummy#next with
             | Some ring_dummy_next ->
                 let node = ref ring_dummy_next in
                 while !node != ring_dummy && !node#value <> (Some value)
                 do node :=
                   match !node#next with
                     | Some n -> n
                     | None -> assert false
                 done;
                 !node
             | None -> assert false)
      | None -> assert false
 
  (* Delete a node from the ring structure. *)
  method delete_node node =
    (match node#prev with
       | Some node_prev -> node_prev#set_next node#next
       | None -> assert false);
    (match node#next with
       | Some node_next -> node_next#set_prev node#prev
       | None -> assert false);
    count <- count - 1
 
  (* Delete a node from the ring structure by value. *)
  method delete_value value =
    let node = self#search value in
    match dummy with
      | Some ring_dummy when node != ring_dummy ->
          self#delete_node node
      | _ -> ()
end
 
(* A node in the ring structure which contains a polymorphic value. *)
and ['a] ring_node () = object
  val mutable prev = (None : 'a ring_node option)
  val mutable next = (None : 'a ring_node option)
  val mutable value = (None : 'a option)
  method prev = prev
  method next = next
  method value = value
  method set_prev prev' = prev <- prev'
  method set_next next' = next <- next'
  method set_value value' = value <- value'
end

(* Create a class with "compare_to" and "to_string" methods. *)
class klass name idnum = object (self)
  val name = (name : string)
  val idnum = (idnum : int)
 
  method name = name
  method idnum = idnum
 
  method compare_to (other : klass) =
    compare
      (String.uppercase self#name)
      (String.uppercase other#name)
 
  method to_string =
    Printf.sprintf "%s (%05d)"
      (String.capitalize self#name)
      self#idnum
end
 
(* Define a comparison operator that invokes a "compare_to" method. *)
let ( <=> ) o1 o2 = (o1 #compare_to o2 : int)
 
(* Demonstrate these two methods. *)
let () =
  let a = new klass "test1" 5 in
  let b = new klass "TEST2" 10 in
  Printf.printf "%d\n" (a <=> b);
  Printf.printf "%s\n%s\n" a#to_string b#to_string
 
(* Define a module to contain our time type. *)
module TimeNumber = struct
 
  (* TimeNumber.t contains the time values. *)
  class t hours minutes seconds = object (self)
    val mutable hours = (hours : int)
    val mutable minutes = (minutes : int)
    val mutable seconds = (seconds : int)
 
    method hours = hours
    method minutes = minutes
    method seconds = seconds
 
    method set_hours hours' = hours <- hours'
    method set_minutes minutes' = minutes <- minutes'
    method set_seconds seconds' = seconds <- seconds'
 
    (* TimeNumber.t#add adds two times together. *)
    method add (other : t) =
      let answer = new t
        (self#hours + other#hours)
        (self#minutes + other#minutes)
        (self#seconds + other#seconds) in
      if answer#seconds >= 60
      then (answer#set_seconds (answer#seconds mod 60);
            answer#set_minutes (answer#minutes + 1));
      if answer#minutes >= 60
      then (answer#set_minutes (answer#minutes mod 60);
            answer#set_hours (answer#hours + 1));
      answer
  end
 
  (* TimeNumber.Operators is a submodule that is designed to be
     imported using "open". It redefines the built-in arithmetic
     operators to work on TimeNumber.t values. *)
  module Operators = struct
    let ( + ) (t1 : t) (t2 : t) = t1 #add t2
    (* let ( - ) (t1 : t) (t2 : t) = t1 #sub t2 *)
    (* let ( * ) (t1 : t) (t2 : t) = t1 #mult t2 *)
    (* let ( / ) (t1 : t) (t2 : t) = t1 #div t2 *)
  end
 
end
 
(* Globally import the custom operators. This will make them work on
   TimeNumber.t values *only* - to do regular integer addition, you
   will now have to use Pervasives.( + ) and so on. *)
open TimeNumber.Operators
let () =
  let t1 = new TimeNumber.t 2 59 59 in
  let t2 = new TimeNumber.t 1 5 6 in
  let t3 = t1 + t2 in
  Printf.printf "%02d:%02d:%02d\n" t3#hours t3#minutes t3#seconds
 
(* Locally import the custom operators using a "let module". The
   operators will only be redefined within the "Local" module. *)
let () =
  let t1 = new TimeNumber.t 2 59 59 in
  let t2 = new TimeNumber.t 1 5 6 in
  let t3 =
    let module Local = struct
      open TimeNumber.Operators
      let result = t1 + t2
    end in Local.result in
  Printf.printf "%02d:%02d:%02d\n" t3#hours t3#minutes t3#seconds
 
(* The openin syntax extension can simplify the above technique.
   openin is available at http://alain.frisch.fr/soft.html#openin *)
let () =
  let t1 = new TimeNumber.t 2 59 59 in
  let t2 = new TimeNumber.t 1 5 6 in
  let t3 = open TimeNumber.Operators in t1 + t2 in
  Printf.printf "%02d:%02d:%02d\n" t3#hours t3#minutes t3#seconds
 
(*-----------------------------*)
 
(* show_strnum - demo operator overloading *)
 
class strnum value = object
  method value = value
  method spaceship (other : strnum) = compare value (other#value)
  method concat (other : strnum) = new strnum (value ^ other#value)
  method repeat n = new strnum (String.concat ""
                                  (Array.to_list (Array.make n value)))
end
 
let (  +  ) a b = a #concat b
let (  *  ) a b = a #repeat b
let ( <=> ) a b = a #spaceship b
let (  <  ) a b = a <=> b < 0
let ( <=  ) a b = a <=> b <= 0
let (  =  ) a b = a <=> b = 0
let ( >=  ) a b = a <=> b >= 0
let (  >  ) a b = a <=> b > 0
 
(*-----------------------------*)
 
let x = new strnum "Red"
let y = new strnum "Black"
let z = x + y
let r = z * 3
 
let () =
  Printf.printf "values are %s, %s, %s, and %s\n"
    x#value y#value z#value r#value;
  Printf.printf "%s is %s %s\n"
    x#value (if x < y then "LT" else "GE") y#value
 
(*
  values are Red, Black, RedBlack, and RedBlackRedBlackRedBlack
  Red is GE Black
*)
 
(*-----------------------------*)
 
(* demo_fixnum - show operator overloading *)
 
module FixNum = struct
  let default_places = ref 0
  class t ?places (value : float) = object
    val mutable places =
      match places with
        | Some n -> n
        | None -> !default_places
    val value = value
    method places = places
    method set_places n = places <- n
    method value = value
    method to_string = Printf.sprintf "FixNum.t: %.*f" places value
  end
end
 
let ( + ) a b =
  new FixNum.t ~places:(max a#places b#places) (a#value +. b#value)
let ( - ) a b =
  new FixNum.t ~places:(max a#places b#places) (a#value -. b#value)
let ( * ) a b =
  new FixNum.t ~places:(max a#places b#places) (a#value *. b#value)
let ( / ) a b =
  new FixNum.t ~places:(max a#places b#places) (a#value /. b#value)
 
(*-----------------------------*)
 
(* let () = FixNum.default_places := 5 *)
 
let x = new FixNum.t 40.
let y = new FixNum.t 12.
 
let () =
  Printf.printf "sum of %s and %s is %s\n"
    x#to_string y#to_string (x + y)#to_string;
  Printf.printf "product of %s and %s is %s\n"
    x#to_string y#to_string (x * y)#to_string
 
let z = x / y
 
let () =
  Printf.printf "%s has %d places\n" z#to_string z#places;
  if z#places = 0 then z#set_places 2;
  Printf.printf "div of %s by %s is %s\n"
    x#to_string y#to_string z#to_string;
  Printf.printf "square of that is %s\n" (z * z)#to_string
 
(*
  sum of FixNum.t: 40 and FixNum.t: 12 is FixNum.t: 52
  product of FixNum.t: 40 and FixNum.t: 12 is FixNum.t: 480
  FixNum.t: 3 has 0 places
  div of FixNum.t: 40 by FixNum.t: 12 is FixNum.t: 3.33
  square of that is FixNum.t: 11.11
*)

(* OCaml does not have anything like Perl's "tie" feature; you can't
   make an identifier evaluate to anything other than itself. Since
   "tie" is just syntax sugar anyway, all of the examples can be done
   with regular classes and objects. *)
 
class ['a] value_ring values = object
  val mutable values = (values : 'a list)
  method get =
    match values with
      | h :: t -> values <- t @ [h]; h
      | [] -> raise Not_found
  method add value =
    values <- value :: values
end
 
(*-----------------------------*)
 
let () =
  let colors = new value_ring ["red"; "blue"] in
  Printf.printf "%s %s %s %s %s %s\n"
    colors#get colors#get colors#get
    colors#get colors#get colors#get;
  (* blue red blue red blue red *)
 
  colors#add "green";
  Printf.printf "%s %s %s %s %s %s\n"
    colors#get colors#get colors#get
    colors#get colors#get colors#get
  (* blue red green blue red green *)
 
(*-----------------------------*)
 
(* Magic hash that autoappends. *)
 
class ['a, 'b] append_hash size = object
  val hash = (Hashtbl.create size : ('a, 'b) Hashtbl.t)
  method get k = Hashtbl.find hash k
  method set k v =
    Hashtbl.replace hash k
      (try v :: Hashtbl.find hash k with Not_found -> [v])
  method each f = Hashtbl.iter f hash
end
 
(*-----------------------------*)
 
let () =
  let tab = new append_hash 3 in
  tab#set "beer" "guinness";
  tab#set "food" "potatoes";
  tab#set "food" "peas";
  tab#each
    (fun k vs ->
       Printf.printf "%s => [%s]\n"
         k (String.concat " " (List.rev vs)))
 
(*-----------------------------*)
 
(*
  beer => [guinness]
  food => [potatoes peas]
*)
 
(*-----------------------------*)
 
(* For a more lightweight syntax, you can override the .{}
   operator--which normally works with Bigarrays--to work on
   any object with "get" and "set" methods. *)
 
module Bigarray = struct
  module Array1 = struct
    let get obj = obj#get
    let set obj = obj#set
  end
end
 
let () =
  let tab = new append_hash 3 in
  tab.{"beer"} <- "guinness";
  tab.{"food"} <- "potatoes";
  tab.{"food"} <- "peas";
  tab#each
    (fun k vs ->
       Printf.printf "%s => [%s]\n"
         k (String.concat " " (List.rev vs)));
  print_endline (List.hd tab.{"beer"})
 
(*-----------------------------*)
 
(* Hash that magically folds case. *)
 
class ['a] folded_hash size = object
  val hash = (Hashtbl.create size : (string, 'a) Hashtbl.t)
  method get k = Hashtbl.find hash (String.lowercase k)
  method set k v = Hashtbl.replace hash (String.lowercase k) v
  method each f = Hashtbl.iter f hash
end
 
(*-----------------------------*)
 
let () =
  let tab = new folded_hash 2 in
  tab.{"VILLAIN"} <- "big ";
  tab.{"herOine"} <- "red riding hood";
  tab.{"villain"} <- tab.{"villain"} ^ "bad wolf";
  tab#each (Printf.printf "%s is %s\n")
 
(*
  heroine is red riding hood
  villain is big bad wolf
*)
 
(*-----------------------------*)
 
(* Hash that permits key *or* value lookups. *)
class ['a] rev_hash size = object
  val hash = (Hashtbl.create size : ('a, 'a) Hashtbl.t)
  method get k = Hashtbl.find hash k
  method set k v =
    Hashtbl.replace hash k v;
    Hashtbl.replace hash v k
  method each f = Hashtbl.iter f hash
end
 
(*-----------------------------*)
 
let () =
  let tab = new rev_hash 8 in
  tab.{`Str "Red"} <- `Str "Rojo";
  tab.{`Str "Blue"} <- `Str "Azul";
  tab.{`Str "Green"} <- `Str "Verde";
  tab.{`Str "EVIL"} <- `StrList [ "No way!"; "Way!!" ];
  let to_string = function
    | `Str s -> s
    | `StrList ss -> "[" ^ String.concat " " ss ^ "]" in
  tab#each
    (fun k v ->
       Printf.printf "%s => %s\n" (to_string k) (to_string v))
 
(*
  Verde => Green
  Azul => Blue
  Green => Verde
  Blue => Azul
  Red => Rojo
  [No way! Way!!] => EVIL
  EVIL => [No way! Way!!]
  Rojo => Red
*)
 
(*-----------------------------*)
 
(* Simple counter. *)
 
class counter start = object
  val mutable value = (start : int)
  method next = value <- value + 1; value
end
 
let () =
  let c = new counter 0 in
  while true do
    Printf.printf "Got %d\n" c#next
  done
 
(*-----------------------------*)
 
(* Tee-like class that outputs to multiple channels at once. *)
 
class tee channels = object
  method print s = List.iter (fun ch -> output_string ch s) channels
end
 
let () =
  let tee = new tee [stdout; stderr] in
  tee#print "This line goes to both places.\n";
  flush_all ()
 
let () =
  let tee = new tee
    (stdout ::
       (Array.to_list
          (Array.init 10
             (fun _ ->
                snd (Filename.open_temp_file "teetest." ""))))) in
  tee#print "This lines goes many places.\n";
  flush_all ()