diff --git a/dune-project b/dune-project
index e218c82e2dc2e8bbdd4b893bc8b179a6a961a144..9d9b51a47c0eb2f9629e163d5a3389a260c3c860 100644
--- a/dune-project
+++ b/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")))
diff --git a/lib/Timetable.ml b/lib/Timetable.ml
index 933a6a8199165811a446140ea9497eeda5f13bee..da9cca46bf60c6eba62dda2b8ff08920b1e32c3a 100644
--- a/lib/Timetable.ml
+++ b/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
diff --git a/lib/Timetable.mli b/lib/Timetable.mli
index 71d813fe75a27bb93b391de912f1612f8a48026e..399292ad7a6104fba43bf555c08af5fe1e5bd80a 100644
--- a/lib/Timetable.mli
+++ b/lib/Timetable.mli
@@ -1,6 +1,7 @@
-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
diff --git a/lib/dune b/lib/dune
index 7f777ba982e2ee5eca969486a769d6a6be10f622..336a7c92a03291f38f2e0c15a45cc05e6ef1ac77 100644
--- a/lib/dune
+++ b/lib/dune
@@ -1,3 +1,3 @@
(library
(name ocaml_edt)
- (libraries calendar yojson))
+ (libraries calendar yojson str ))
diff --git a/ocaml_edt.opam b/ocaml_edt.opam
index f4add2348a8b83f0f8679caa3935a2d1424f2fa0..7c95af65f0f1f8a3b5cb7a70f1c4d27017b225bd 100644
--- a/ocaml_edt.opam
+++ b/ocaml_edt.opam
@@ -16,6 +16,7 @@ depends: [
"cmdliner"
"calendar"
"yojson"
+ "ounit2"
"odoc" {with-doc}
]
build: [
diff --git a/test/dune b/test/dune
index fb23c18a4ad38c137fdc33637d9d4556109de418..b3379c950351bc986c0d3b35349752b7c726c034 100644
--- a/test/dune
+++ b/test/dune
@@ -1,2 +1,3 @@
(test
- (name test_ocaml_edt))
+ (name test_ocaml_edt)
+ (libraries ocaml_edt ounit2))
diff --git a/test/test_ocaml_edt.ml b/test/test_ocaml_edt.ml
index 957f8c4064bce2b8257a4fc66509932029409543..4c1097a410431700e2309f2345858b86d954a6dc 100644
--- a/test/test_ocaml_edt.ml
+++ b/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