exo2.ml

(* Lists *)

(* Three cases: empty list, singleton list, and lists with at least two elements. *)
let rec switch = function
  | [] -> []
  | [x] -> [x]
  | x :: y :: rest -> y :: x :: switch rest

let rec unpair = function
  | [] -> []
  | (x,y) :: rest -> x :: y :: unpair rest

(* Three cases, again. *)
let rec remove_succ = function
  | [] -> []
  | [x] -> [x]
  | x :: y :: rest ->
    (* The recursive call is made on y :: rest, because the element following y might be y+1. *)
    if y = x+1 then remove_succ (y :: rest)
    else x :: remove_succ (y :: rest)

let rec combine l1 l2 =
  match l1,l2 with
  | [], [] -> []
  | x1 :: rest1, x2 :: rest2 -> (x1,x2) :: combine rest1 rest2
  | _ -> failwith "combine: lists of different lengths."

let rec keep l1 l2 =
  match l1,l2 with
  | [], [] -> []

  (* These two cases can also be done with a single case and a IF. *)
  | x1 :: rest1, false :: rest2 -> keep rest1 rest2
  | x1 :: rest1, true :: rest2 -> x1 :: keep rest1 rest2

  (* This case happens if l1 or l2 is empty. *)
  | _ -> failwith "keep: lists of different lengths"

let rec map2 f l1 l2 =
  match l1,l2 with
  | [], [] -> []
  | x1 :: rest1, x2 :: rest2 -> (f x1 x2) :: map2 f rest1 rest2
  | _ -> failwith "map2: lists of different lengths"

let rec interleave l1 l2 =
  match l1,l2 with
  | l1, [] -> l1
  | [], l2 -> l2
  | x1 :: rest1, l2 -> x1 :: interleave l2 rest1


(* Variants *)
type bool3 = BTrue | BFalse | Unknown

let and3 a b = match a,b with
  | BFalse, _ | _, BFalse -> BFalse
  | BTrue, x  | x, BTrue -> x
  | Unknown, Unknown -> Unknown

let not3 = function
  | BTrue -> BFalse
  | BFalse -> BTrue
  | Unknown -> Unknown

type instruction = Plus of int | Mul of int

let rec apply_instructions count = function
  | [] -> count
  | Plus n :: rest -> apply_instructions (count + n) rest
  | Mul n :: rest -> apply_instructions (count * n) rest
                       
let rec compact = function
  | [] -> []
  | Plus 0 :: rest -> compact rest
  | Mul 1 :: rest -> compact rest

  (* The recursive call is made at the same starting point, because further compaction can still occur at this point. 
   * The recursion is well-founded because the list length strictly decreases. *)
  | Plus n :: Plus m :: rest -> compact (Plus (n+m) :: rest)
  | Mul n :: Mul m :: rest -> compact (Mul (n*m) :: rest)

  (* Last case: nothing can be compacted at this point, we keep the current element and go on with the list tail. *)
  | el :: rest -> el :: compact rest

                    
let rec to_string acu = function
  | [] -> acu

  (* Because there is only + and * operators, and because * has priority over +, no parentheses are needed here. *)
  | Plus n :: rest -> to_string (acu ^ " + " ^ string_of_int n) rest

  (* For the same reason, parentheses are needed here. *)
  | Mul  n :: rest -> to_string ("(" ^ acu ^ ") * " ^ string_of_int n) rest


let rec to_funlist = function
  | [] -> []

  (* We insert in the list an anonymous function that adds or multiply its argument by n. *)
  | Plus n :: rest -> (fun x -> x + n) :: to_funlist rest
  | Mul n :: rest -> (fun x -> x * n) :: to_funlist rest

(* Another version *)
let to_funlist l = List.map (function Plus n -> (fun x -> x + n) | Mul n -> (fun x -> x * n)) l

(* This is the usual composition operator: g ++ f is  g o f *)
let (++) g f x = g (f x )

(* We start the FOLDing with the neutral element for composition: the identity function fun x -> x. *)
let to_fun l = List.fold_left (fun f g -> g ++ f) (fun x -> x) (to_funlist l)


type 'a element = Single of 'a | Pair of 'a * 'a

type 'a fonct = One_arg of ('a -> 'a) | Two_args of ('a -> 'a -> 'a)

let rec count_elements = function
  | [] -> 0
  | Single _ :: rest -> 1 + count_elements rest
  | Pair _ :: rest -> 2 + count_elements rest

let rec apply_list l1 l2 =
  match (l1,l2) with
  | [], [] -> []
  | One_arg f :: rest1, Single x :: rest2 -> f x :: apply_list rest1 rest2
  | Two_args f :: rest1, Pair (x,y) :: rest2 -> f x y :: apply_list rest1 rest2

  (* Error cases. *)
  | One_arg _ :: _, Pair _ :: _ -> failwith "One arg function applied to a pair."
  | Two_args _ :: _, Single _ :: _ -> failwith "Two arg function applied to a single."
  | _, [] | [], _ -> failwith "Lists of different sizes."

let rec partial_apply x = function
  | [] -> []
  | One_arg f :: rest -> f :: partial_apply x rest
  | Two_args f :: rest -> (f x) :: partial_apply x rest


(* Records *)

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

let rec mk_people_list n =
  if n = 0 then []
  else { name = "John-" ^ string_of_int n ;
         age = 10 * n } :: mk_people_list (n-1)

let rec age_most cmp current = function
  | [] -> current
  | p :: rest -> age_most cmp (if cmp current.age p.age then current else p) rest


type author = Anonymous | Someone of people

type 'a contribution =
  { date: float ;
    author: author ;
    content: 'a }

let mike = { name = "Mike" ; age = 30 }
let rihanna = { name = "Rihanna" ; age = 28 }

let test_contr = [ { date = 100.0 ; author = Anonymous ; content = "afoo1" } ;
                   { date = 90.0  ; author = Someone mike ; content = "bar1" } ;
                   { date = 105.0 ; author = Anonymous ; content = "afoo2" } ;
                   { date = 107.0 ; author = Someone rihanna ; content ="bar2" } ;
                   { date = 102.0 ; author = Someone mike ; content = "bar3" } ]

let rec filter_contributions = function
  | [] -> []
  | { author = Anonymous } :: rest -> filter_contributions rest
  | c :: rest -> c :: filter_contributions rest
                   
(* Alternative *)
let filter_contributions l = List.filter (fun ctr -> ctr.author <> Anonymous) l

let rec map_contributions f = function
  | [] -> []
  | ct :: rest -> { ct with content = f ct.content } :: map_contributions f rest

(* Alternative *)
let map_contributions f l = List.map (fun ct -> { ct with content = f ct.content } ) l

let latest l =
  let rec loop late = function
    | [] -> late
    | ct :: rest ->

      (* Compare ct with the current 'late' *)
      let new_late = match late with
        | None -> Some ct
        | Some ct1 -> if ct.date > ct1.date then Some ct else late
      in
      loop new_late rest
  in  
  loop None l

let rec contents_of guy = function
  | [] -> []
  | ct :: rest ->
    if ct.author = Someone guy then ct.content :: contents_of guy rest
    else contents_of guy rest