Backport of core representation from grid

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)
+ (depends ocaml dune cmdliner calendar)
  (tags
   (topics "timetable")))
 

lib/Timetable.ml

+let lex access cmp fn v1 v2 =
+  let v = fn v1 v2 in
+  if v != 0 then v else cmp (access v1) (access v2)
+
+let lex_r access cmp fn v1 v2 =
+  let v = cmp (access v1) (access v2) in
+  if v != 0 then v else 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
+
+let as_iso (d : date) : string = CalendarLib.Printer.Date.sprint "%F" d
+
+type 'a cell = { rowspan : int; colspan : int; content : 'a }
+type 'a line = { headers : string cell list; cells : 'a cell list }
+
+type 'a table = {
+  columns_headers : string cell list list;
+  lines : 'a line list;
+}
+
+module type ResourcesT = sig
+  type t
+
+  val conflicts : t -> t -> bool
+  val compare : t -> t -> int
+end
+
+module Make (R : ResourcesT) = struct
+  module D = CalendarLib.Date
+
+  type heure = int
+
+  let heure (h : int) (m : int) : heure = (h * 60) + m
+
+  type creneau = { resources : R.t; date : date; start : heure; duration : int }
+
+  let compare =
+    eq
+    |> lex (fun c -> c.date) D.compare
+    |> lex (fun c -> c.start) ( - )
+    |> lex (fun c -> c.duration) ( - )
+    |> lex (fun c -> c.resources) R.compare
+
+  let inside h h' d = h' <= h && h <= h' + d
+
+  let intersect c1 c2 =
+    c1.date = c2.date
+    && (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)
+
+  let rec supprime_conflits raise_exc c l =
+    match l with
+    | [] -> l
+    | c' :: rest ->
+        if conflict c c' then
+          if raise_exc then raise (Conflit (c, c'))
+          else supprime_conflits raise_exc c rest
+        else
+          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 : creneau list) :
+      creneau list =
+    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 -> c :: c' :: supprime_conflits raise_exc c rest
+
+  let groupby gv cmp cmp2 l =
+    let l = List.map (fun c -> (gv c, c)) l in
+    let cmp_p = eq |> lex fst cmp |> lex snd cmp2 in
+    let l = List.sort cmp_p l in
+    let rec aux = function
+      | [] -> []
+      | (v, c) :: rest -> (
+          match aux rest with
+          | [] -> [ (v, [ c ]) ]
+          | (v', cs') :: rest' ->
+              if v = v' then (v', c :: cs') :: rest'
+              else (v, [ c ]) :: (v', cs') :: rest')
+    in
+    aux l
+
+  let by_week l = groupby (fun c -> week_of_date c.date) D.compare compare l
+end

lib/dune

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

ocaml_edt.opam

@@ -14,6 +14,7 @@ depends: [
   "ocaml"
   "dune" {>= "3.16"}
   "cmdliner"
+  "calendar"
   "odoc" {with-doc}
 ]
 build: [