package bonsai

  1. Overview
  2. Docs
package bonsai
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file visibility_tracker.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
open! Core
open! Import
open! Bonsai_web
open Js_of_ocaml

module Bbox = struct
  type 'a t =
    { min_x : 'a
    ; max_x : 'a
    ; min_y : 'a
    ; max_y : 'a
    }
  [@@deriving sexp, equal]

  module Int = struct
    type nonrec t = int t [@@deriving sexp, equal]

    let width { min_x; max_x; _ } = max_x - min_x
    let height { min_y; max_y; _ } = max_y - min_y
  end

  module Float = struct
    type nonrec t = float t [@@deriving sexp, equal]

    let width { min_x; max_x; _ } = max_x -. min_x
    let height { min_y; max_y; _ } = max_y -. min_y
  end

  let intersection a b =
    let open Core.Float in
    let r =
      { min_x = max a.min_x b.min_x
      ; min_y = max a.min_y b.min_y
      ; max_x = min a.max_x b.max_x
      ; max_y = min a.max_y b.max_y
      }
    in
    if Float.height r <= 0.0 || Float.width r <= 0.0 then None else Some r
  ;;

  let round_bigger { min_x; min_y; max_x; max_y } =
    let open Core.Float in
    { min_x = iround_down_exn min_x
    ; min_y = iround_down_exn min_y
    ; max_x = iround_up_exn max_x
    ; max_y = iround_up_exn max_y
    }
  ;;
end

let intersect_and_reproject client_bbox window_bbox =
  Option.map (Bbox.intersection client_bbox window_bbox) ~f:(fun inter ->
    let min_x = inter.min_x -. client_bbox.min_x in
    let min_y = inter.min_y -. client_bbox.min_y in
    let max_x = min_x +. Bbox.Float.width inter in
    let max_y = min_y +. Bbox.Float.height inter in
    Bbox.round_bigger { min_x; min_y; max_x; max_y })
;;

let compute_visibility ~client_bbox ~window_bbox ~parents =
  let window_bbox =
    List.fold parents ~init:(Some window_bbox) ~f:(fun acc parent ->
      match acc with
      | None -> None
      | Some acc -> Bbox.intersection acc parent)
  in
  let visible_section =
    Option.bind window_bbox ~f:(intersect_and_reproject client_bbox)
  in
  Bbox.round_bigger client_bbox, visible_section
;;

let rec get_parent_rects element =
  let open Option.Let_syntax in
  let o =
    let%bind parent = Js.Opt.to_option element##.parentNode in
    let%bind parent = Js.Opt.to_option (Dom_html.CoerceTo.element parent) in
    let parent_bb = element##getBoundingClientRect in
    let parent_bb =
      { Bbox.min_x = parent_bb##.left
      ; min_y = parent_bb##.top
      ; max_y = parent_bb##.bottom
      ; max_x = parent_bb##.right
      }
    in
    Some (parent_bb :: get_parent_rects parent)
  in
  Option.value ~default:[] o
;;

let get_accurate_vis_bounds (element : Dom_html.element Js.t) =
  let client_bbox =
    let client_bounds = element##getBoundingClientRect in
    { Bbox.min_x = client_bounds##.left
    ; min_y = client_bounds##.top
    ; max_y = client_bounds##.bottom
    ; max_x = client_bounds##.right
    }
  in
  let window_bbox =
    { Bbox.min_x = 0.0
    ; min_y = 0.0
    ; max_x = Int.to_float Dom_html.window##.innerWidth
    ; max_y = Int.to_float Dom_html.window##.innerHeight
    }
  in
  let parents = get_parent_rects element in
  compute_visibility ~client_bbox ~window_bbox ~parents
;;

module T = struct
  module Input = struct
    type t =
      { client_rect_changed : int Bbox.t -> unit Vdom.Effect.t
      ; visible_rect_changed : int Bbox.t option -> unit Vdom.Effect.t
      }

    let sexp_of_t = sexp_of_opaque

    let combine
          { client_rect_changed = client_rect_changed_left
          ; visible_rect_changed = visible_rect_changed_left
          }
          { client_rect_changed = client_rect_changed_right
          ; visible_rect_changed = visible_rect_changed_right
          }
      =
      let client_rect_changed bbox =
        Vdom.Effect.sequence_as_sibling
          (client_rect_changed_left bbox)
          ~unless_stopped:(fun () -> client_rect_changed_right bbox)
      in
      let visible_rect_changed bbox =
        Vdom.Effect.sequence_as_sibling
          (visible_rect_changed_left bbox)
          ~unless_stopped:(fun () -> visible_rect_changed_right bbox)
      in
      { client_rect_changed; visible_rect_changed }
    ;;
  end

  module State = struct
    type prev =
      { mutable whole_element : int Bbox.t
      ; mutable visible_section : int Bbox.t option
      }
    [@@deriving sexp, equal]

    type nonrec t =
      { mutable callback : Input.t
      ; mutable prev : prev
      ; mutable animation_id : (Dom_html.animation_frame_request_id[@sexp.opaque])
      ; mutable dirty : bool
      }
    [@@deriving sexp_of]

    let schedule state ~f =
      cancel_animation_frame state.animation_id;
      state.animation_id <- request_animation_frame f
    ;;
  end

  let init (callback : Input.t) element =
    let state =
      { State.callback
      ; prev =
          { whole_element = { min_x = 0; min_y = 0; max_x = 0; max_y = 0 }
          ; visible_section = None
          }
      ; animation_id = request_animation_frame (Fn.const ())
      ; dirty = true
      }
    in
    let rec every_frame _frame_time =
      let whole_element, visible_section = get_accurate_vis_bounds element in
      if state.dirty
      || not ([%equal: int Bbox.t option] visible_section state.prev.visible_section)
      then (
        Effect.Expert.handle_non_dom_event_exn
          (state.callback.visible_rect_changed visible_section);
        state.prev.visible_section <- visible_section);
      if state.dirty || not ([%equal: int Bbox.t] whole_element state.prev.whole_element)
      then (
        Effect.Expert.handle_non_dom_event_exn
          (state.callback.client_rect_changed whole_element);
        state.prev.whole_element <- whole_element);
      state.dirty <- false;
      State.schedule state ~f:every_frame
    in
    State.schedule state ~f:every_frame;
    state
  ;;

  let on_mount _input _state _element = ()

  let update ~old_input:_ ~new_input:callback (state : State.t) _element =
    state.dirty <- true;
    state.callback <- callback
  ;;

  let destroy _input (state : State.t) _element =
    cancel_animation_frame state.animation_id
  ;;
end

module Hook = Vdom.Attr.Hooks.Make (T)

let detect
      ?(client_rect_changed = fun _ -> Effect.Ignore)
      ?(visible_rect_changed = fun _ -> Effect.Ignore)
      ()
  =
  Vdom.Attr.create_hook
    "bounds-change"
    (Hook.create { T.Input.client_rect_changed; visible_rect_changed })
;;

module For_testing = struct
  include Hook.For_testing
  include T.Input

  let intersect_and_reproject = intersect_and_reproject

  let compute_visibility ~client_bbox ~window_bbox ~parents =
    compute_visibility ~client_bbox ~window_bbox ~parents |> Tuple2.get2
  ;;
end
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct