1+2*3;;

let pi = 4.0 *. atan 1.0;;

let square x = x *. x;;

square(sin pi) +. square(cos pi);;

1.0 * 2;;

let rec fib n =
  if n < 2 then n else fib(n-1) + fib(n-2);;

fib 10;;

(1 < 2) = false;;

'a';;

"Hello world";;

let l = ["is"; "a"; "tale"; "told"; "etc."];;

"Life" :: l;;

let rec sort lst =
  match lst with
    [] -> []
  | head :: tail -> insert head (sort tail)
and insert elt lst =
  match lst with
    [] -> [elt]
  | head :: tail -> if elt <= head then elt :: lst else head :: insert elt
tail
;;

sort l;;

sort [6;2;5;3];;

sort [3.14; 2.718];;

let deriv f dx = function x -> (f(x +. dx) -. f(x)) /. dx;;

let sin' = deriv sin 1e-6;;

sin' pi;;

let compose f g = function x -> f(g(x));;

let cos2 = compose square cos;;

List.map (function n -> n * 2 + 1) [0;1;2;3;4];;

let rec map f l =
  match l with
    [] -> []
  | hd :: tl -> f hd :: map f tl;;

type ratio = {num: int; denum: int};;

let add_ratio r1 r2 =
  {num = r1.num * r2.denum + r2.num * r1.denum;
   denum = r1.denum * r2.denum};;

add_ratio {num=1; denum=3} {num=2; denum=5};;

type number = Int of int | Float of float | Error;;

type sign = Positive | Negative;;

let sign_int n = if n >= 0 then Positive else Negative;;

let add_num n1 n2 =
  match (n1, n2) with
    (Int i1, Int i2) ->
      (* Check for overflow of integer addition *)
      if sign_int i1 = sign_int i2 && sign_int(i1 + i2) <> sign_int i1
      then Float(float i1 +. float i2)
      else Int(i1 + i2)
  | (Int i1, Float f2) -> Float(float i1 +. f2)
  | (Float f1, Int i2) -> Float(f1 +. float i2)
  | (Float f1, Float f2) -> Float(f1 +. f2)
  | (Error, _) -> Error
  | (_, Error) -> Error;;

add_num (Int 123) (Float 3.14159);;

type 'a btree = Empty | Node of 'a * 'a btree * 'a btree;;

let rec member x btree =
  match btree with
    Empty -> false
  | Node(y, left, right) ->
      if x = y then true else
      if x < y then member x left else member x right;;

let rec insert x btree =
  match btree with
    Empty -> Node(x, Empty, Empty)
  | Node(y, left, right) ->
      if x <= y then Node(y, insert x left, right)
                else Node(y, left, insert x right);;

let add_vect v1 v2 =
  let len = min (Array.length v1) (Array.length v2) in
  let res = Array.create len 0.0 in
  for i = 0 to len - 1 do
    res.(i) <- v1.(i) +. v2.(i)
  done;
  res;;

add_vect [| 1.0; 2.0 |] [| 3.0; 4.0 |];;

type mutable_point = { mutable x: float; mutable y: float };;

let translate p dx dy =
  p.x <- p.x +. dx; p.y <- p.y +. dy;;

let mypoint = { x = 0.0; y = 0.0 };;

translate mypoint 1.0 2.0;;

mypoint;;

let insertion_sort a =
  for i = 1 to Array.length a - 1 do
    let val_i = a.(i) in
    let j = ref i in
    while !j > 0 && val_i < a.(!j - 1) do
      a.(!j) <- a.(!j - 1);
      j := !j - 1
    done;
    a.(!j) <- val_i
  done;;

let current_rand = ref 0;;

let random () =
  current_rand := !current_rand * 25713 + 1345;
  !current_rand;;

type 'a ref = { mutable contents: 'a };;

let (!) r = r.contents;;

let (:=) r newval = r.contents <- newval;;

type idref = { mutable id: 'a. 'a -> 'a };;

let r = {id = fun x -> x};;

let g s = (s.id 1, s.id true);;

r.id <- (fun x -> print_string "called id\n"; x);;

g r;;

exception Empty_list;;

let head l =
  match l with
    [] -> raise Empty_list
  | hd :: tl -> hd;;

head [1;2];;

head [];;

List.assoc 1 [(0, "zero"); (1, "one")];;

List.assoc 2 [(0, "zero"); (1, "one")];;

let name_of_binary_digit digit =
  try
    List.assoc digit [0, "zero"; 1, "one"]
  with Not_found ->
    "not a binary digit";;

name_of_binary_digit 0;;

name_of_binary_digit (-1);;

let temporarily_set_reference ref newval funct =
  let oldval = !ref in
  try
    ref := newval;
    let res = funct () in
    ref := oldval;
    res
  with x ->
    ref := oldval;
    raise x;;

type expression =
    Const of float
  | Var of string
  | Sum of expression * expression    (* e1 + e2 *)
  | Diff of expression * expression   (* e1 - e2 *)
  | Prod of expression * expression   (* e1 * e2 *)
  | Quot of expression * expression   (* e1 / e2 *)
;;

exception Unbound_variable of string;;

let rec eval env exp =
  match exp with
    Const c -> c
  | Var v ->
      (try List.assoc v env with Not_found -> raise(Unbound_variable v))
  | Sum(f, g) -> eval env f +. eval env g
  | Diff(f, g) -> eval env f -. eval env g
  | Prod(f, g) -> eval env f *. eval env g
  | Quot(f, g) -> eval env f /. eval env g;;

eval [("x", 1.0); ("y", 3.14)] (Prod(Sum(Var "x", Const 2.0), Var "y"));;

let rec deriv exp dv =
  match exp with
    Const c -> Const 0.0
  | Var v -> if v = dv then Const 1.0 else Const 0.0
  | Sum(f, g) -> Sum(deriv f dv, deriv g dv)
  | Diff(f, g) -> Diff(deriv f dv, deriv g dv)
  | Prod(f, g) -> Sum(Prod(f, deriv g dv), Prod(deriv f dv, g))
  | Quot(f, g) -> Quot(Diff(Prod(deriv f dv, g), Prod(f, deriv g dv)),
                       Prod(g, g))
;;

deriv (Quot(Const 1.0, Var "x")) "x";;

let print_expr exp =
  (* Local function definitions *)
  let open_paren prec op_prec =
    if prec > op_prec then print_string "(" in
  let close_paren prec op_prec =
    if prec > op_prec then print_string ")" in
  let rec print prec exp =     (* prec is the current precedence *)
    match exp with
      Const c -> print_float c
    | Var v -> print_string v
    | Sum(f, g) ->
        open_paren prec 0;
        print 0 f; print_string " + "; print 0 g;
        close_paren prec 0
    | Diff(f, g) ->
        open_paren prec 0;
        print 0 f; print_string " - "; print 1 g;
        close_paren prec 0
    | Prod(f, g) ->
        open_paren prec 2;
        print 2 f; print_string " * "; print 2 g;
        close_paren prec 2
    | Quot(f, g) ->
        open_paren prec 2;
        print 2 f; print_string " / "; print 3 g;
        close_paren prec 2
  in print 0 exp;;

let e = Sum(Prod(Const 2.0, Var "x"), Const 1.0);;

print_expr e; print_newline();;

print_expr (deriv e "x"); print_newline();;

#load "camlp4o.cma";;

open Genlex;;

let lexer = make_lexer ["("; ")"; "+"; "-"; "*"; "/"];;

let token_stream = lexer(Stream.of_string "1.0 +x");;

Stream.next token_stream;;

Stream.next token_stream;;

Stream.next token_stream;;

let rec parse_expr = parser
    [< e1 = parse_mult; e = parse_more_adds e1 >] -> e
and parse_more_adds e1 = parser
    [< 'Kwd "+"; e2 = parse_mult; e = parse_more_adds (Sum(e1, e2)) >] -> e
  | [< 'Kwd "-"; e2 = parse_mult; e = parse_more_adds (Diff(e1, e2)) >] -> e
  | [< >] -> e1
and parse_mult = parser
    [< e1 = parse_simple; e = parse_more_mults e1 >] -> e
and parse_more_mults e1 = parser
    [< 'Kwd "*"; e2 = parse_simple; e = parse_more_mults (Prod(e1, e2)) >]
-> e
  | [< 'Kwd "/"; e2 = parse_simple; e = parse_more_mults (Quot(e1, e2)) >]
-> e
  | [< >] -> e1
and parse_simple = parser
    [< 'Ident s >] -> Var s
  | [< 'Int i >] -> Const(float i)
  | [< 'Float f >] -> Const f
  | [< 'Kwd "("; e = parse_expr; 'Kwd ")" >] -> e;;

let parse_expression = parser [< e = parse_expr; _ = Stream.empty >] -> e;;

let read_expression s = parse_expression(lexer(Stream.of_string s));;

read_expression "2*(x+y)";;

read_expression "x - 1";;

read_expression "x-1";;

module PrioQueue =
  struct
    type priority = int
    type 'a queue = Empty | Node of priority * 'a * 'a queue * 'a queue
    let empty = Empty
    let rec insert queue prio elt =
      match queue with
        Empty -> Node(prio, elt, Empty, Empty)
      | Node(p, e, left, right) ->
          if prio <= p
          then Node(prio, elt, insert right p e, left)
          else Node(p, e, insert right prio elt, left)
    exception Queue_is_empty
    let rec remove_top = function
        Empty -> raise Queue_is_empty
      | Node(prio, elt, left, Empty) -> left
      | Node(prio, elt, Empty, right) -> right
      | Node(prio, elt, (Node(lprio, lelt, _, _) as left),
                        (Node(rprio, relt, _, _) as right)) ->
          if lprio <= rprio
          then Node(lprio, lelt, remove_top left, right)
          else Node(rprio, relt, left, remove_top right)
    let extract = function
        Empty -> raise Queue_is_empty
      | Node(prio, elt, _, _) as queue -> (prio, elt, remove_top queue)
  end;;

PrioQueue.insert PrioQueue.empty 1 "hello";;

module type PRIOQUEUE =
  sig
    type priority = int         (* still concrete *)
    type 'a queue               (* now abstract *)
    val empty : 'a queue
    val insert : 'a queue -> int -> 'a -> 'a queue
    val extract : 'a queue -> int * 'a * 'a queue
    exception Queue_is_empty
  end;;

module AbstractPrioQueue = (PrioQueue : PRIOQUEUE);;

AbstractPrioQueue.remove_top;;

AbstractPrioQueue.insert AbstractPrioQueue.empty 1 "hello";;

type comparison = Less | Equal | Greater;;

module type ORDERED_TYPE =
  sig
    type t
    val compare: t -> t -> comparison
  end;;

module Set =
  functor (Elt: ORDERED_TYPE) ->
    struct
      type element = Elt.t
      type set = element list
      let empty = []
      let rec add x s =
        match s with
          [] -> [x]
        | hd::tl ->
           match Elt.compare x hd with
             Equal   -> s         (* x is already in s *)
           | Less    -> x :: s    (* x is smaller than all elements of s *)
           | Greater -> hd :: add x tl
      let rec member x s =
        match s with
          [] -> false
        | hd::tl ->
            match Elt.compare x hd with
              Equal   -> true     (* x belongs to s *)
            | Less    -> false    (* x is smaller than all elements of s *)
            | Greater -> member x tl
    end;;

module OrderedString =
  struct
    type t = string
    let compare x y = if x = y then Equal else if x < y then Less else
Greater
  end;;

module StringSet = Set(OrderedString);;

StringSet.member "bar" (StringSet.add "foo" StringSet.empty);;

module type SETFUNCTOR =
  functor (Elt: ORDERED_TYPE) ->
    sig
      type element = Elt.t      (* concrete *)
      type set                  (* abstract *)
      val empty : set
      val add : element -> set -> set
      val member : element -> set -> bool
    end;;

module AbstractSet = (Set : SETFUNCTOR);;

module AbstractStringSet = AbstractSet(OrderedString);;

AbstractStringSet.add "gee" AbstractStringSet.empty;;

module type SET =
  sig
    type element
    type set
    val empty : set
    val add : element -> set -> set
    val member : element -> set -> bool
  end;;

module WrongSet = (Set : functor(Elt: ORDERED_TYPE) -> SET);;

module WrongStringSet = WrongSet(OrderedString);;

WrongStringSet.add "gee" WrongStringSet.empty;;

module AbstractSet = 
  (Set : functor(Elt: ORDERED_TYPE) -> (SET with type element = Elt.t));;

module NoCaseString =
  struct
    type t = string
    let compare s1 s2 =
      OrderedString.compare (String.lowercase s1) (String.lowercase s2)
  end;;

module NoCaseStringSet = AbstractSet(NoCaseString);;

NoCaseStringSet.add "FOO" AbstractStringSet.empty;;

class point =
  object 
    val mutable x = 0
    method get_x = x
    method move d = x <- x + d
  end;;

let p = new point;;

p#get_x;;

p#move 3;;

p#get_x;;

let x0 = ref 0;;

class point =
  object 
    val mutable x = incr x0; !x0
    method get_x = x
    method move d = x <- x + d
  end;;

new point#get_x;;

new point#get_x;;

class point = fun x_init -> 
  object 
    val mutable x = x_init
    method get_x = x
    method move d = x <- x + d
  end;;

class point x_init =
  object 
    val mutable x = x_init
    method get_x = x
    method move d = x <- x + d
  end;;

new point;;

let p = new point 7;;

class point x_init =
  object 
    val mutable x = x_init
    method get_x = x
    method get_offset = x - x_init
    method move d = x <- x + d 
  end;;

class adjusted_point x_init =
  let origin = (x_init / 10) * 10 in
  object 
    val mutable x = origin
    method get_x = x
    method get_offset = x - origin
    method move d = x <- x + d
  end;;

class adjusted_point x_init =  point ((x_init / 10) * 10);;

let new_adjusted_point x_init = new point ((x_init / 10) * 10);;

let p =
  object 
    val mutable x = 0
    method get_x = x
    method move d = x <- x + d
  end;;

p#get_x;;

p#move 3;;

p#get_x;;

let minmax x y =
  if x < y then object method min = x method max = y end
  else object method min = y method max = x end;;

class printable_point x_init =
  object (s)
    val mutable x = x_init
    method get_x = x
    method move d = x <- x + d
    method print = print_int s#get_x
  end;;

let p = new printable_point 7;;

p#print;;

let ints = ref [];;

class my_int =
  object (self)
    method n = 1
    method register = ints := self :: !ints
  end;;

let my_int =
  object (self)
    method n = 1
    method register = ints := self :: !ints
  end;;

class printable_point x_init =
  let origin = (x_init / 10) * 10 in
  object (self)
    val mutable x = origin
    method get_x = x
    method move d = x <- x + d
    method print = print_int self#get_x
    initializer print_string "new point at "; self#print; print_newline()
  end;;

let p = new printable_point 17;;

class virtual abstract_point x_init =
  object (self)
    method virtual get_x : int
    method get_offset = self#get_x - x_init
    method virtual move : int -> unit
  end;;

class point x_init =
  object
    inherit abstract_point x_init
    val mutable x = x_init
    method get_x = x
    method move d = x <- x + d 
  end;;

class virtual abstract_point2 =
  object
    val mutable virtual x : int
    method move d = x <- x + d 
  end;;

class point2 x_init =
  object
    inherit abstract_point2
    val mutable x = x_init
    method get_offset = x - x_init
  end;;

class restricted_point x_init =
  object (self)
    val mutable x = x_init
    method get_x = x
    method private move d = x <- x + d
    method bump = self#move 1
  end;;

let p = new restricted_point 0;;

p#move 10;;

p#bump;;

class point_again x =
  object (self)
    inherit restricted_point x
    method virtual move : _
  end;;

class point_again x =
  object (self : < move : _; ..> )
    inherit restricted_point x
  end;;

class point_again x =
  object
    inherit restricted_point x as super
    method move = super#move 
  end;;

class type restricted_point_type = 
  object
    method get_x : int
    method bump : unit
end;;

fun (x : restricted_point_type) -> x;;

class restricted_point' x = (restricted_point x : restricted_point_type);;

class restricted_point' = (restricted_point : int ->
restricted_point_type);;

module type POINT = sig 
  class restricted_point' : int ->
    object    
      method get_x : int
      method bump : unit
    end 
end;;

module Point : POINT = struct 
  class restricted_point' = restricted_point
end;;

class colored_point x (c : string) =
  object 
    inherit point x
    val c = c
    method color = c
  end;;

let p' = new colored_point 5 "red";;

p'#get_x, p'#color;;

let get_succ_x p = p#get_x + 1;;

get_succ_x p + get_succ_x p';;

let set_x p = p#set_x;;

let incr p = set_x p (get_succ_x p);;

class printable_colored_point y c = 
  object (self)
    val c = c
    method color = c
    inherit printable_point y as super
    method print =
      print_string "(";
      super#print;
      print_string ", ";
      print_string (self#color);
      print_string ")"
  end;;

let p' = new printable_colored_point 17 "red";;

p'#print;;

class ref x_init =
  object 
    val mutable x = x_init
    method get = x
    method set y = x <- y
  end;;

class ref (x_init:int) =
  object 
    val mutable x = x_init
    method get = x
    method set y = x <- y
  end;;

let new_ref x_init =
  object 
    val mutable x = x_init
    method get = x
    method set y = x <- y
  end;;

class ['a] ref x_init = 
  object 
    val mutable x = (x_init : 'a)
    method get = x
    method set y = x <- y
  end;;

let r = new ref 1 in r#set 2; (r#get);;

class ['a] ref_succ (x_init:'a) = 
  object
    val mutable x = x_init + 1
    method get = x
    method set y = x <- y
  end;;

class ['a] circle (c : 'a) =
  object 
    val mutable center = c
    method center = center
    method set_center c = center <- c
    method move = (center#move : int -> unit)
  end;;

class ['a] circle (c : 'a) =
  object 
    constraint 'a = #point
    val mutable center = c
    method center = center
    method set_center c = center <- c
    method move = center#move
  end;;

class ['a] colored_circle c =
  object
    constraint 'a = #colored_point
    inherit ['a] circle c
    method color = center#color
  end;;

List.fold_left;;

class ['a] intlist (l : int list) =
  object
    method empty = (l = [])
    method fold f (accu : 'a) = List.fold_left f accu l
  end;;

let l = new intlist [1; 2; 3];;

l#fold (fun x y -> x+y) 0;;

l;;

l#fold (fun s x -> s ^ string_of_int x ^ " ") "";;

class intlist (l : int list) =
  object
    method empty = (l = [])
    method fold : 'a. ('a -> int -> 'a) -> 'a -> 'a =
      fun f accu -> List.fold_left f accu l
  end;;

let l = new intlist [1; 2; 3];;

l#fold (fun x y -> x+y) 0;;

l#fold (fun s x -> s ^ string_of_int x ^ " ") "";;

class intlist_rev l =
  object
    inherit intlist l
    method fold f accu = List.fold_left f accu (List.rev l)
  end;;

class type ['a] iterator =
  object method fold : ('b -> 'a -> 'b) -> 'b -> 'b end;;

class intlist l =
  object (self : int #iterator)
    method empty = (l = [])
    method fold f accu = List.fold_left f accu l
  end;;

let sum lst = lst#fold (fun x y -> x+y) 0;;

sum l;;

let sum (lst : _ #iterator) = lst#fold (fun x y -> x+y) 0;;

let sum lst =
  (lst : < fold : 'a. ('a -> _ -> 'a) -> 'a -> 'a; .. >)#fold (+) 0;;

class type point0 = object method get_x : int end;;

class distance_point x =
  object
    inherit point x
    method distance : 'a. (#point0 as 'a) -> int =
      fun other -> abs (other#get_x - x)
  end;;

let p = new distance_point 3 in
(p#distance (new point 8), p#distance (new colored_point 1 "blue"));;

class multi_poly =
  object
    method m1 : 'a. (< n1 : 'b. 'b -> 'b; .. > as 'a) -> _ =
      fun o -> o#n1 true, o#n1 "hello"
    method m2 : 'a 'b. (< n2 : 'b -> bool; .. > as 'a) -> 'b -> _ =
      fun o x -> o#n2 x
  end;;

let colored_point_to_point cp = (cp : colored_point :> point);;

let p = new point 3 and q = new colored_point 4 "blue";;

let l = [p; (colored_point_to_point q)];;

(p : point :> colored_point);;

let to_point cp = (cp :> point);;

class c0 = object method m = {< >} method n = 0 end;;

class type c1 =  object method m : c1 end;;

fun (x:c0) -> (x : c0 :> c1);;

fun (x:c0) -> (x :> c1);;

class type c2 =  object ('a) method m : 'a end;;

fun (x:c0) -> (x :> c2);;

let to_c1 x = (x :> c1);;

let to_c2 x = (x :> c2);;

function x -> (x :> 'a);;

class c = object method m = 1 end
and d = object (self)
  inherit c
  method n = 2
  method as_c = (self :> c)
end;;

class c = object (self) method m = (self :> c) end;;

let all_c = ref [];;

class c (m : int) =
  object (self)
    method m = m
    initializer all_c := (self :> c) :: !all_c
  end;;

let rec lookup_obj obj = function [] -> raise Not_found
  | obj' :: l ->
     if (obj :> < >) = (obj' :> < >) then obj' else lookup_obj obj l ;;

let lookup_c obj = lookup_obj obj !all_c;;

class type c' = object method m : int end;;

class c : c' = object method m = 1 end
and d = object (self)
  inherit c
  method n = 2
  method as_c = (self :> c')
end;;

class virtual c' = object method virtual m : int end;;

class c = object (self) inherit c' method m = 1 end;;

type c' = <m : int>;;

type 'a c'_class = 'a constraint 'a = < m : int; .. >;;

class functional_point y =
  object 
    val x = y
    method get_x = x
    method move d = {< x = x + d >}
  end;;

let p = new functional_point 7;;

p#get_x;;

(p#move 3)#get_x;;

p#get_x;;

class bad_functional_point y =
  object 
    val x = y
    method get_x = x
    method move d = new bad_functional_point (x+d)
  end;;

Oo.copy;;

let p = new point 5;;

let q = Oo.copy p;;

q#move 7; (p#get_x, q#get_x);;

let q = Oo.copy p;;

p = q, p = p;;

class copy =
  object
    method copy = {< >}
  end;;

class copy =
  object (self)
    method copy = Oo.copy self
  end;;

class backup = 
  object (self : 'mytype)
    val mutable copy = None
    method save = copy <- Some {< copy = None >}
    method restore = match copy with Some x -> x | None -> self
  end;;

class ['a] backup_ref x = object inherit ['a] ref x inherit backup end;;

let rec get p n = if n = 0 then p # get else get (p # restore) (n-1);;

let p = new backup_ref 0  in
p # save; p # set 1; p # save; p # set 2; 
[get p 0; get p 1; get p 2; get p 3; get p 4];;

class backup = 
  object (self : 'mytype)
    val mutable copy = None
    method save = copy <- Some {< >}
    method restore = match copy with Some x -> x | None -> self
    method clear = copy <- None
  end;;

class ['a] backup_ref x = object inherit ['a] ref x inherit backup end;;

let p = new backup_ref 0  in
p # save; p # set 1; p # save; p # set 2; 
[get p 0; get p 1; get p 2; get p 3; get p 4];;

class window =
  object 
    val mutable top_widget = (None : widget option)
    method top_widget = top_widget
  end
and widget (w : window) =
  object
    val window = w
    method window = window
  end;;

class virtual comparable = 
  object (_ : 'a)
    method virtual leq : 'a -> bool
  end;;

class money (x : float) =
  object
    inherit comparable
    val repr = x
    method value = repr
    method leq p = repr <= p#value
  end;;

class money2 x =
  object   
    inherit money x
    method times k = {< repr = k *. repr >}
  end;;

let min (x : #comparable) y =
  if x#leq y then x else y;;

(min (new money  1.3) (new money 3.1))#value;;

(min (new money2 5.0) (new money2 3.14))#value;;

class money x =
  object (self : 'a)
    val repr = x
    method value = repr
    method print = print_float repr
    method times k = {< repr = k *. x >}
    method leq (p : 'a) = repr <= p#value
    method plus (p : 'a) = {< repr = x +. p#value >}
  end;;

class safe_money x =
  object (self : 'a)
    val repr = x
    method print = print_float repr
    method times k = {< repr = k *. x >}
  end;;

module type MONEY = 
  sig 
    type t
    class c : float -> 
      object ('a)
        val repr : t
        method value : t
        method print : unit
        method times : float -> 'a
        method leq : 'a -> bool
        method plus : 'a -> 'a 
      end
  end;;

module Euro : MONEY = 
  struct
    type t = float
    class c x =
      object (self : 'a)
        val repr = x
        method value = repr
        method print = print_float repr
        method times k = {< repr = k *. x >}
        method leq (p : 'a) = repr <= p#value
        method plus (p : 'a) = {< repr = x +. p#value >}
      end
  end;;

ListLabels.map;;

StringLabels.sub;;

let f ~x ~y = x - y;;

let x = 3 and y = 2 in f ~x ~y;;

let f ~x:x1 ~y:y1 = x1 - y1;;

f ~x:3 ~y:2;;

let f ~x ~y = x - y;;

f ~y:2 ~x:3;;

ListLabels.fold_left;;

ListLabels.fold_left [1;2;3] ~init:0 ~f:(+);;

ListLabels.fold_left ~init:0;;

let hline ~x:x1 ~x:x2 ~y = (x1, x2, y);;

hline ~x:3 ~y:2 ~x:5;;

f 3 2;;

ListLabels.map succ [1;2;3];;

ListLabels.fold_left (+) 0 [1;2;3];;

let h g = g ~x:3 ~y:2;;

h f;;

h (+);;

h (fun ~x:_ ~y -> y+1);;

let bump ?(step = 1) x = x + step;;

bump 2;;

bump ~step:3 2;;

let test ?(x = 0) ?(y = 0) () ?(z = 0) () = (x, y, z);;

test ();;

test ~x:2 () ~z:3 ();;

test ~y:2 ~x:3 () ();;

test () () ~z:1 ~y:2 ~x:3;;

(test () ()) ~z:1;;

let bump ?step x =
  match step with
  | None -> x * 2
  | Some y -> x + y
;;

let test2 ?x ?y () = test ?x ?y () ();;

test2 ?x:None;;

let h' g = g ~y:2 ~x:3;;

h' f;;

let bump_it bump x =
  bump ~step:2 x;;

bump_it bump 1;;

let bump_it (bump : ?step:int -> int -> int) x =
  bump ~step:2 x;;

bump_it bump 1;;

let twice f (x : int) = f(f x);;

twice bump 2;;

[`On; `Off];;

`Number 1;;

let f = function `On -> 1 | `Off -> 0 | `Number n -> n;;

List.map f [`On; `Off];;

type 'a vlist = [`Nil | `Cons of 'a * 'a vlist];;

let rec map f : 'a vlist -> 'b vlist = function
  | `Nil -> `Nil
  | `Cons(a, l) -> `Cons(f a, map f l)
;;

let f = function `A -> `C | `B -> `D | x -> x;;

f `E;;

let f1 = function `A x -> x = 1 | `B -> true | `C -> false
let f2 = function `A x -> x = "a" | `B -> true ;;

let f x = f1 x && f2 x;;

type 'a wlist = [`Nil | `Cons of 'a * 'a wlist | `Snoc of 'a wlist * 'a];;

let wlist_of_vlist  l = (l : 'a vlist :> 'a wlist);;

let open_vlist l = (l : 'a vlist :> [> 'a vlist]);;

fun x -> (x :> [`A|`B|`C]);;

let split_cases = function
  | `Nil | `Cons _ as x -> `A x
  | `Snoc _ as x -> `B x
;;

let num x = `Num x
let eval1 eval (`Num x) = x
let rec eval x = eval1 eval x ;;

let plus x y = `Plus(x,y)
let eval2 eval = function
  | `Plus(x,y) -> eval x + eval y
  | `Num _ as x -> eval1 eval x
let rec eval x = eval2 eval x ;;

let f = function
  | #myvariant -> "myvariant"
  | `Tag3 -> "Tag3";;

let g1 = function `Tag1 _ -> "Tag1" | `Tag2 _ -> "Tag2";;

let g = function
  | #myvariant as x -> g1 x
  | `Tag3 -> "Tag3";;

type abc = [`A | `B | `C] ;;

let f = function
  | `As -> "A"
  | #abc -> "other" ;;

let f : abc -> string = f ;;

let f : abc -> string = function
  | `As -> "A"
  | #abc -> "other" ;;

let euro = new Euro.c;;

let zero = euro 0.;;

let neg x = x#times (-1.);;

class account =
  object 
    val mutable balance = zero
    method balance = balance
    method deposit x = balance <- balance # plus x
    method withdraw x =
      if x#leq balance then (balance <- balance # plus (neg x); x) else zero
  end;;

let c = new account in c # deposit (euro 100.); c # withdraw (euro 50.);;

class account_with_interests =
  object (self)
    inherit account
    method private interest = self # deposit (self # balance # times 0.03)
  end;;

class safe_account =
  object
    inherit account
    method deposit x = if zero#leq x then balance <- balance#plus x
  end;;

class safe_account =
  object
    inherit account as unsafe
    method deposit x =
      if zero#leq x then unsafe # deposit x
      else raise (Invalid_argument "deposit")
  end;;

type 'a operation = Deposit of 'a | Retrieval of 'a;;

class account_with_history =
  object (self) 
    inherit safe_account as super  
    val mutable history = []
    method private trace x = history <- x :: history
    method deposit x = self#trace (Deposit x);  super#deposit x
    method withdraw x = self#trace (Retrieval x); super#withdraw x
    method history = List.rev history
  end;;

class account_with_deposit x =
  object 
    inherit account_with_history 
    initializer balance <- x 
  end;;

class account_with_deposit x =
  object (self)
    inherit account_with_history 
    initializer self#deposit x
  end;;

let ccp = new account_with_deposit (euro 100.) in 
let balance = ccp#withdraw (euro 50.) in
ccp#history;;

let close c = c#withdraw (c#balance);;

let today () = (01,01,2000) (* an approximation *)
module Account (M:MONEY) =
  struct
    type m = M.c
    let m = new M.c
    let zero = m 0. 
        
    class bank =
      object (self) 
        val mutable balance = zero
        method balance = balance
        val mutable history = []
        method private trace x = history <- x::history
        method deposit x =
          self#trace (Deposit x);
          if zero#leq x then balance <- balance # plus x
          else raise (Invalid_argument "deposit")
        method withdraw x =
          if x#leq balance then
            (balance <- balance # plus (neg x); self#trace (Retrieval x); x)
          else zero
        method history = List.rev history
      end
        
    class type client_view = 
      object
        method deposit : m -> unit
        method history : m operation list
        method withdraw : m -> m
        method balance : m
      end
          
    class virtual check_client x = 
      let y = if (m 100.)#leq x then x
      else raise (Failure "Insufficient initial deposit") in
      object (self) initializer self#deposit y end
        
    module Client (B : sig class bank : client_view end) =
      struct
        class account x : client_view =
          object
            inherit B.bank
            inherit check_client x
          end
            
        let discount x =
          let c = new account x in
          if today() < (1998,10,30) then c # deposit (m 100.); c
      end
  end;;

module Euro_account = Account(Euro);;

module Client = Euro_account.Client (Euro_account);;

new Client.account (new Euro.c 100.);;

module Investment_account (M : MONEY) = 
  struct
    type m = M.c
    module A = Account(M)
        
    class bank =
      object
        inherit A.bank as super
        method deposit x =
          if (new M.c 1000.)#leq x then
            print_string "Would you like to invest?";
          super#deposit x
      end
        
    module Client = A.Client
  end;;

module Internet_account (M : MONEY) = 
  struct
    type m = M.c
    module A = Account(M)
  
    class bank =
      object
        inherit A.bank 
        method mail s = print_string s
      end
        
    class type client_view = 
      object
        method deposit : m -> unit
        method history : m operation list
        method withdraw : m -> m
        method balance : m
        method mail : string -> unit
      end
          
    module Client (B : sig class bank : client_view end) =
      struct
        class account x : client_view =
          object
            inherit B.bank
            inherit A.check_client x
          end
      end
  end;;

class ostring s =
  object
     method get n = String.get s n
     method set n c = String.set s n c
     method print = print_string s
     method copy = new ostring (String.copy s)
  end;;

class sub_string s =
  object
     inherit ostring s
     method sub start len = new sub_string (String.sub s  start len)
  end;;

class better_string s =
  object
     val repr = s
     method get n = String.get repr n
     method set n c = String.set repr n c
     method print = print_string repr
     method copy = {< repr = String.copy repr >}
     method sub start len = {< repr = String.sub s  start len >}
  end;;

class ostring s =
  object (self : 'mytype)
     val repr = s
     method repr = repr
     method get n = String.get repr n
     method set n c = String.set repr n c
     method print = print_string repr
     method copy = {< repr = String.copy repr >}
     method sub start len = {< repr = String.sub s start len >}
     method concat (t : 'mytype) = {< repr = repr ^ t#repr >}
  end;;

class cstring n = ostring (String.create n);;

exception Empty;;

class ['a] stack =
  object 
    val mutable l = ([] : 'a list)
    method push x = l <- x::l
    method pop = match l with [] -> raise Empty | a::l' -> l <- l'; a
    method clear = l <- []
    method length = List.length l
  end;;

class ['a, 'b] stack2 =
  object
    inherit ['a] stack
    method fold f (x : 'b) = List.fold_left f x l
  end;;

let s = new stack2;;

s#fold (+) 0;;

s;;

class ['a] stack3 =
  object
    inherit ['a] stack
    method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b
                = fun f x -> List.fold_left f x l
  end;;

class type ['a, 'b] hash_table =
  object 
    method find : 'a -> 'b
    method add : 'a -> 'b -> unit
  end;;

class ['a, 'b] small_hashtbl : ['a, 'b] hash_table =
  object
    val mutable table = []
    method find key = List.assoc key table
    method add key valeur = table <- (key, valeur) :: table
  end;;

class ['a, 'b] hashtbl size : ['a, 'b] hash_table =
  object (self)
    val table = Array.init size (fun i -> new small_hashtbl) 
    method private hash key =
      (Hashtbl.hash key) mod (Array.length table)
    method find key = table.(self#hash key) # find key
    method add key = table.(self#hash key) # add key
  end;;

module type SET =
  sig
    type 'a tag
    class ['a] c :
      object ('b)
        method is_empty : bool
        method mem : 'a -> bool
        method add : 'a -> 'b
        method union : 'b -> 'b
        method iter : ('a -> unit) -> unit
        method tag : 'a tag
      end
  end;;

module Set : SET =
  struct
    let rec merge l1 l2 =
      match l1 with
        [] -> l2
      | h1 :: t1 ->
          match l2 with
            [] -> l1
          | h2 :: t2 ->
              if h1 < h2 then h1 :: merge t1 l2
              else if h1 > h2 then h2 :: merge l1 t2
              else merge t1 l2
    type 'a tag = 'a list
    class ['a] c =
      object (_ : 'b)
        val repr = ([] : 'a list)
        method is_empty = (repr = [])
        method mem x = List.exists ((=) x) repr
        method add x = {< repr = merge [x] repr >}
        method union (s : 'b) = {< repr = merge repr s#tag >}
        method iter (f : 'a -> unit) = List.iter f repr
        method tag = repr
      end
  end;;

class virtual ['subject, 'event] observer =
  object
    method virtual notify : 'subject ->  'event -> unit
  end;;

class ['observer, 'event] subject =
  object (self)
    val mutable observers = ([]:'observer list)
    method add_observer obs = observers <- (obs :: observers)
    method notify_observers (e : 'event) = 
        List.iter (fun x -> x#notify self e) observers
  end;;

type event = Raise | Resize | Move;;

let string_of_event = function
    Raise -> "Raise" | Resize -> "Resize" | Move -> "Move";;

let count = ref 0;;

class ['observer] window_subject =
  let id = count := succ !count; !count in
  object (self)
    inherit ['observer, event] subject
    val mutable position = 0
    method identity = id
    method move x = position <- position + x; self#notify_observers Move
    method draw = Printf.printf "{Position = %d}\n"  position;
  end;;

class ['subject] window_observer =
  object
    inherit ['subject, event] observer
    method notify s e = s#draw
  end;;

let window = new window_subject;;

let window_observer = new window_observer;;

window#add_observer window_observer;;

window#move 1;;

class ['observer] richer_window_subject =
  object (self)
    inherit ['observer] window_subject
    val mutable size = 1
    method resize x = size <- size + x; self#notify_observers Resize
    val mutable top = false
    method raise = top <- true; self#notify_observers Raise
    method draw = Printf.printf "{Position = %d; Size = %d}\n"  position
size;
  end;;

class ['subject] richer_window_observer =
  object 
    inherit ['subject] window_observer as super
    method notify s e = if e <> Raise then s#raise; super#notify s e
  end;;

class ['subject] trace_observer = 
  object 
    inherit ['subject, event] observer
    method notify s e =
      Printf.printf
        "<Window %d <== %s>\n" s#identity (string_of_event e)
  end;;

let window = new richer_window_subject;;

window#add_observer (new richer_window_observer);;

window#add_observer (new trace_observer);;

window#move 1; window#resize 2;;

load "foo.cmo";;

load "bar.cmo";;

load "gee.cmo";;