Skip to content
dk docs

Interactive Apps

Context

Section titled “Context”

This guide is a live demo of an Elm-style OCaml app compiled to JavaScript and rendering into a web terminal. This guide is for advanced users who want to build their own interactive web applications using dk-based tooling.

The two cells on this page define the Elm-style app; editing and re-running them changes what the terminal (the third cell) shows. The terminal is a ghostty-web VT100 emulator.

1. The Samples module

Section titled “1. The Samples module”

This cell defines the Canadian Cabinet data and the animation loop used to drive the app. It can be edited (just expand the Command).

Command — 1187 lines (click to expand)
module Samples = struct
  open MlFront_Progress


(** Reusable progress reporting sample data and drivers.


    These are shared by demos and tests (for example the DkZero_RuntimeC
    SyntheticDemo test and the DkZero_Web browser terminal) so most of the
    progress tree animation lives in one place. *)


(** A synthetic "Canadian Cabinet" hierarchy (sovereign -> governor general /
    prime minister -> ministers -> deputy ministers) animated month by month
    over a {!MlFront_Progress.Progress} tree.


    The driver is backend- and pacing-agnostic: {!run} mutates the supplied root
    node's subtree once per simulated month and then calls [tick], leaving the
    caller to flush, sleep, or capture a frame. *)
