seance 8 avril + correction tp7

tp/tp7.ml

+module Association = struct
+  (* Type pour représenter des dictionnaires (ou map ou association) dont la clé est une string *)
+  type 'a t = Vide | Noeud of string * 'a * 'a t * 'a t
+
+  (* Fonction pour chercher dans un dictionnaire. get d k renvoie None si k n'est pas une clé de d,
+      Some x si x est la valeur associée à k dans d. *)
+
+  let _test_data1 =
+    Noeud
+      ( "b",
+        2,
+        Noeud ("a", 1, Vide, Vide),
+        Noeud ("c", 3, Vide, Noeud ("d", 4, Vide, Vide)) )
+
+  let rec get : 'a t -> string -> 'a option =
+   fun d k ->
+    match d with
+    | Vide -> None
+    | Noeud (k', v', fg, fd) ->
+        if k = k' then Some v' else if k < k' then get fg k else get fd k
+  ;;
+
+  assert (Some 1 = get _test_data1 "a");;
+  assert (Some 4 = get _test_data1 "d")
+
+  (* Ajoute un couple clé/valeur dans un dictionnaire, si la clé est déjà dans le dictionnaire,
+      change en v la valeur qui sera renvoyée par get *)
+  let rec put : 'a t -> string -> 'a -> 'a t =
+   fun d k v ->
+    match d with
+    | Vide -> Noeud (k, v, Vide, Vide)
+    | Noeud (k', v', fg, fd) ->
+        if k = k' then Noeud (k, v, fg, fd)
+        else if k < k' then Noeud (k', v', put fg k v, fd)
+        else Noeud (k', v', fg, put fd k v)
+  ;;
+
+  assert (Some 5 = get (put _test_data1 "e" 5) "e");;
+  assert (Some 4 = get (put _test_data1 "e" 5) "d")
+
+  (* Le dictionnaire vide *)
+  let empty : 'a t = Vide
+
+  (* Supprime les valeurs associées à la clé k dans le dictionnaire. *)
+  let rec delete : 'a t -> string -> 'a t =
+    (* suppose k1 < k2 *)
+    let rec fusionne d1 d2 =
+      match (d1, d2) with
+      | Vide, Vide -> Vide
+      | Vide, d | d, Vide -> d
+      | Noeud (k1, v1, fg1, fd1), Noeud (k2, v2, fg2, fd2) ->
+          Noeud (k1, v1, fg1, Noeud (k2, v2, fusionne fd1 fg2, fd2))
+    in
+    fun d k ->
+      match d with
+      | Vide -> Vide
+      | Noeud (k', v', fg, fd) ->
+          if k = k' then fusionne fg fd
+          else if k < k' then Noeud (k', v', delete fg k, fd)
+          else Noeud (k', v', fg, delete fd k)
+  ;;
+
+  assert (None = get (delete _test_data1 "a") "a");;
+  assert (None = get (delete _test_data1 "d") "d");;
+  assert (Some 3 = get (delete _test_data1 "d") "c")
+
+  let rec fold : ('acc -> string -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc =
+   fun f init d ->
+    match d with
+    | Vide -> init
+    | Noeud (k, v, fg, fd) -> fold f (f (fold f init fd) k v) fg
+
+  (* on utilise fold_right pour garder l'ordre, ce qui est important
+     pour au cas où une clé est plusieurs fois dans la liste *)
+
+  let to_list : 'a t -> (string * 'a) list =
+   fun d -> fold (fun acc k v -> (k, v) :: acc) [] d
+end
+
+module Usine = struct
+  type jour = Lundi | Mardi | Mercredi | Jeudi | Vendredi | Samedi | Dimanche
+
+  let string_of_jour (j : jour) =
+    match j with
+    | Lundi -> "lundi"
+    | Mardi -> "mardi"
+    | Mercredi -> "mercredi"
+    | Jeudi -> "jeudi"
+    | Vendredi -> "vendredi"
+    | Samedi -> "samedi"
+    | Dimanche -> "dimanche"
+
+  let jours_test_data =
+    [ Lundi; Mardi; Mercredi; Jeudi; Vendredi; Samedi; Dimanche ]
+
+  let string_test_data =
+    [ "lundi"; "mardi"; "mercredi"; "jeudi"; "vendredi"; "samedi"; "dimanche" ]
+
+  let _ =
+    List.combine jours_test_data string_test_data
+    |> List.iter (fun (j, s) -> assert (s = string_of_jour j))
+
+  let jour_opt_of_string (s : string) =
+    match s with
+    | "lundi" -> Some Lundi
+    | "mardi" -> Some Mardi
+    | "mercredi" -> Some Mercredi
+    | "jeudi" -> Some Jeudi
+    | "vendredi" -> Some Vendredi
+    | "samedi" -> Some Samedi
+    | "dimanche" -> Some Dimanche
+    | _ -> None
+
+  let _ =
+    List.combine jours_test_data string_test_data
+    |> List.iter (fun (j, s) -> assert (Some j = jour_opt_of_string s))
+  ;;
+
+  assert (None = jour_opt_of_string "toto")
+
+  type configuration =
+    (string -> string option) * (string -> string -> int option)
+
+  let mk_configuration :
+      (string -> string option) ->
+      (string -> string -> int option) ->
+      configuration =
+   fun choix_jouet choix_nombre -> (choix_jouet, choix_nombre)
+
+  let get_jouet : configuration -> string -> string option = fst
+  let get_nb_jouets : configuration -> string -> string -> int option = snd
+  let toupie _lutin = Some "toupie"
+  let quanrante_deux _lutin _jouet = Some 42
+  let test_configuration = mk_configuration toupie quanrante_deux;;
+
+  assert (get_jouet test_configuration "LecheCuillere" = Some "toupie");;
+  assert (get_nb_jouets test_configuration "LecheCuillere" "toupie" = Some 42)
+
+  let jouet1 lutin =
+    match lutin with
+    | "LecheCuillere" -> Some "toupie"
+    | "Farceur" -> Some "velo"
+    | "Malin" -> Some "ballon"
+    | _ -> None
+
+  let jouet2 lutin =
+    List.assoc_opt lutin
+      [ ("LecheCuillere", "velo"); ("Farceur", "ballon"); ("Malin", "toupie") ]
+
+  let nb_jouets1 lutin _jouet =
+    List.assoc_opt lutin [ ("LecheCuillere", 1); ("Farceur", 2); ("Malin", 3) ]
+
+  let nb_jouets2 _lutin jouet =
+    List.assoc_opt jouet [ ("velo", 2); ("toupie", 10); ("ballon", 5) ]
+
+  let configuration_globale =
+    List.fold_left
+      (fun acc (k, v) -> Association.put acc k v)
+      Association.empty
+      [
+        ("lundi", mk_configuration toupie quanrante_deux);
+        ("mardi", mk_configuration jouet1 nb_jouets1);
+        ("mercredi", mk_configuration jouet2 nb_jouets1);
+        ("jeudi", mk_configuration jouet1 nb_jouets2);
+        ("vendredi", mk_configuration jouet2 nb_jouets2);
+        ("samedi", mk_configuration jouet1 quanrante_deux);
+        ("dimanche", mk_configuration jouet2 quanrante_deux);
+      ]
+
+  let config_samedi =
+    match Association.get configuration_globale "samedi" with
+    | Some c -> c
+    | None -> failwith "pas de configuration pour samedi"
+
+  let config_mardi =
+    match Association.get configuration_globale "mardi" with
+    | Some c -> c
+    | None -> failwith "pas de configuration pour mardi"
+
+  let lutins = [ "LecheCuillere"; "Farceur"; "Malin" ]
+
+  let calcule_jouets_config : configuration -> (string * int) list =
+   fun cfg ->
+    let gj = get_jouet cfg and nbj = get_nb_jouets cfg in
+    let update_jouets jouets lutin =
+      match gj lutin with
+      | None -> jouets
+      | Some jouet -> (
+          match nbj lutin jouet with
+          | None -> jouets
+          | Some nb -> (
+              match Association.get jouets jouet with
+              | None -> Association.put jouets jouet nb
+              | Some nb' -> Association.put jouets jouet (nb + nb')))
+    in
+    Association.to_list (List.fold_left update_jouets Association.empty lutins)
+  ;;
+
+  assert (
+    Some 42 = List.assoc_opt "toupie" (calcule_jouets_config config_samedi))
+  ;;
+
+  assert (Some 2 = List.assoc_opt "velo" (calcule_jouets_config config_mardi))
+end
+
+module LutinsApp = struct
+  let affiche_jouets : (string * int) list -> string =
+   fun nb_jouets_du_jour ->
+    List.fold_left
+      (fun acc (jouet, nb) ->
+        if nb = 0 then acc
+        else
+          let ligne = jouet ^ ": " ^ string_of_int nb in
+          if acc = "" then ligne else acc ^ "\n" ^ ligne)
+      "" nb_jouets_du_jour
+end
+
+let usage () = print_endline "\nUsage: ocaml tp7.ml jour"
+
+let run (args : string list) : unit =
+  match args with
+  | _pgm :: jour_s :: _ -> (
+      match Association.get Usine.configuration_globale jour_s with
+      | Some cfg ->
+          let quantites = Usine.calcule_jouets_config cfg in
+          let affichage = LutinsApp.affiche_jouets quantites in
+          print_endline ("Jouets produits: \n" ^ affichage)
+      | None -> print_endline (jour_s ^ " n'est pas un jour"))
+  | _ -> usage ()
+
+let _ = run (Array.to_list Sys.argv)