Source file object.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Objects.

  Class {!class-o} is the base class for widget and other classes which
  can trigger events and hold properties {!Props.props}.
*)

(** Introduce the [Prop_changed] property to register callbacks called
  when the value of a given property changed. Previous and current
  values of the property are passed to the callback. *)
type _ Events.ev +=
| Prop_changed : 'a Props.prop -> (prev: 'a option -> now: 'a -> unit) Events.ev

(** Object id. Each object of {!class-o} is given a unique id. *)
type id = Oid.t

(** Transition step minimum delay, in milliseconds. *)
let transition_step_delay = 50

(** An object. See {!Widget.widget_arguments} for [props] arguments.

  Registered callbacks are unregistered when object is destroyed.
*)
class o ?props () =
  let props = match props with None -> Props.create () | Some p -> p in
  let id = Oid.gen () in
  object(self)
    (** The unique id of the object. *)
    method id = id

    (** Coercion to {!class-o}. *)
    method as_o = (self :> o)

    (** Returns a string representation of the object's name and id.*)
    method me = Printf.sprintf "[%s]" (Oid.to_string self#id)

    (**/**)
    val callbacks = Events.callbacks ()
    val mutable props = Props.dup props
    val mutable delayed_props : unit Lwt.u Props.Map.t = Props.Map.empty
    (**/**)

    (** Returns the object properties. This is not a copy and should
      not be modified directly except if you know what you're doing.
      To set a property value, use the [set_*] methods provided by
      inheriting classes. If no such method is available for a
      property, you can use the [set_p] method below.*)
    method props = props

    (** [o#get_p p] returns value of property [p] in properties of [o].
      If no value for [p] is set in [o] and [p] has no default value,
      then {!Misc.type-error.Missing_prop} is raised.
    *)
    method get_p : 'a. 'a Props.prop -> 'a = fun p -> Props.get props p

    (** [o#opt_p p] returns value of property [p] in properties of [o],
      if such a value is set. *)
    method opt_p : 'a. 'a Props.prop -> 'a option = fun p -> Props.opt props p

    (** [o#set_p p v] sets value [v] to property [p] in properties of [o].
      Optional argument [propagate] (defaults: [false]) can be used
      to indicate that this change must be propagated to children objects.
      Optional argument [delay] can be used to specify a transition delay (in seconds)
      if the property has a transition function. Default is no delay.
      Class {!class-o} has no children, but inheriting classes may have and
      will override this method to implement propagation.
      The [Prop_changed] event is triggered if the value of [p] changed
      (properties are defined with a comparison function, allowing
       to detect a change).
    *)
    method set_p : 'a. 'a Props.prop -> ?delay:float -> ?propagate:bool -> 'a -> unit =
      fun p ?delay ?(propagate=false) v ->
        match delay with
        | None ->
            (
             match Props.update props p v with
             | None -> (* no change *) ()
             | Some prev ->
                 try
                   [%debug "%s property %S updated => %a (propagate=%b)"
                        self#me (Props.name p) (Props.pp_prop p) v
                       propagate];
                   self#on_prop_changed p ~prev v ;
                 with Not_found ->
                     Log.err (fun  m -> m "Not found! %s" (Printexc.get_backtrace()))
            )
        | Some delay ->
            (* if we have no transition fun we a delay is required,
               create a dummy transition fun and set a transition step
               equal to the delay. *)
            let trans, transition_step_delay =
              match Props.transition p with
              | Some f -> f, transition_step_delay
              | None ->
                  (fun ~start ~stop r -> if r >= 1. then stop else start),
                  (truncate (delay *. 1000.))
            in
            (match Props.Map.find_opt p delayed_props with
             | None -> ()
             | Some resolver ->
                 delayed_props <- Props.Map.remove p delayed_props;
                 Lwt.wakeup resolver ()
            );
            let start = self#get_p p in
            let stop = v in
            let start_t = Tsdl.Sdl.get_ticks () in
            let delay = delay *. 1000. in
            let waiter, resolver = Lwt.wait () in
            delayed_props <- Props.Map.add p resolver delayed_props ;
            let rec f () =
              let%lwt () = Lwt_unix.sleep (float transition_step_delay /. 1000.) in
              match Lwt.state waiter with
              | Return _ | Fail _ -> Lwt.return_unit
              | Sleep ->
                  let t = Tsdl.Sdl.get_ticks () in
                  let r = min 1.0 (Int32.(to_float (sub t start_t)) /. delay) in
                  let v = trans ~start ~stop r in
                  self#set_p p ~propagate v;
                  if r < 1. then
                    f ()
                  else
                    (
                     delayed_props <- Props.Map.remove p delayed_props ;
                     Lwt.return_unit
                    )
            in
            Lwt.async f

    (**/**)
    method on_prop_changed : 'a. 'a Props.prop -> prev:'a option -> 'a -> unit =
      fun p ~prev now ->
        let cbs = Events.get callbacks (Prop_changed p) in
        List.iter (fun cb -> cb ~prev ~now) cbs
    (**/**)

    (** [o#set_props ?propagate props] calls [o#set_p ?propagate] for
      each pair (property, value) in [props]. *)
    method set_props ?delay ?propagate props =
      Props.fold
        (fun p v () -> self#set_p ?delay ?propagate p v)
        props
        ()

    (**/**)
    val mutable callback_ids = ([] : Events.callback_id list)
    (**/**)

    (** [o#connect event cb] registers [cb] to be called when [event]
      is triggered by [o]. Returns a callback id which can be used
      to unregister the callback, either with {!method-disconnect} or with
      {!Events.unregister}.
      Optional parameter [count] indicates the number of times the
      callback is called before being unregistered. Default is [None],
      i.e. callback is not unregistered.
      *)
    method connect : 'a. ?count:int -> 'a Events.ev -> 'a -> Events.callback_id =
      fun ?count e cb ->
        let id = Events.register callbacks ?count e cb in
        callback_ids <- id :: callback_ids;
        id

    (** [disconnect id] unregisters the callback with the given [id]. *)
    method disconnect = Events.unregister

    (**/**)
    method trigger_event : 'a. ('a -> bool) Events.ev -> 'a -> bool =
      fun ev v ->
        [%debug "%s#trigger_event %s" self#me
          (Printexc.to_string (Obj.magic ev))];
        match Events.get callbacks ev with
        | [] -> false
        | cbs ->
          List.fold_left
            (fun acc cb -> let b = cb v in (b || acc))
              false cbs

    method trigger_event_unit : 'a. ('a -> bool) Events.ev -> 'a -> unit =
      fun ev v -> ignore(self#trigger_event ev v)

    method trigger_unit_event : 'a. ('a -> unit) Events.ev -> 'a -> unit =
      fun ev v ->
        match Events.get callbacks ev with
        | [] -> ()
        | cbs -> List.iter
            (fun f ->
               try f v
               with e -> Log.err (fun m -> m "%s" (Printexc.to_string e)))
              cbs

    method destroy = List.iter Events.unregister callback_ids

(*
    initializer
      prerr_endline (Printf.sprintf "object %s created" (Oid.to_string id));
      let str = self#me in
      Gc.finalise_last
        (fun () -> prerr_endline (Printf.sprintf "object %s finalised" str)
           (*List.iter Events.unregister callback_ids*))
        self
*)
  end

(** [add_mirror ~src:(object1,prop1) ~dst:(object2,prop2) ~map_to ~map_from]
  registers event handlers to that a change on [prop1] in [object1] triggers a
  change of propery [prop2] of [object2], using [map_to] to map the new value of
  [prop1] to the value given to [prop2], and conversely (using [map_from]).
  The function returns the event handlers on [object1] and [object2], so that
  this mirror can be removed using [object1#disconnect id1; object2#disconnect id2].
*)
let add_mirror :
    src:(o *'a Props.prop) -> dst:(o * 'b Props.prop) ->
      map_to:('a -> 'b) -> map_from:('b -> 'a) -> (Events.callback_id * Events.callback_id) =
 fun ~src:(o1,p1) ~dst:(o2,p2) ~map_to ~map_from ->
   let f_from ~prev:_ ~now = let v = map_from now in o1#set_p p1 v in
   let id_from = (o2)#connect (Prop_changed p2) f_from in
   let f_to ~prev:_ ~now = let v = map_to now in o2#set_p p2 v in
   let id_to = (o1)#connect (Prop_changed p1) f_to in
   (id_to, id_from)

(** Same as {!add_mirror}, using [Fun.id] as mappers, i.e. when both properties
  have the same time and meaning. *)
let add_mirror_id ~src ~dst =
  add_mirror ~src ~dst ~map_to:Fun.id ~map_from:Fun.id