module CanadianCabinet = struct
  (* ===================================================================== *)
  (* Data                                                                  *)
  (* ===================================================================== *)


  type 'a title =
    | Queen : [ `Sovereign ] title
    | King : [ `Sovereign ] title
    | GovernorGeneral : [ `First ] title
    | PrimeMinister : [ `First ] title
    | DeputyPrimeMinister : [ `Second ] title
    | MinisterOfFinance : [ `Second ] title
    | MinisterOfForeignAffairs : [ `Second ] title
    | DeputyMinisterOfFinance : [ `Third ] title
    | DeputyMinisterOfForeignAffairs : [ `Third ] title


  let rank_title : type a. a title -> int = function
    | Queen -> 1
    | King -> 2
    | GovernorGeneral -> 3
    | PrimeMinister -> 4
    | DeputyPrimeMinister -> 5
    | MinisterOfFinance -> 6
    | MinisterOfForeignAffairs -> 7
    | DeputyMinisterOfFinance -> 8
    | DeputyMinisterOfForeignAffairs -> 9


  let show_title : type a. a title -> string = function
    | King -> "King"
    | Queen -> "Queen"
    | GovernorGeneral -> "Governor General"
    | PrimeMinister -> "Prime Minister"
    | DeputyPrimeMinister -> "Deputy Prime Minister"
    | MinisterOfFinance -> "Finance Minister"
    | MinisterOfForeignAffairs -> "Foreign Affairs Minister"
    | DeputyMinisterOfFinance -> "Deputy Finance Minister"
    | DeputyMinisterOfForeignAffairs -> "Deputy Foreign Affairs Minister"


  let _ = compare
  let compare_title a b = compare (rank_title a) (rank_title b)
  let _ = compare_title


  type hierarchy =
    [ `Sovereign ] title option
    * [ `First ] title option
    * [ `Second ] title option
    * [ `Third ] title option


  let show_hierarchy (s, l1, l2, l3) =
    let show' n = function
      | None -> ""
      | Some t ->
          let prefix = if n > 1 then " -> " else "" in
          prefix ^ show_title t
    in
    Printf.sprintf "%s%s%s%s" (show' 1 s) (show' 2 l1) (show' 3 l2) (show' 4 l3)


  let is_sovereign = function
    | Some (King | Queen), None, None, None -> true
    | _ -> false


  let rank_hierarchy_max = 4


  let rank_hierarchy = function
    | Some _, Some _, Some _, Some _ -> (4, `Third)
    | Some _, Some _, Some _, _ -> (3, `Second)
    | Some _, Some _, _, _ -> (2, `First)
    | Some _, _, _, _ -> (1, `Sovereign)
    | _, _, _, _ -> (0, `None)


  let title_hierarchy = function
    | Some s, None, None, None -> [ rank_title s ]
    | Some s, Some l1, None, None -> [ rank_title s; rank_title l1 ]
    | Some s, Some l1, Some l2, None ->
        [ rank_title s; rank_title l1; rank_title l2 ]
    | Some s, Some l1, Some l2, Some l3 ->
        [ rank_title s; rank_title l1; rank_title l2; rank_title l3 ]
    | None, None, None, None -> []
    | a_s, a_1, a_2, a_3 ->
        Printf.eprintf "non-contiguous hierarchy: %s\n"
          (show_hierarchy (a_s, a_1, a_2, a_3));
        assert false


  let compare_hierarchy a b =
    let a' = title_hierarchy a in
    let b' = title_hierarchy b in
    List.compare Int.compare a' b'


  let parent_hierarchy = function
    | Some s, Some l1, Some l2, Some _l3 -> (Some s, Some l1, Some l2, None)
    | Some s, Some l1, Some _l2, None -> (Some s, Some l1, None, None)
    | Some s, Some _l1, None, None -> (Some s, None, None, None)
    | Some _s, None, None, None -> (None, None, None, None)
    | _, _, _, _ -> (None, None, None, None)


  type service = Service : { title : 'a title } -> service


  type t = {
    name : string;
    service : service;
    startyymm : int * int;
    endyymm : int * int;
    hierarchy : hierarchy;
  }


  (** Functions and structures to provide a search structure for the raw data.
  *)
  module Denorm = struct
    type nonrec normalized = t
    type serving = { monthno : int; totalmonths : int }


    type t = {
      dname : string;
      dtitle : string;
      dyymm : int * int;
      dstate : [ `EaseIn of int | `Serving of serving | `EaseOut of int ];
      dhierarchy : hierarchy;
      dmons : int;
    }
    (** A time-varying denormalized record. EaseIn and EaseOut are the number of
        months remaining and since serving, respectively. *)


    (** This is a search structure ["SELECT * FROM denorm WHERE dyymm = ?"]. *)
    module YymmMap = Map.Make (struct
      type t = int * int


      let compare = compare
    end)


    (* A verified assumption that the hierarchy is sorted with the sovereign first *)
    let assume_sorted_by_hierarchy_with_soverign_first () =
      let innercmp = compare_hierarchy in
      let cmp = fun a b -> innercmp a.dhierarchy b.dhierarchy in
      (* test the [innercmp] *)
      let a = (Some King, None, None, None) in
      let b = (Some Queen, None, None, None) in
      let c = (Some Queen, Some GovernorGeneral, None, None) in
      let d =
        ( Some Queen,
          Some PrimeMinister,
          Some MinisterOfFinance,
          Some DeputyMinisterOfFinance )
      in
      let e =
        (Some Queen, Some PrimeMinister, Some DeputyPrimeMinister, None)
      in
      let testdata = [ a; b; c; d; e ] in
      let sorted = List.sort innercmp testdata in
      let expected = [ b; c; e; d; a ] in
      if sorted <> expected then (
        List.iter
          (fun h -> Printf.eprintf "unverified: %s\n" (show_hierarchy h))
          sorted;
        assert false);
      (`SamplesVerified, cmp)


    let clamplo ~min x = if x < min then min else x
    let clamphi ~max x = if x > max then max else x
    let tomon (yy, mm) = (yy * 12) + mm
    let toyymm mon = ((mon - 1) / 12, 1 + ((mon - 1) mod 12))


    let denormalize ~easing_months ~firstyymm ~lastyymm (orig : normalized list)
        : t list YymmMap.t =
      let firstmon = tomon firstyymm in
      let lastmon = tomon lastyymm in
      let denormed_records : t list =
        List.concat_map
          (fun {
                 name;
                 service = Service { title };
                 startyymm;
                 endyymm;
                 hierarchy;
               } ->
            let startmon = clamplo ~min:firstmon (tomon startyymm) in
            let endmon = clamphi ~max:lastmon (tomon endyymm) in
            let easemon1 = clamplo ~min:(startmon - easing_months) startmon in
            let easemon2 = clamphi ~max:(endmon + easing_months) endmon in
            let easedurmon = 1 + easemon2 - easemon1 in
            let rec aux curmon acc =
              if curmon > endmon + easing_months then List.rev acc
              else
                let current_yymm = toyymm curmon in
                let state =
                  if curmon < startmon then `EaseIn (startmon - curmon)
                  else if curmon > endmon then `EaseOut (curmon - endmon)
                  else
                    `Serving
                      {
                        monthno = curmon - startmon + 1;
                        totalmonths = easedurmon;
                      }
                in
                aux (curmon + 1)
                  ({
                     dname = name;
                     dtitle = show_title title;
                     dyymm = current_yymm;
                     dstate = state;
                     dhierarchy = hierarchy;
                     dmons = easedurmon;
                   }
                  :: acc)
            in
            aux (startmon - easing_months) [])
          orig
      in
      (* Must be sorted by hierarchy for a sane display *)
      let denormed_records =
        let _, cmp = assume_sorted_by_hierarchy_with_soverign_first () in
        List.sort cmp denormed_records
      in


      (* Partition [t list] into YymmMap map of dyymm -> t.
         Maintain correct order with fold_right. *)
      List.fold_right
        (fun record m ->
          YymmMap.update record.dyymm
            (function
              | None -> Some [ record ]
              | Some records -> Some (record :: records))
            m)
        denormed_records YymmMap.empty
  end


  let data : t list =
    (*
      Harness: GitHub Copilot v1.0.40
      LLM: GPT 5.4 mini


      Caution:
        The periods of service may overlap! Perhaps change the prompt to
        avoid the overlap, which messes with the counters.


      Prompt:
        Populate the `data` with a list of Canadian government
        officials from 1975 - 2025. If someone has discontinuous period of time serving
        in the Cabinet, make separate records.
        The King and Queen have hierarchy `` (Some King, None, None, ...) `` and ``
        (Some Queen, None, None, ...) ``, respectively. The Governor General and Prime
        Minister are under the King and Queen; if they served under Queen Elizabeth it
        would be `` (Some Queen, Some GovernorGeneral, None, ...) `` and
        `` (Some Queen, Some PrimeMinister, None, ...) ``.


        Include all levels down to deputy ministers.


        Keep the comment you see containing the "Prompt".
      *)
    [
      {
        name = "Queen Elizabeth II";
        service = Service { title = Queen };
        startyymm = (1975, 1);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, None, None, None);
      };
      {
        name = "King Charles III";
        service = Service { title = King };
        startyymm = (2022, 9);
        endyymm = (2025, 12);
        hierarchy = (Some King, None, None, None);
      };
      {
        name = "Jules Leger";
        service = Service { title = GovernorGeneral };
        startyymm = (1975, 1);
        endyymm = (1979, 1);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Edward Schreyer";
        service = Service { title = GovernorGeneral };
        startyymm = (1979, 1);
        endyymm = (1984, 6);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Jeanne Sauve";
        service = Service { title = GovernorGeneral };
        startyymm = (1984, 6);
        endyymm = (1990, 1);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Ray Hnatyshyn";
        service = Service { title = GovernorGeneral };
        startyymm = (1990, 1);
        endyymm = (1995, 2);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Romeo LeBlanc";
        service = Service { title = GovernorGeneral };
        startyymm = (1995, 2);
        endyymm = (1999, 1);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Adrienne Clarkson";
        service = Service { title = GovernorGeneral };
        startyymm = (1999, 1);
        endyymm = (2005, 9);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Michaelle Jean";
        service = Service { title = GovernorGeneral };
        startyymm = (2005, 9);
        endyymm = (2010, 10);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "David Johnston";
        service = Service { title = GovernorGeneral };
        startyymm = (2010, 10);
        endyymm = (2017, 10);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Julie Payette";
        service = Service { title = GovernorGeneral };
        startyymm = (2017, 10);
        endyymm = (2021, 7);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Mary Simon";
        service = Service { title = GovernorGeneral };
        startyymm = (2021, 7);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, Some GovernorGeneral, None, None);
      };
      {
        name = "Mary Simon";
        service = Service { title = GovernorGeneral };
        startyymm = (2022, 9);
        endyymm = (2025, 12);
        hierarchy = (Some King, Some GovernorGeneral, None, None);
      };
      {
        name = "Pierre Trudeau";
        service = Service { title = PrimeMinister };
        startyymm = (1975, 1);
        endyymm = (1979, 3);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Joe Clark";
        service = Service { title = PrimeMinister };
        startyymm = (1979, 6);
        endyymm = (1980, 3);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Pierre Trudeau";
        service = Service { title = PrimeMinister };
        startyymm = (1980, 3);
        endyymm = (1984, 6);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "John Turner";
        service = Service { title = PrimeMinister };
        startyymm = (1984, 6);
        endyymm = (1984, 9);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Brian Mulroney";
        service = Service { title = PrimeMinister };
        startyymm = (1984, 9);
        endyymm = (1993, 6);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Kim Campbell";
        service = Service { title = PrimeMinister };
        startyymm = (1993, 6);
        endyymm = (1993, 11);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Jean Chretien";
        service = Service { title = PrimeMinister };
        startyymm = (1993, 11);
        endyymm = (2003, 12);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Paul Martin";
        service = Service { title = PrimeMinister };
        startyymm = (2003, 12);
        endyymm = (2006, 2);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Stephen Harper";
        service = Service { title = PrimeMinister };
        startyymm = (2006, 2);
        endyymm = (2015, 11);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Justin Trudeau";
        service = Service { title = PrimeMinister };
        startyymm = (2015, 11);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, Some PrimeMinister, None, None);
      };
      {
        name = "Justin Trudeau";
        service = Service { title = PrimeMinister };
        startyymm = (2022, 9);
        endyymm = (2025, 12);
        hierarchy = (Some King, Some PrimeMinister, None, None);
      };
      {
        name = "Allan MacEachen";
        service = Service { title = DeputyPrimeMinister };
        startyymm = (1977, 8);
        endyymm = (1979, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some DeputyPrimeMinister, None);
      };
      {
        name = "Erik Nielsen";
        service = Service { title = DeputyPrimeMinister };
        startyymm = (1984, 9);
        endyymm = (1986, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some DeputyPrimeMinister, None);
      };
      {
        name = "Don Mazankowski";
        service = Service { title = DeputyPrimeMinister };
        startyymm = (1993, 1);
        endyymm = (1997, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some DeputyPrimeMinister, None);
      };
      {
        name = "Herb Gray";
        service = Service { title = DeputyPrimeMinister };
        startyymm = (1997, 6);
        endyymm = (2002, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some DeputyPrimeMinister, None);
      };
      {
        name = "Anne McLellan";
        service = Service { title = DeputyPrimeMinister };
        startyymm = (2006, 1);
        endyymm = (2007, 8);
        hierarchy = (Some Queen, Some PrimeMinister, Some DeputyPrimeMinister, None);
      };
      {
        name = "Chrystia Freeland";
        service = Service { title = DeputyPrimeMinister };
        startyymm = (2019, 11);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some DeputyPrimeMinister, None);
      };
      {
        name = "Chrystia Freeland";
        service = Service { title = DeputyPrimeMinister };
        startyymm = (2022, 9);
        endyymm = (2024, 12);
        hierarchy = (Some King, Some PrimeMinister, Some DeputyPrimeMinister, None);
      };
      {
        name = "Donald Macdonald";
        service = Service { title = MinisterOfFinance };
        startyymm = (1975, 1);
        endyymm = (1976, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Jean Chretien";
        service = Service { title = MinisterOfFinance };
        startyymm = (1976, 9);
        endyymm = (1979, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "John Crosbie";
        service = Service { title = MinisterOfFinance };
        startyymm = (1979, 6);
        endyymm = (1980, 3);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Allan MacEachen";
        service = Service { title = MinisterOfFinance };
        startyymm = (1980, 3);
        endyymm = (1984, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Michael Wilson";
        service = Service { title = MinisterOfFinance };
        startyymm = (1984, 9);
        endyymm = (1991, 4);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Don Mazankowski";
        service = Service { title = MinisterOfFinance };
        startyymm = (1991, 4);
        endyymm = (1993, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Paul Martin";
        service = Service { title = MinisterOfFinance };
        startyymm = (1993, 1);
        endyymm = (2002, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "John Manley";
        service = Service { title = MinisterOfFinance };
        startyymm = (2002, 6);
        endyymm = (2003, 12);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Ralph Goodale";
        service = Service { title = MinisterOfFinance };
        startyymm = (2003, 12);
        endyymm = (2006, 2);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Jim Flaherty";
        service = Service { title = MinisterOfFinance };
        startyymm = (2006, 2);
        endyymm = (2014, 3);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Joe Oliver";
        service = Service { title = MinisterOfFinance };
        startyymm = (2014, 3);
        endyymm = (2015, 11);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Bill Morneau";
        service = Service { title = MinisterOfFinance };
        startyymm = (2015, 11);
        endyymm = (2020, 8);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Chrystia Freeland";
        service = Service { title = MinisterOfFinance };
        startyymm = (2020, 8);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Chrystia Freeland";
        service = Service { title = MinisterOfFinance };
        startyymm = (2022, 9);
        endyymm = (2024, 12);
        hierarchy = (Some King, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Dominic LeBlanc";
        service = Service { title = MinisterOfFinance };
        startyymm = (2024, 12);
        endyymm = (2025, 12);
        hierarchy = (Some King, Some PrimeMinister, Some MinisterOfFinance, None);
      };
      {
        name = "Allan MacEachen";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1975, 1);
        endyymm = (1976, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Donald Jamieson";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1976, 9);
        endyymm = (1979, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Flora MacDonald";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1979, 6);
        endyymm = (1980, 3);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Mark MacGuigan";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1980, 3);
        endyymm = (1982, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Jean Chretien";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1982, 9);
        endyymm = (1984, 6);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Joe Clark";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1984, 9);
        endyymm = (1991, 4);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Barbara McDougall";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1991, 4);
        endyymm = (1993, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Andre Ouellet";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1993, 1);
        endyymm = (1994, 11);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Lloyd Axworthy";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (1996, 1);
        endyymm = (2000, 10);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "John Manley";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2000, 10);
        endyymm = (2002, 5);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Bill Graham";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2002, 5);
        endyymm = (2004, 7);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Pierre Pettigrew";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2004, 7);
        endyymm = (2006, 2);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Peter MacKay";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2006, 2);
        endyymm = (2007, 8);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Maxime Bernier";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2007, 8);
        endyymm = (2008, 5);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Lawrence Cannon";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2008, 5);
        endyymm = (2011, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "John Baird";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2011, 1);
        endyymm = (2015, 11);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Stephane Dion";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2015, 11);
        endyymm = (2017, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Chrystia Freeland";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2017, 1);
        endyymm = (2019, 11);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Francois-Philippe Champagne";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2019, 11);
        endyymm = (2021, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Marc Garneau";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2021, 1);
        endyymm = (2021, 10);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Melanie Joly";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2021, 10);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Melanie Joly";
        service = Service { title = MinisterOfForeignAffairs };
        startyymm = (2022, 9);
        endyymm = (2025, 12);
        hierarchy = (Some King, Some PrimeMinister, Some MinisterOfForeignAffairs, None);
      };
      {
        name = "Peter Harder";
        service = Service { title = DeputyMinisterOfForeignAffairs };
        startyymm = (2007, 1);
        endyymm = (2010, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, Some DeputyMinisterOfForeignAffairs);
      };
      {
        name = "Morris Rosenberg";
        service = Service { title = DeputyMinisterOfForeignAffairs };
        startyymm = (2010, 1);
        endyymm = (2013, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, Some DeputyMinisterOfForeignAffairs);
      };
      {
        name = "Marta Morgan";
        service = Service { title = DeputyMinisterOfForeignAffairs };
        startyymm = (2016, 1);
        endyymm = (2020, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, Some DeputyMinisterOfForeignAffairs);
      };
      {
        name = "David Morrison";
        service = Service { title = DeputyMinisterOfForeignAffairs };
        startyymm = (2020, 1);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfForeignAffairs, Some DeputyMinisterOfForeignAffairs);
      };
      {
        name = "David Morrison";
        service = Service { title = DeputyMinisterOfForeignAffairs };
        startyymm = (2022, 9);
        endyymm = (2025, 12);
        hierarchy = (Some King, Some PrimeMinister, Some MinisterOfForeignAffairs, Some DeputyMinisterOfForeignAffairs);
      };
      {
        name = "Michael Horgan";
        service = Service { title = DeputyMinisterOfFinance };
        startyymm = (2009, 1);
        endyymm = (2014, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, Some DeputyMinisterOfFinance);
      };
      {
        name = "Paul Rochon";
        service = Service { title = DeputyMinisterOfFinance };
        startyymm = (2014, 1);
        endyymm = (2020, 1);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, Some DeputyMinisterOfFinance);
      };
      {
        name = "Chris Forbes";
        service = Service { title = DeputyMinisterOfFinance };
        startyymm = (2020, 1);
        endyymm = (2022, 9);
        hierarchy = (Some Queen, Some PrimeMinister, Some MinisterOfFinance, Some DeputyMinisterOfFinance);
      };
      {
        name = "Chris Forbes";
        service = Service { title = DeputyMinisterOfFinance };
        startyymm = (2022, 9);
        endyymm = (2025, 12);
        hierarchy = (Some King, Some PrimeMinister, Some MinisterOfFinance, Some DeputyMinisterOfFinance);
      };
    ] [@@ocamlformat "disable"]


  (* ===================================================================== *)
  (* Data accessors                                                        *)
  (* ===================================================================== *)


  let firstyymm = (1975, 1)
  let lastyymm = (2025, 12)
  let base_root_name = "Canadian Cabinet"
  let nextmon (yy, mm) = if mm = 12 then (yy + 1, 1) else (yy, mm + 1)


  (** Number of inclusive months between two [(year, month)] points. *)
  let months_in_range (startyy, startmm) (endyy, endmm) =
    ((endyy - startyy) * 12) + (endmm - startmm) + 1


  let totalmonths = months_in_range firstyymm lastyymm


  let monthname : int -> string = function
    | 1 -> "January"
    | 2 -> "February"
    | 3 -> "March"
    | 4 -> "April"
    | 5 -> "May"
    | 6 -> "June"
    | 7 -> "July"
    | 8 -> "August"
    | 9 -> "September"
    | 10 -> "October"
    | 11 -> "November"
    | 12 -> "December"
    | _ -> invalid_arg "Invalid month number"


  (** Root node label for a given month, e.g. ["Canadian Cabinet 1975 Jan"]. *)
  let rootnode_name (curyy, curmm) =
    Printf.sprintf "%s %04d %s" base_root_name curyy
      (String.sub (monthname curmm) 0 3)


  (* ===================================================================== *)
  (* Driver                                                                *)
  (* ===================================================================== *)


  type progress_phase = EaseIn | Serving | EaseOut
  type hierarchy_key = { hk_hierarchy : hierarchy; hk_name : string }


  type nodestate = {
    node : Progress.nodeobj;
    objid : [ `Object of int ];
    mutable phase : progress_phase;
  }


  let phase_of_dstate :
      [ `EaseIn of int | `Serving of Denorm.serving | `EaseOut of int ] ->
      progress_phase = function
    | `EaseIn _ -> EaseIn
    | `Serving _ -> Serving
    | `EaseOut _ -> EaseOut


  let phase_priority = function Serving -> 0 | EaseIn -> 1 | EaseOut -> 2


  let hierarchy_key ~dhierarchy ~dname =
    { hk_hierarchy = dhierarchy; hk_name = dname }


  (* Does [needle] occur anywhere in [haystack]? (Replaces Stringext.find_from
     so this module has no extra dependencies.) *)
  let contains_substring ~needle haystack =
    let nl = String.length needle and hl = String.length haystack in
    if nl = 0 then true
    else
      let rec scan i =
        if i + nl > hl then false
        else if String.sub haystack i nl = needle then true
        else scan (i + 1)
      in
      scan 0


  (** [end_without_parent_progress ?parent node] ends a node without updating
      its parent's progress. We set parent counters (months in service)
      independent of the children. *)
  let end_without_parent_progress ?parent node =
    let parent_completed = Option.map Progress.completed_items parent in
    Progress.end_ node;
    match (parent, parent_completed) with
    | Some parent, Some completed ->
        Progress.set_completed_items parent completed
    | _ -> ()


  let parent_node ~rootnodestate nodestates dhierarchy =
    if is_sovereign dhierarchy then Some rootnodestate.node
    else
      let parent = parent_hierarchy dhierarchy in
      let best_parent =
        Hashtbl.fold
          (fun { hk_hierarchy = candidate_hierarchy; hk_name = _ }
               candidate_state acc ->
            if compare_hierarchy candidate_hierarchy parent = 0 then
              match acc with
              | None -> Some candidate_state
              | Some best_state ->
                  if
                    phase_priority candidate_state.phase
                    < phase_priority best_state.phase
                  then Some candidate_state
                  else acc
            else acc)
          nodestates None
      in
      Option.map (fun { node; _ } -> node) best_parent


  (** [set_service_progress node ~dstate ~dmons] sets the progress of a node. We
      avoid the default auto-incrementing because it is ugly with our 3-phase
      nodes. *)
  let set_service_progress node
      ~(dstate :
         [ `EaseIn of int | `Serving of Denorm.serving | `EaseOut of int ])
      ~dmons =
    let completed_items =
      match dstate with
      | `EaseIn _ -> 0
      | `Serving { monthno; totalmonths = _ } -> monthno
      | `EaseOut _ -> dmons
    in
    Progress.set_estimated_total_items node dmons;
    Progress.set_completed_items node completed_items


  (** find the parent node. it should exist because of the assumption ... unless
      the person is missing an immediate leader (which happens in politics).
      simplistic: if missing a leader we say the person does not exist *)
  let get_parent_node ~rootnodestate
      (nodestates : (hierarchy_key, nodestate) Hashtbl.t) dhierarchy =
    let `SamplesVerified, _ =
      Denorm.assume_sorted_by_hierarchy_with_soverign_first ()
    in
    if is_sovereign dhierarchy then Some rootnodestate
    else
      let parent = parent_hierarchy dhierarchy in
      let best_parent =
        Hashtbl.fold
          (fun { hk_hierarchy = candidate_hierarchy; hk_name = _ }
               candidate_state acc ->
            if compare_hierarchy candidate_hierarchy parent = 0 then
              match acc with
              | None -> Some candidate_state
              | Some best_state ->
                  if
                    phase_priority candidate_state.phase
                    < phase_priority best_state.phase
                  then Some candidate_state
                  else acc
            else acc)
          nodestates None
      in
      best_parent


  (** maintain the tree hierarchy for this month *)
  let do_yymm ~trace ~next_objid ~rootnodestate nodestates
      (monthdata : Denorm.t list) =
    let open Progress in
    (* we'll garbage collect later, so we need the live set *)
    let live = Hashtbl.create 16 in


    (* add nodes / update nodes *)
    let rec aux : Denorm.t list -> unit = function
      | [] -> ()
      | { dname; dtitle; dyymm = _; dstate; dhierarchy; dmons } :: rest ->
          let state_phase = phase_of_dstate dstate in
          let nodekey = hierarchy_key ~dhierarchy ~dname in
          (* create the node name; check if easing in or out *)
          let nodename =
            match dstate with
            | `Serving { monthno = _; totalmonths = _ } ->
                Printf.sprintf "%s|%s" dname dtitle
            | `EaseIn mon -> String.make mon ' ' ^ "<- " ^ dname
            | `EaseOut mon -> String.make mon ' ' ^ "-> " ^ dname
          in
          begin
            (*  cleanup:
                  if [dhierarchy] already present but name has changed,
                  remove the node first, then proceed as if not present.
              *)
            match Hashtbl.find_opt nodestates nodekey with
            | Some { node; objid; _ } ->
                let foundname = Option.value ~default:"" (name node) in
                if not (contains_substring ~needle:dname foundname) then begin
                  (* name changed *)
                  let parent =
                    parent_node ~rootnodestate nodestates dhierarchy
                  in
                  if trace then
                    Printf.eprintf
                      "Name change detected from %s to %s. Cleaning up old \
                       node...\n\
                       %!"
                      foundname dname;
                  end_without_parent_progress ?parent node;
                  Hashtbl.remove nodestates nodekey;
                  Hashtbl.remove live objid
                end
            | _ -> ()
          end;
          begin
            (*  if [dhierarchy] not present, create a new node.
                if [dhierarchy] already present, update the node.
              *)
            match Hashtbl.find_opt nodestates nodekey with
            | Some ({ node; objid; _ } as nodestate) ->
                (* update cabinet official's name *)
                set_name node nodename;
                (* progress is based on months in service, not months visible *)
                set_service_progress node ~dstate ~dmons;
                nodestate.phase <- state_phase;
                Hashtbl.add live objid ()
            | None -> (
                (* find cabinet official's leader (the parent node).
                   the root node is the "leader" for a sovereign *)
                let leader' =
                  get_parent_node ~rootnodestate nodestates dhierarchy
                in
                match leader' with
                | None ->
                    (* no leader found *)
                    if trace then
                      Printf.eprintf
                        "Warning: No leader found for %s. Skipping...\n%!"
                        nodename;
                    ()
                | Some { node = leader; objid = _; _ } ->
                    (* make the cabinet official a new child of the leader *)
                    let official =
                      start ~estimated_total:dmons leader nodename
                    in
                    let objid = next_objid () in
                    Hashtbl.add nodestates nodekey
                      { node = official; objid; phase = state_phase };
                    (* progress is based on months in service, not months visible *)
                    set_service_progress official ~dstate ~dmons;
                    Hashtbl.add live objid ())
          end;
          aux rest
    in
    aux monthdata;


    (* garbage collect nodes in nodestate that are no longer alive.
       but go through lowest to highest rank so we don't do cascading deletes. *)
    let phased_gc rank =
      Hashtbl.filter_map_inplace
        (fun { hk_hierarchy = h; hk_name = _ } ({ node; objid; _ } as nodestate)
           ->
          match rank_hierarchy h with
          | r, _variant when r = rank ->
              (* same rank so consider if live *)
              if Hashtbl.mem live objid then Some nodestate
              else
                let parent = parent_node ~rootnodestate nodestates h in
                if trace then
                  Printf.eprintf "GC'ing node for %s in %s\n%!"
                    (Option.value ~default:"<unnamed node>" (name node))
                    (Option.value ~default:"<unnamed root>"
                       (name rootnodestate.node));
                end_without_parent_progress ?parent node;
                None
          | _ ->
              (* keep anything out of phase *)
              Some nodestate)
        nodestates
    in
    for rank = rank_hierarchy_max downto 0 do
      phased_gc rank
    done


  (* ---- Elm-style animation (model / msg / update + a reconciling view) ----


     The model is the pure animation state -- just the current month. [update]
     advances it in response to a message. [render] is the "view": it reconciles
     the backend tree (the managed runtime state, like a virtual-DOM patch) to
     the model's month. It is idempotent for a given month, so it is safe to
     call every frame; the backend node handles live in [runtime], not in the
     pure model. *)


  type model = {
    cfg_first : int * int;
    cfg_last : int * int;
    demodata : Denorm.t list Denorm.YymmMap.t;
    cur : int * int; (* current simulated month *)
  }


  type msg =
    | Next_month
    | Set_by_elapsed of { elapsed_secs : float; months_per_sec : float }


  let init ~firstyymm ~lastyymm ?(easing_months = 6) () =
    {
      cfg_first = firstyymm;
      cfg_last = lastyymm;
      demodata = Denorm.denormalize ~easing_months ~firstyymm ~lastyymm data;
      cur = firstyymm;
    }


  let current_yymm model = model.cur
  let is_finished model = model.cur >= model.cfg_last


  let add_months (yy, mm) n =
    let total = (yy * 12) + (mm - 1) + n in
    (total / 12, (total mod 12) + 1)


  (** Advance the model in response to a message ([Next_month] for a CLI demo
      paced by sleeps; [Set_by_elapsed] for a real-time animation loop, where
      the caller supplies the demo's months-per-second). Pure. *)
  let update msg model =
    let clamp ym =
      if ym < model.cfg_first then model.cfg_first
      else if ym > model.cfg_last then model.cfg_last
      else ym
    in
    match msg with
    | Next_month -> { model with cur = clamp (nextmon model.cur) }
    | Set_by_elapsed { elapsed_secs; months_per_sec } ->
        let idx = int_of_float (elapsed_secs *. months_per_sec) in
        let idx = if idx < 0 then 0 else idx in
        { model with cur = clamp (add_months model.cfg_first idx) }


  (* The managed runtime: the backend root and the live node handles that
     [render] reconciles -- analogous to Elm's real DOM. *)
  type runtime = {
    rt_root : Progress.nodeobj;
    rt_trace : bool;
    rt_nodestates : (hierarchy_key, nodestate) Hashtbl.t;
    rt_next_objid : unit -> [ `Object of int ];
  }


  let create_runtime ~root ?(trace = false) () =
    let current_objid = ref 0 in
    let next_objid () =
      let id = !current_objid in
      current_objid := id + 1;
      `Object id
    in
    (* the root takes object id 0, matching the original driver *)
    ignore (next_objid ());
    {
      rt_root = root;
      rt_trace = trace;
      rt_nodestates = Hashtbl.create 16;
      rt_next_objid = next_objid;
    }


  (** The "view": reconcile the backend tree under [runtime] to show [model]'s
      current month -- rename the root, add/update/remove the ministers' subtree
      ([do_yymm] is the patch), and set the root's completed-month count.
      Idempotent for a given month; the caller flushes the backend afterwards.
  *)
  let render rt model =
    let open Progress in
    let rootnodestate =
      { node = rt.rt_root; objid = `Object 0; phase = Serving }
    in
    set_name rt.rt_root (rootnode_name model.cur);
    let monthdata =
      Option.value ~default:[]
        (Denorm.YymmMap.find_opt model.cur model.demodata)
    in
    do_yymm ~trace:rt.rt_trace ~next_objid:rt.rt_next_objid ~rootnodestate
      rt.rt_nodestates monthdata;
    set_completed_items rt.rt_root (months_in_range model.cfg_first model.cur)


  (** [run ...] animates the whole range, calling [tick] after each month --
      where the caller flushes the backend and paces the demo (e.g. sleeps).
      Built on the Elm-style model above; the caller does any final flush. *)
  let run ~root ~firstyymm ~lastyymm ?(easing_months = 6) ?(trace = false) ~tick
      () =
    let rt = create_runtime ~root ~trace () in
    let model = ref (init ~firstyymm ~lastyymm ~easing_months ()) in
    let rec loop () =
      render rt !model;
      tick ();
      if is_finished !model then ()
      else begin
        model := update Next_month !model;
        loop ()
      end
    in
    loop ()
end
end

2. The cabinet app

Section titled “2. The cabinet app”

This cell defines cabinet which is an Elm-style (init / update / view / subscriptions) record that drives MlFront_ProgressZig (a built-in progress tree library) and renders its ANSI. Consider changing the cell to use months_per_sec = 25.0 and then running this cell and the next.

(* An Elm-style terminal app (Dk_web.app) wrapping the Canadian Cabinet
   animation. The terminal calls init once, then each animation frame folds the
   frame's timing through update and displays view; subscriptions stop
   requesting frames once the timeline finishes. *)
let cabinet
    : ( Samples.CanadianCabinet.runtime * Samples.CanadianCabinet.model,
        Dk_web.timing )
      Dk_web.app =
  let module C = Samples.CanadianCabinet in
  let months_per_sec = 5.0 in
  {
    Dk_web.init =
      (fun () ->
        (* shutdown lets a fresh root node start on each (re)run *)
        MlFront_ProgressZig.Zig.shutdown ();
        match
          MlFront_ProgressZig.root_node ~initial_delay_ns:0L ~refresh_rate_ns:0L
            ~root_name:(C.rootnode_name C.firstyymm)
            ~estimated_total_items:(C.months_in_range C.firstyymm C.lastyymm) ()
        with
        | Error msg -> failwith ("progress backend: " ^ msg)
        | Ok root ->
            ( C.create_runtime ~root (),
              C.init ~firstyymm:C.firstyymm ~lastyymm:C.lastyymm () ));
    update =
      (fun (t : Dk_web.timing) (rt, cab) ->
        ( rt,
          C.update
            (C.Set_by_elapsed
               { elapsed_secs = t.Dk_web.elapsed_secs_since_start; months_per_sec })
            cab ));
    view =
      (fun (rt, cab) ->
        Dk_web.capture (fun () ->
            C.render rt cab;
            MlFront_ProgressZig.Zig.flush ()));
    subscriptions =
      (fun (_, cab) ->
        if C.is_finished cab then [] else [ Dk_web.on_frame (fun t -> t) ]);
  }

3. The terminal

Section titled “3. The terminal”

{% terminal f="cabinet" /%} attaches the cabinet app defined above and runs it:

Loading the terminal…