Allow creating ccstom widgets for ui

bin/hotreload.available.ml

@@ -2,45 +2,47 @@ let ui_replay ~io (nb_past, target_clock, nb_future) =
   let open Gamelle in
   let open Ui in
   let io = View.font_size 12 @@ View.color Color.white io in
-  window ~io
-    ~width:(fun _ -> Size.width (Window.size ~io))
-    ~height:(fun h ->
-      Gamelle_common.ui_replay_height := h;
-      h)
-  @@ fun [%ui] ->
-  horizontal [%ui] @@ fun () ->
-  let total_events = nb_past + nb_future in
-  let present =
-    if total_events <= 0 then 0
-    else
-      over [%ui] @@ fun () ->
-      draw [%ui] (fun ~io box ->
-          let module Box = Gamelle.Box in
-          let size = Box.size box in
-          let progress =
-            8.0
-            +. ((Size.width size -. 16.0) *. float nb_past /. float total_events)
-          in
-          let target =
-            8.0
-            +. (Size.width size -. 16.0)
-               *. float target_clock /. float total_events
-          in
-          let missing =
-            Box.v
-              Vec.(Box.top_left box + Vec.v progress 0.0)
-              (Size.v (target -. progress) (Size.height size))
-          in
-          if Box.width missing > 0.0 then
-            Box.fill ~io ~color:Color.(with_alpha 0.2 red) missing);
-      int_of_float
-      @@ slider [%ui] ~min:0.0 ~max:(float total_events) (float target_clock)
-  in
-  let nb_future =
-    reshape [%ui] ~width:(fun _ -> { flex = 0.0; min = 60.0; max = 60.0 })
-    @@ fun () -> if button [%ui] "CLEAR" then 0 else nb_future
+  let _, result =
+    window ~io ~at:Point.zero ~size:(fun s ->
+        Gamelle_common.ui_replay_height := Size.height s;
+        Size.v (Size.width (Window.size ~io)) (Size.height s))
+    @@ fun [%ui] ->
+    horizontal [%ui] @@ fun () ->
+    let total_events = nb_past + nb_future in
+    let present =
+      if total_events <= 0 then 0
+      else
+        over [%ui] @@ fun () ->
+        Ui.Custom.draw [%ui] (fun ~io box ->
+            let module Box = Gamelle.Box in
+            let size = Box.size box in
+            let progress =
+              8.0
+              +. (Size.width size -. 16.0)
+                 *. float nb_past /. float total_events
+            in
+            let target =
+              8.0
+              +. (Size.width size -. 16.0)
+                 *. float target_clock /. float total_events
+            in
+            let missing =
+              Box.v
+                Vec.(Box.top_left box + Vec.v progress 0.0)
+                (Size.v (target -. progress) (Size.height size))
+            in
+            if Box.width missing > 0.0 then
+              Box.fill ~io ~color:Color.(with_alpha 0.2 red) missing);
+        int_of_float
+        @@ slider [%ui] ~min:0.0 ~max:(float total_events) (float target_clock)
+    in
+    let nb_future =
+      reshape [%ui] ~width:(fun _ -> { flex = 0.0; min = 60.0; max = 60.0 })
+      @@ fun () -> if button [%ui] "CLEAR" then 0 else nb_future
+    in
+    (nb_past, present, nb_future)
   in
-  (nb_past, present, nb_future)
+  result
 
 let to_string = function
   | Inotify.Access -> "Access"

examples/ui/src/ui.ml

