calendarlib + json + tests basiques

dune-project

@@ -19,7 +19,7 @@
  (name ocaml_edt)
  (synopsis "Generates timetables for course planification")
  (description "Program and library to generate a timetable for a course or a set of courses, outputs in HTML format among others")
- (depends ocaml dune cmdliner calendar yojson)
+ (depends ocaml dune cmdliner calendar yojson ounit2)
  (tags
   (topics "timetable")))
 

lib/Timetable.ml

@@ -10,10 +10,19 @@ let lex access cmp fn v1 v2 =
 let eq _ _ = 0
 (* let rec gcd n m = if m = 0 then n else gcd m (n mod m) *)
 
-type date = CalendarLib.Date.t
-type heure = int
+type date = CalendarLib.Calendar.Date.t
+type heure = CalendarLib.Calendar.Time.t
 
-let heure (h : int) (m : int) : heure = (h * 60) + m
+let date (annee : int) (mois : int) (jour : int) : date =
+  CalendarLib.Calendar.Date.make annee mois jour
+
+let heure (h : int) (m : int) : heure = CalendarLib.Calendar.Time.make h m 0
+
+let week_start_of_date d : date =
+  let open CalendarLib.Calendar.Date in
+  let day = day_of_week d in
+  let offset = 1 - int_of_day day in
+  add d (Period.day offset)
 
 (* let as_iso (d : date) : string = CalendarLib.Printer.Date.sprint "%F" d *)
 
@@ -30,36 +39,43 @@ module type ResourcesT = sig
 
   val conflicts : t -> t -> bool
   val compare : t -> t -> int
+  val title : t -> string
+  val description : t -> string
 end
 
 module Make (R : ResourcesT) = struct
-  module D = CalendarLib.Date
+  module C = CalendarLib.Calendar
+  module P = CalendarLib.Calendar.Period
+  module Pr = CalendarLib.Printer.Calendar
 
-  type creneau = { resources : R.t; date : date; start : heure; duration : int }
+  type creneau = { resources : R.t; start : C.t; duration : int }
   type creneaux = creneau list
   type week = date * creneaux
 
+  let creneau r dst tst dur =
+    { resources = r; start = C.create dst tst; duration = dur }
+
+  let resources c = c.resources
+  let starts c = c.start
+  let duration c = c.duration
+  let new_week y m d = (week_start_of_date @@ C.Date.make y m d, [])
+  let empty_creneaux = []
+
   let compare =
     eq
-    |> lex (fun c -> c.date) D.compare
-    |> lex (fun c -> c.start) ( - )
+    |> lex (fun c -> c.start) C.compare
     |> lex (fun c -> c.duration) ( - )
     |> lex (fun c -> c.resources) R.compare
 
