lesson4.ml


(** Exercise : Records *)

type test =
   { fonc: (int -> int) ;
     arg: int ;
     expect: int }

let apply test = test.fonc test.arg = test.expect

let myf x = x + 1

(* t1 is true *)
let t1 = apply { fonc = myf ;
                 arg  = 0 ;
                 expect = 1 }

(* t2 is false *)
let t2 = apply { fonc = (fun x -> x * 2) ;
                 arg  = 10 ;
                 expect = 0 }

type ('a, 'b) ptest =
   { fonc: ('a -> 'b) ;
     arg: 'a ;
     expect: 'b }


(** Exercise : Mutable types *)

type player =
   { name: string ;
     age: int ;
     mutable points: int }

let show_player p =
  Printf.printf "%s, aged %d, %d points\n%!" p.name p.age p.points ;
  ()

let new_player name age = { name ; age ; points = 0 }

let add_points p n = p.points <- p.points + n

let test =
  let p1 = new_player "Mary" 26
  and p2 = new_player "Joe" 21 in

  show_player p1 ;
  show_player p2 ;

  add_points p1 10 ;
  add_points p1 100 ;
  add_points p2 2 ;
  add_points p2 50 ;

  show_player p1 ;
  show_player p2 ;
  
  ()

type iplayer =
   { iname: string ;
     iage: int ;
     ipoints: int }

let show_iplayer p =
  Printf.printf "%s, aged %d, %d points\n%!" p.iname p.iage p.ipoints ;
  ()

let new_iplayer iname iage = { iname ; iage ; ipoints = 0 }

let add_ipoints p n = { p with ipoints = p.ipoints + n }

(* - Set is not mutable (no side-effect)
 * - Queue is mutable
 * - Hashtbl is mutable
 * - Map is not mutable.
 *
 * Hint: if add returns unit, the type is necessarily mutable.
 *)


(** Exercise : Simple variants *)

type color = White | Yellow | Green | Blue | Red

type role = Player of color * int | Referee

type people =
   { name: string ;
     role: role ;
     age: int }

let same_team p1 p2 = match (p1.role, p2.role) with
  | Player (c1, _), Player (c2, _) -> c1 = c2
  | _ -> false

let play1 = { name = "Play1" ;
              role = Player (White, 4) ;
              age  = 20 }

let play2 = { name = "Play2" ;
              role = Player (Green, 10) ;
              age  = 24 }

let play3 = { name = "Play3" ;
              role = Referee ;
              age  = 31 }

let play4 = { name = "Play4" ;
              role = Player (White, 9) ;
              age  = 26 }

let player_list = [ play1 ; play2 ; play3 ; play4 ]

let test1 = same_team play1 play2
let test2 = same_team play1 play3
let test3 = same_team play1 play4

let is_number p n = match p.role with
  | Player (_, i) -> i = n
  | _ -> false

let test1 = is_number play2 5
let test2 = is_number play2 10
let test3 = is_number play3 10

(** Parameterized and recursive variants *)

type 'a mylist = Empty | Cell of 'a * 'a mylist

let myhd = function
  | Empty -> failwith "empty list"
  | Cell (x, _) -> x

let mytl = function
  | Empty -> failwith "empty list"
  | Cell (_, tl) -> tl

let test_fail () = failwith "foo" (* has type unit -> 'a, hence failwith "foo" has type 'a (i.e. it as all types). *)

let rec mylength = function
  | Empty -> 0
  | Cell (_, tl) -> 1 + mylength tl

(* Tail-recursive version *)
let rec mylength' acu = function
  | Empty -> acu
  | Cell (_, tl) -> mylength' (1 + acu) tl

(* Tail-recursive with inner recursion. *)
let mylength'' l =
  let rec loop acu = function
    | Empty -> acu
    | Cell (_, tl) -> loop (1 + acu) tl
   in
   loop 0 l

(* Builtin list *)
let hd = function
  | [] -> failwith "empty list"
  | x :: _ -> x

let tl = function
  | [] -> failwith "empty list"
  | _ :: tl -> tl

let rec length = function
  | [] -> 0
  | _ :: tl -> 1 + length tl

let rec length' acu = function
  | [] -> acu
  | _ :: tl -> length' (1 + acu) tl

let rec mk_aculist acu n = if n = 0 then acu else mk_aculist (n :: acu) (n-1)

let big = mk_aculist [] 1000000
let test1 = length big
let test1 = length' 0 big

(** Exercise: option type *)
let ohd = function
  | [] -> None
  | x :: _ -> Some x

let otl = function
  | [] -> None
  | _ :: tl -> Some tl

(** Exercise : Ad-hoc functions *)
let rec get_referees = function
  | [] -> []
  | people :: tl -> 
    (match people.role with
     | Referee -> people :: get_referees tl
     | _ -> get_referees tl)

(* Alternative: we can use 'as' in a pattern to bind a variable to a sub-pattern. *)
let rec get_referees = function
  | [] -> []
  | ({ role = Referee } as people) :: tl -> people :: get_referees tl
  | _ :: tl -> get_referees tl

let rec get_younger peoples limit =
  match peoples with
  | [] -> []
  | ppl :: tl ->
    if ppl.age <= limit then ppl :: get_younger tl limit
    else get_younger tl limit

let rec find_color peoples color = match peoples with
  | [] -> None
  | ppl :: tl ->
    (match ppl.role with
     | Player (col, _) -> if col = color then Some ppl else find_color tl color
     | _ -> find_color tl color)

let test1 = get_referees player_list
let test2 = get_younger player_list 24
let test3 = find_color player_list Yellow

(** Exercise : Generic functions *)

let rec filter f = function
  | [] -> []
  | x :: xs -> if f x then x :: filter f xs else filter f xs

(* Alternative, with accumulator *)
let rec filter' f acu = function
  | [] -> acu
  | x :: xs -> filter' f (if f x then x :: acu else acu) xs

let get_referees l = filter (fun p -> p.role = Referee) l
let get_younger l age = filter (fun p -> p.age <= age) l

let rec find pred = function
  | [] -> None
  | x :: xs -> if pred x then Some x else find pred xs

let has_color color p = match p.role with
  | Player (c, _) -> c = color
  | _ -> false

let find_color peoples color = find (has_color color) peoples