@@ -26,16 +26,10 @@ let initial_state =
 let rec loop { text; check1; check2; slider1; slider2; rad } ~io =
   if Input.is_pressed ~io `escape then raise Exit;
   Window.show_cursor ~io true;
-  let wr = ref 0.0 and hr = ref 0.0 in
-  let state =
+  let panel_size, state =
     let open Ui in
-    window ~io
-      ~width:(fun w ->
-        wr := 1.1 *. w;
-        !wr)
-      ~height:(fun h ->
-        hr := 1.1 *. h;
-        !hr)
+    window ~io ~at:Point.zero ~size:(fun s ->
+        Size.v (Size.width s *. 1.5) (Size.height s *. 1.))
     @@ fun [%ui] ->
     let text = text_input [%ui] text in
     text_area [%ui]
@@ -109,7 +103,7 @@ let rec loop { text; check1; check2; slider1; slider2; rad } ~io =
     end;
     { text; check1; check2; slider1; slider2; rad }
   in
-  Window.set_size ~io (Size.v !wr !hr);
+  Window.set_size ~io panel_size;
   next_frame ~io;
   loop state ~io
 

lib/gamelle.mli

@@ -751,11 +751,20 @@ module Ui : sig
   type ui
 
   val window :
-    io:io ->
-    ?width:(float -> float) ->
-    ?height:(float -> float) ->
-    (ui -> 'a) ->
-    'a
+    io:io -> at:Point.t -> ?size:(Size.t -> Size.t) -> (ui -> 'a) -> Size.t * 'a
+  (** {ocaml[window ~io ~at ?size begin fun [%ui] ->
+    ...
+  end]}
+
+  renders a UI panel with its top-left corner at [at] and returns
+  [(panel_size, result)] where [panel_size] is the final rendered size and
+  [result] is the value returned by the callback.
+
+  The panel lays out its contents, then [size] is applied to the resulting
+  natural size to produce the final dimensions; it defaults to the identity,
+  meaning the panel is exactly as large as its contents require. Use [~size:(fun
+  _ -> Size.v w h)] to fix dimensions, or [~size:(fun s -> Size.v (Size.width s
+  *. 1.1) (Size.height s))] to scale one axis. *)
 
   val button : ui -> string -> bool
   (** [button [%ui] "click me"] display a button saying "click me", and return
@@ -867,39 +876,168 @@ capping its [max].
 Note: reporting a [min] smaller than the child actually needs will cause it
 to be rendered in a box that is too small, resulting in clipping or overflow. *)
 
-  val draw :
-    ui ->
-    ?min_width:float ->
-    ?max_width:float ->
-    ?min_height:float ->
-    ?max_height:float ->
-    ?flex_width:float ->
-    ?flex_height:float ->
-    (io:io -> Box.t -> unit) ->
-    unit
-  (** {ocaml[
-draw [%ui] ?min_width ?max_width ?min_height ?max_height
-  ?flex_width ?flex_height begin fun ~io box ->
-    ...
-  end
-]}
-
-The primitive leaf widget. Declares a box with the given layout constraints and
-calls the drawing function with the allocated [~io] and {!Box.t}.
-
-The code [...] should draw the desired inside the [box] its given by the layout.
+  (** {1 Building custom widgets}
 
-All size parameters default to [0.0] except [max_width] and [max_height] which
-default to [infinity]. A [flex] value of [0.0] means the widget takes exactly
-its [min] size; a positive value means it competes for extra space
-proportionally to that value.
+      Use [Ui.Custom] to build new interactive widgets. The primitives here are
+      the same ones used to implement {!button}, {!checkbox}, {!slider}, etc.
 
-No clipping is applied: drawing outside [box] is not prevented. If you want
-clipping you can use {!View.clip}.
-
-You can combine this with {!over} to create "reskins" of other widgets.
+      A typical non-container widget follows this pattern:
+      {[
+        open Ui.Custom
+
+        module Store = State (struct
+          type t = float
+        end)
+
+        let my_toggle ui (checked : bool) : bool =
+          let anim = Store.find [%ui] 0.0 in
+          on_click ui @@ fun st ->
+          update anim
+            (if st = `pressed then min 1.0 (value anim +. 0.05) else value anim);
+          let checked = if st = `clicked then not checked else checked in
+          draw ui ~min_width:40. ~min_height:20. (fun ~io box ->
+              (* render using checked and (value anim) *)
+              ());
+          checked
+      ]} *)
 
-*)
+  module Custom : sig
+    type 'a state
+    (** Persistent per-instance internal state. Use {!get} and {!set} to access
+        it. The concrete representation is hidden. *)
+
+    val value : 'a state -> 'a
+    val update : 'a state -> 'a -> unit
+
+    val draw :
+      ui ->
+      ?min_width:float ->
+      ?max_width:float ->
+      ?min_height:float ->
+      ?max_height:float ->
+      ?flex_width:float ->
+      ?flex_height:float ->
+      (io:io -> Box.t -> unit) ->
+      unit
+    (** The primitive leaf widget. Declares a box with the given layout
+        constraints and calls the drawing function with the allocated [~io] and
+        {!Box.t}.
+
+        All size parameters default to [0.0] except [max_width] and [max_height]
+        which default to [infinity]. A [flex] value of [0.0] means the widget
+        takes exactly its [min] size; a positive value means it competes for
+        extra space proportionally to that value. *)
+
+    val get_io : ui -> io
+    (** Get the current [io]. Needed to read input events such as mouse position
+        inside [on_click] callbacks. *)
+
+    (** Layout primitives for building container widgets. Pass a
+        [Layout.t list -> Layout.t] function to {!parent} to define how children
+        are arranged. *)
+    module Layout : sig
+      type t
+
+      val horizontal : ?gap:float -> t list -> t
+      val vertical : ?gap:float -> t list -> t
+      val over : t list -> t
+      val pad : float -> t -> t
+      val center : t list -> t
+      val vclip : float -> t -> t
+      val hclip : float -> t -> t
+
+      val reshape :
+        ?width:(constrain -> constrain) ->
+        ?height:(constrain -> constrain) ->
+        t ->
+        t
+    end
+
+    val parent : ui -> (Layout.t list -> Layout.t) -> (unit -> 'a) -> 'a
+    (** Container primitive. [parent ui layout fn] runs [fn] to collect child
+        layout nodes, passes them to [layout], and inserts the result. All
+        built-in layout combinators ([horizontal], [vertical], etc.) are
+        wrappers around this. *)
+
+    val parent1 : ui -> (Layout.t -> Layout.t) -> (unit -> 'a) -> 'a
+    (** Like {!parent} but asserts exactly one child. *)
+
+    val horizontal : ui -> ?gap:float -> (unit -> 'a) -> 'a
+    val vertical : ui -> ?gap:float -> (unit -> 'a) -> 'a
+    val over : ui -> (unit -> 'a) -> 'a
+
+    val vclip : ui -> ?offset:Vec.t -> Box.t -> (unit -> 'a) -> 'a
+    (** Clips content vertically to [box], scrolled by [offset]. Events outside
+        the clip box are suppressed. *)
+
+    val hclip : ui -> ?offset:Vec.t -> Box.t -> (unit -> 'a) -> 'a
+    (** Clips content horizontally to [box], scrolled by [offset]. Events
+        outside the clip box are suppressed. *)
+
+    val on_click :
+      ui -> ([ `normal | `hover | `pressed | `clicked ] -> 'a) -> 'a
+    (** Track hover/press/click state for whatever is rendered inside the
+        callback. Internal button state is managed automatically. *)
+
+    val with_box : ui -> (Box.t -> 'a) -> 'a
+    (** Provides the layout box allocated to the content. Useful when the box is
+        needed for hit-testing or positioning outside of a [draw] call. *)
+
+    val boxed :
+      ?border:Color.t -> ?bg:Color.t -> ?pad:float -> ui -> (unit -> 'a) -> 'a
+    (** Wraps content in a bordered rectangle with background fill. Defaults to
+        theme colors and [pad = 10.0]. *)
+
+    val padding : ui -> float -> (unit -> 'a) -> 'a
+    (** Adds uniform padding around the content. *)
+
+    val center : ui -> (unit -> 'a) -> 'a
+    (** Centers the content in the available space. *)
+
+    (** Module type satisfied by the result of {!State}. Pass as a first-class
+        module to {!with_state}. *)
+    module type Store = sig
+      type value
+
+      val find : ui -> value -> value state
+    end
+
+    (** [module Store = State(struct type t = my_type end)] creates a persistent
+        store for internal state of type [my_type]. Declare one per
+        internal-state type at module level. *)
+    module State : functor
+      (V : sig
+         type t
+       end)
+      -> Store with type value = V.t
+
+    val with_state :
+      (module Store with type value = 'a) -> ui -> 'a -> ('a -> 'a) -> 'a
+    (** [with_state (module Store) [%ui] default (fun v -> ...)] looks up the
+        persistent state for this call-site, passes the current value [v] to the
+        callback, persists the returned value, and returns it.
+
+        The state type ['a] can combine internal and external parts; the caller
+        is responsible for extracting whichever parts it needs from the result.
+
+        {[
+          open Ui.Custom
+
+          module Store = State (struct
+            type t = int * string
+          end)
+
+          let my_widget ui init_text =
+            let _, text =
+              with_state (module Store) [%ui] (0, init_text)
+              @@ fun (cursor, text) ->
+              draw ui ~min_width:30. ~min_height:30. (fun ~io box ->
+                  (* render *) ());
+              (cursor + 1, text)
+            in
+            text
+        ]} *)
+  end
 
   (**/**)
 

lib/ui/int_slider.ml

@@ -1,4 +1,6 @@
 module Ui = Ui_backend
 
 let v [%ui] ~min ~max value =
-  int_of_float @@ Slider.v [%ui] ~min:(float_of_int min) ~max:(float_of_int max) (float_of_int value)
+  int_of_float
+  @@ Slider.v [%ui] ~min:(float_of_int min) ~max:(float_of_int max)
+       (float_of_int value)

lib/ui/layout.ml

@@ -68,12 +68,16 @@ let width ?(min = 0.0) ?(max = infinity) ?(flex = 0.0) fn : t =
 let height ?(min = 0.0) ?(max = infinity) ?(flex = 0.0) fn : h =
   ({ min; flex; max }, fn)
 
-let solve ?(width = fun w -> w) ?(height = fun h -> h) layout =
+let solve ~at ?(size = fun s -> s) layout =
   let { min = w; _ }, fn = layout in
-  let w = max w (width w) in
-  let { min = h; _ }, fn = fn w in
-  let h = max h (height h) in
-  fn (Box.v Point.zero (Size.v w h))
+  let { min = h; _ }, _ = fn w in
+  let s = size (Size.v w h) in
+  let w = max w (Size.width s) in
+  let h = max h (Size.height s) in
+  let _, render = fn w in
+  let s = Size.v w h in
+  render (Box.v at s);
+  s
 
 let v ?(min_width = 0.0) ?(flex_width = 0.0) ?(max_width = infinity)
     ?(min_height = 0.0) ?(flex_height = 0.0) ?(max_height = infinity) fn =
@@ -215,6 +219,19 @@ let vclip height layout =
           in
           fn box ) )
 
+let hclip width layout =
+  let w_constraint, fn = layout in
+  ( C1.exact width,
+    fun actual_width ->
+      let h_constraint, fn = fn (max w_constraint.min actual_width) in
+      ( h_constraint,
+        fun box ->
+          let box =
+            Box.v (Box.top_left box)
+              (Size.v (max w_constraint.min (Box.width box)) (Box.height box))
+          in
+          fn box ) )
+
 let center layout =
   let w, fn = layout in
   ( C1.max w C1.flex,