-  let inside h h' d = h' <= h && h <= h' + d
+  (** [inside h h' d] renvoie true si h est dans l'intervalle [h', h'+d] *)
+  let inside (h : C.t) (h' : C.t) d =
+    let h'' = C.add h' (P.minute d) in
+    C.compare h' h <= 0 && C.compare h h'' <= 0
 
   let intersect c1 c2 =
-    c1.date = c2.date
-    && (inside c1.start c2.start c2.duration
-       || inside c2.start c1.start c1.duration)
+    inside c1.start c2.start c2.duration || inside c2.start c1.start c1.duration
 
   let conflict c1 c2 = intersect c1 c2 && R.conflicts c1.resources c2.resources
-  (* let date = D.make *)
-
-  let week_of_date d : date =
-    let day = D.day_of_week d in
-    let offset = 1 - D.int_of_day day in
-    D.add d (D.Period.day offset)
 
   exception Conflit of (creneau * creneau)
 
@@ -74,11 +90,12 @@ module Make (R : ResourcesT) = struct
           let l_s = supprime_conflits raise_exc c rest in
           if l_s == rest then l else l_s
 
-  let rec place (raise_exc : bool) (c : creneau) (l : creneaux) : creneaux =
+  let rec place ?(raise_exc : bool = false) (c : creneau) (l : creneaux) :
+      creneaux =
     match l with
     | [] -> [ c ]
-    | c' :: rest when conflict c c' -> place raise_exc c rest
-    | c' :: rest when compare c' c <= 0 -> c' :: place raise_exc c rest
+    | c' :: rest when conflict c c' -> place ~raise_exc c rest
+    | c' :: rest when compare c' c <= 0 -> c' :: place ~raise_exc c rest
     | c' :: rest -> c :: c' :: supprime_conflits raise_exc c rest
 
   let groupby gv cmp cmp2 l =
@@ -96,10 +113,74 @@ module Make (R : ResourcesT) = struct
     in
     aux l
 
-  let by_week l = groupby (fun c -> week_of_date c.date) D.compare compare l
-  let week_start : week -> date = fst
+  let by_week l =
+    groupby
+      (fun c -> week_start_of_date (C.to_date c.start))
+      C.Date.compare compare l
 
-  let to_fullcalendar (_cr : (date * creneau list) list) : Yojson.Safe.t =
-    (* let open Yojson.Safe in *)
-    `Null
+  let week_start : week -> date = fst
+  let ends c = C.add c.start (P.minute c.duration)
+
+  let to_fullcalendar (weeks : (date * creneau list) list) : Yojson.Basic.t =
+    let eid = ref 0 in
+    let creneau_to_event c =
+      let id = !eid in
+      eid := !eid + 1;
+      `Assoc
+        [
+          ("id", `String ("evt" ^ string_of_int id));
+          ("title", `String (R.title c.resources));
+          ("start", `String (Pr.sprint "%FT%T" c.start));
+          ("end", `String (Pr.sprint "%FT%T" (ends c)));
+        ]
+    in
+    `List
+      (List.map (fun (_, crl) -> List.map creneau_to_event crl) weeks
+      |> List.flatten)
+
+  let write_fullcalendar ?(prefix = "") ?(suffix = "") (weeks : week list)
+      (filename : string) =
+    let ch = open_out filename in
+    output_string ch prefix;
+    to_fullcalendar weeks |> Yojson.Basic.pretty_to_channel ch;
+    output_string ch suffix;
+    close_out_noerr ch
+
+  let simple_page weeks filename =
+    let tpl =
+      {|
+<!DOCTYPE html>
+<html lang='en'>
+  <head>
+    <meta charset='utf-8' />
+    <script src='https://cdn.jsdelivr.net/npm/fullcalendar@6.1.15/index.global.min.js'></script>
+    <script>
+
+      document.addEventListener('DOMContentLoaded', function() {
+        var data = $$DATA$$;
+        var calendarEl = document.getElementById('calendar');
+        var calendar = new FullCalendar.Calendar(calendarEl, {
+          initialView: 'timeGridWeek',
+          events: data
+        });
+        calendar.render();
+      });
+
+    </script>
+  </head>
+  <body>
+    <div id='calendar'></div>
+  </body>
+</html>
+      |}
+    in
+    let output =
+      Str.global_replace
+        (Str.regexp_string "$$DATA$$")
+        (to_fullcalendar weeks |> Yojson.Basic.to_string)
+        tpl
+    in
+    let ch = open_out filename in
+    output_string ch output;
+    close_out_noerr ch
 end

lib/Timetable.mli

-type date = CalendarLib.Date.t
+type date
 type heure
 
+val date : int -> int -> int -> date
 val heure : int -> int -> heure
 
 module type ResourcesT = sig
@@ -8,11 +9,25 @@ module type ResourcesT = sig
 
   val conflicts : t -> t -> bool
   val compare : t -> t -> int
+  val title : t -> string
+  val description : t -> string
 end
 
 module Make (R : ResourcesT) : sig
-  type creneau = { resources : R.t; date : date; start : heure; duration : int }
+  type creneau
   (** Type pour représenter un créneau associé à des ressources *)
+    
+  val creneau: R.t -> date -> heure -> int -> creneau
+  (** Créée un nouveau créneau *)
+
+  val resources : creneau -> R.t
+  (** ressources associées à un créneau *)
+
+  val starts : creneau -> CalendarLib.Calendar.t
+  (** heure de début du créneau *)
+
+  val duration : creneau -> int
+  (** heure de fin du créneau *)
 
   type creneaux
   (** Représente un ensemble de créneaux *)
@@ -20,10 +35,17 @@ module Make (R : ResourcesT) : sig
   type week
   (** Représente une semaine *)
 
+  val new_week : int -> int -> int -> week
+  (** [new_week y m d] crée une nouvelle semaine contenant le jour passé en
+    argument sous la forme [y-m-d] (année, mois, jour)*)
+
   exception Conflit of (creneau * creneau)
   (** Conflit de créneaux *)
 
-  val place : bool -> creneau -> creneaux -> creneaux
+val empty_creneaux: creneaux
+(** ensemble de créneaux vides *)
+
+  val place : ?raise_exc:bool -> creneau -> creneaux -> creneaux
   (** [place b cr crl] ajoute le créneau [cr] à la liste des créneaux [crl] si
         ce créneau rentre en conflit avec un créneau dans [crl], alors si [b]
         vaut [true] une exception [Conflit] est levée. Si [b] vaut [false], alors
@@ -37,7 +59,18 @@ module Make (R : ResourcesT) : sig
   val week_start : week -> date
   (** date du premier jour de la semaine *)
 
-  val to_fullcalendar : week list -> Yojson.Safe.t
+  val to_fullcalendar : week list -> Yojson.Basic.t
   (** convertit un ensemble de semaines en structure json utilisable comme
     donnée pour le composant javascript FullCalendar *)
+
+  val write_fullcalendar :
+    ?prefix:string -> ?suffix:string -> week list -> string -> unit
+  (** [write_fullcalendar weeks filename]
+    convertit une liste de semaines [weeks] en json et l'écrit dans le fichier nommé [filename].
+    [?prefix] est écrit avant le json dans le fichier
+    [?suffix] est écrit après le json dans le fichier *)
+
+  val simple_page : week list -> string -> unit
+  (** [simple_page weeks filename] écrit une page HTML simple permettant de
+    visualiser les événements compris dans weeks *)
 end

lib/dune

 (library
  (name ocaml_edt)
- (libraries calendar yojson))
+ (libraries calendar yojson str ))

ocaml_edt.opam

@@ -16,6 +16,7 @@ depends: [
   "cmdliner"
   "calendar"
   "yojson"
+  "ounit2"
   "odoc" {with-doc}
 ]
 build: [

test/dune

 (test
- (name test_ocaml_edt))
+ (name test_ocaml_edt)
+ (libraries ocaml_edt ounit2))

test/test_ocaml_edt.ml

@@ -15,4 +15,31 @@ PARTICULAR PURPOSE. See the GNU General Public License for more details.
 You should have received a copy of the GNU General Public License along with
 OCamlEDT. If not, see <https://www.gnu.org/licenses/>.
 
-*)
\ No newline at end of file
+*)
+open OUnit2
+open Ocaml_edt.Timetable
+
+module StringResource = struct
+  type t = string
+
+  let conflicts _s1 _s2 = true
+  let compare = String.compare
+  let title s = s
+  let description s = s
+end
+
+module TT = Make (StringResource)
+open TT
+
+let creneaux =
+  empty_creneaux
+  |> place (creneau "a" (date 2024 09 10) (heure 8 0) 90)
+  |> place (creneau "b" (date 2024 09 10) (heure 14 0) 195)
+  |> place (creneau "c" (date 2024 09 11) (heure 8 0) 90)
+
+let test_write_html _ = simple_page (by_week creneaux) "test.html"
+
+let suite =
+  "Ocaml_edt test suite" >::: [ "test_write_html" >:: test_write_html ]
+
+let () = run_test_tt_main suite