Ax/lib/react_loop.ml

open Base
open Math

type 'id t =
  { mutable tree : Draw_tree.t
  ; mutable state : Source.State.t
  ; callbacks : Component.callbacks
  ; mutable event_cb_ids : 'id list }

type event = Tick | Click of Pos.t | Repaint | Exit

module type EVENTS_LAYER = sig
  type callback_id
  val bind_callback : (event -> unit) -> callback_id
  val unregister : callback_id -> unit
  val poll_time_ms : unit -> int
end

module type GRAPHICS_LAYER = sig
  val clear : unit -> unit
  val rect : AABB.t -> Color.t -> unit
end

module Make(E : EVENTS_LAYER)(G : GRAPHICS_LAYER) :
sig
  val run : Component.t -> unit
end
=
struct
  let poll_time _ =
    E.poll_time_ms () / 1000

  let updates_of_sinks state sinks srcs =
    Sequence.concat_map (Sequence.of_list srcs)
      ~f:(fun src ->
          Map.find sinks src
          |> Option.value ~default:[]
          |> Sequence.of_list)
    |> Sequence.map
         ~f:(fun (path, fig_b) ->
             (path, Behavior.sample fig_b state))

  let handle_updated_sources t srcs =
    let updates = updates_of_sinks t.state t.callbacks.sinks srcs in
    begin
      t.tree <- Draw_tree.apply_updates_exn updates t.tree ;
      not (Sequence.is_empty updates)
    end

  let update_sources t (chg_src_map : (Source.value -> Source.value) Source.map) =
    let f ~key:src ~data:func state =
      let value = Source.State.get_exn src state in
      let value = func value in
      Source.State.set src value state
    in
    begin
      t.state <- Map.fold chg_src_map ~init:t.state ~f ;
      handle_updated_sources t (Map.keys chg_src_map)
    end

  let update_source ~src ~f t =
    update_sources t (Map.singleton (module Source) src f)

  let handle_evt t = function
    | Tick ->
       update_source t
         ~src:Source.time
         ~f:poll_time

    | Click(pos) ->
       let ev_arg = Event.Click(pos) in
       update_sources t @@
       List.fold (Draw_tree.capture_point ~pos t.tree)
         ~init:Source.empty_map
         ~f:(fun chg ev_id ->
             match Map.find t.callbacks.handlers ev_id with
             | Some(handler) ->
                Map.merge_skewed chg (handler ev_arg)
                  ~combine:(fun ~key:_ f g x -> f (g x))
             | None -> chg)

    | Repaint ->
       true

    | Exit ->
       let () = List.iter ~f:E.unregister t.event_cb_ids in
       let () = t.event_cb_ids <- [] in
       false

  let repaint t =
    let () = G.clear () in
    Sequence.iter (Draw_tree.render t.tree)
      ~f:(function
          | Draw_tree.Draw.Rect(b, c) -> G.rect b c)

  let run app =
    let state = Source.State.of_time (poll_time ()) in
    let state, callbacks, tree = Component.mount state app in
    let t = { tree ; state ; callbacks ; event_cb_ids = [] } in
    let ec_id =
      E.bind_callback
        (fun ev -> if handle_evt t ev then repaint t)
    in
    let () = t.event_cb_ids <- [ec_id] in
    repaint t

end