Source file window.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Windows. *)

open Misc
open Tsdl

type _ Events.ev +=
| Close : (unit -> bool) Events.ev
  (* Close request for window; callback should return [true] to prevent closing. *)

(**/**)
let keyboard_state_empty st =
  let module A = Bigarray.Array1 in
  let empty = ref true in
  for i = 0 to A.dim st - 1 do
    let v = A.get st i in
    if v <> 0 then
      (
       [%debug "key %S is pressed"
          (Sdl.(get_key_name (get_key_from_scancode i)))];
       empty := false
      )
  done;
  !empty
(**/**)

(** A window is a widget containing one widget and interfacing
  with SDL window to render and handle events.
  Windows should not be created directly but through
  {!App.create_window}, {!App.create_scrolled_window} and
  {!App.popup_menu} so that events are propagated to them
*)
class window ?classes ?name
  ?props ?wdata ?(flags=Sdl.Window.(opengl))
  ?(rflags=Sdl.Renderer.software) ?resizable ?x ?y ?w ?h title =
  let rflags = Tsdl.Sdl.Renderer.(rflags + targettexture) in
  let flags =
    match resizable with
    | None -> flags
    | Some true -> Sdl.Window.(flags + resizable)
    | Some false -> Sdl.Window.(flags - resizable)
  in
  let (autosize_w, autosize_h, w, h) =
    if Sdl.Window.(test flags resizable) then
      (false, false, Option.value ~default:1 w, Option.value ~default:1 h)
    else
      let autosize_w, w =
        match w with None -> (true, 1) | Some w -> (false, w)
      in
      let autosize_h, h =
        match h with None -> (true, 1) | Some h -> (false, h)
      in
      (autosize_w, autosize_h, w, h)
  in
  let win =
    match Sdl.create_window title ?x ?y ~w ~h flags with
    | Error (`Msg msg) -> Misc.sdl_error msg
    | Ok win -> win
  in
  let renderer = match Sdl.(create_renderer ~flags:rflags win) with
  | Error (`Msg msg) -> Misc.sdl_error msg
  | Ok r -> r
  in
  let () =
    match Sdl.set_render_draw_blend_mode renderer Sdl.Blend.mode_blend with
    | Error (`Msg msg) -> Misc.sdl_error msg
    | Ok x -> x
  in
  let winid  = Sdl.get_window_id win in
  let render_mutex = Lwt_mutex.create () in
  let with_renderer_lock f =
    Lwt_mutex.with_lock render_mutex (fun () -> f renderer)
  in
  object(self)
    inherit Bin.bin ?classes ?name ?props ?wdata () as super

    (** The SDL window. *)
    method window = win

    (** The SDL window id. *)
    method window_id = winid

    (** Set window title. *)
    method set_title str = Sdl.set_window_title win str

    (**/**)
    method kind = "window"
    method! top_window = Some win

    val mutable cursor = Sdl.get_cursor ()
    method! cursor =
      match cursor with
      | None -> Log.warn (fun m -> m "%s#cursor: None" self#me); None
      | Some c -> Some c

    method! to_desktop_coords ~x ~y =
      let (wx, wy) = Sdl.get_window_position win in
      (wx + x, wy + y)

    method apply_theme =
      super#apply_theme ;
      self#need_resize

    (**/**)

    (** Returns SDL window position as [(x,y)]. *)
    method position =
      let (x,y) = Sdl.get_window_position win in
      [%debug "%s#position = (%d,%d)" self#me x y];
      (x,y)

    (** Returns the SDL window size. *)
    method size = Sdl.get_window_size win

    (**/**)
    method renderer = renderer
    val mutable to_render = (Layer.Map.empty : G.t Layer.Map.t)
    (**/**)

    (** [w#resize ~w ~h] resize the window with width [w] and height [h]. *)
    method resize ~w ~h = self#update_geometry ~w ~h ()

    (**/**)
    val mutable is_resizing = false
    val mutable need_resize_after = false
    method need_resize =
      if is_resizing then
        need_resize_after <- true
      else
        (
         super#need_resize ;
         self#update_geometry ()
        )
    method private update_geometry =
      let (w0, h0) = self#size in
      fun ?(w=w0) ?(h=h0) () ->
        if is_resizing then
          ()
        else
          (
           is_resizing <- true;
           need_resize_after <-false ;
           let w = if autosize_w then self#min_width else w in
           let h = if autosize_h then self#min_height else h in
           if (w0 <> w || h0 <> h) then
             Sdl.set_window_size self#window ~w ~h ;
           [%debug "%s#update_geometry => w:%d=>%d, h:%d=>%d" self#me w0 w h0 h];
           self#set_geometry { g with w ; h };
           is_resizing <- false;
           if need_resize_after then
             (need_resize_after <- false ;
              self#update_geometry ()
             )
          )

    val mutable on_close = (fun () -> ())
    (**/**)
    (** Set callback on closing. *)
    method set_on_close f = on_close <- f

    (** Closes the window (destroying it). *)
    method close =
      (try on_close ()
       with e ->
           Log.err (fun m -> m "%s#close: %s" self#me (Printexc.to_string e))
      );
      self#destroy

    (**/**)
    method! get_focus =
      [%debug "%s#get_focus return Some(%b)"
         self#me (self#get_p Props.has_focus)];
      (* release previous focus, but do not cal self#release_focus, since
         this would update our has_focus props; start with child.
         If focus is not released, then return None. *)
      match
        match child with
        | None -> true
        | Some w -> w#release_focus
      with
      | true -> Some (self#get_p Props.has_focus)
      | false -> None

    method! grab_focus ?last () =
      Sdl.raise_window self#window;
      (* In case the window did not get the focus, force it.
         It seems to happen when a window already had focus before,
         typically for dialog windows not destroyed but just hidden. *)
      match Sdl.get_keyboard_focus () with
      | Some w when Sdl.get_window_id w = winid -> true
      | _ ->
          match Sdl.set_window_input_focus self#window with
          | Error (`Msg msg) -> Log.err (fun m -> m "%s: %s" self#me msg); false
          | Ok () -> true (*super#grab_focus ?last ()*)

    (* Give focus to the first focusable widget, using grab_focus on
       child. *)
    method! child_focus_next (w:Widget.widget) = w#grab_focus ()
    method! child_focus_prev (w:Widget.widget) = w#grab_focus ~last:true ()

    val mutable last_key_event = None

    method on_window_event (e:Sdl.event) =
      let must_render =
        match Sdl.Event.(window_event_enum (get e window_event_id)) with
        | `Close ->
            (
             let keep = self#trigger_event Close () in
             [%debug "%s: `Close event => keep = %b" self#me keep];
             match keep with
             | true -> true
             | false -> self#close ; false
            )
        | `Enter ->
            (* when entering a window with a button pressed on another one and
               not released, the `Enter event occurs only when releasing the button,
               and mouse_state coords seem to refer to previous window;
               we use global state and convert to our window coordinates *)
            let (_,(x,y)) = Sdl.get_global_mouse_state () in
            let (wx, wy) = Sdl.get_window_position win in
            let pos = (x - wx, y - wy) in
            let _ = self#on_sdl_event_down ~oldpos:None (Some pos) e in
            false
        | `Exposed -> true
        | `Focus_gained ->
            let _ =
              (* if a key is already pressed, set last_key_event to
                 `Keyboard_state to block key press events which occured
                 when another window had the focus. Indeed, since the
                 key may still be pressed, the window gaining the focus will receive
                 key press events, which is not what we want. So we will block
                 key press events when the keyboard_state is the same as when we
                 got the focus, except is there is no key pressed.*)
              let state = Sdl.get_keyboard_state() in
              if not (keyboard_state_empty state) then
                last_key_event <- Some (`Keyboard_state state);
              self#set_p Props.has_focus true ;
              match self#set_has_focus true with
              | true -> true (* has_focus was set on a widget *)
              | false ->
                  (* no widget already has the focus previously, let's use
                     grab_focus to give to the first one *)
                  super#grab_focus ()
            in
            [%debug "%s: focus gained %a" self#me Widget.pp_widget_tree self#wtree] ;
            false
        | `Focus_lost ->
            [%debug "%s: focus lost" self#me] ;
            self#set_p Props.has_focus false ;
            let _ = self#set_has_focus false in
            false
        | `Hidden
        | `Hit_test
        | `Leave ->
            let _ = self#on_sdl_event_down ~oldpos:None None e in
            false
        | `Maximized
        | `Minimized -> self#update_geometry () ; true
        | `Moved -> false
        | `Resized -> self#update_geometry () ; true
        | `Restored
        | `Shown ->
            let _ = self#on_sdl_event_down ~oldpos:None None e in
            false
        | `Size_changed ->
            self#update_geometry () ; true
        | `Take_focus
        | `Unknown _ -> false
      in
      if must_render then
        (
         self#need_render ~layer:Layer.Base g;
        )

    method on_root_event ~oldpos pos ev =
      let ev_type = Sdl.Event.(enum (get ev typ)) in
      (*Log.warn (fun m -> m "%s#on_root_event last_key_event=%s"
        self#me (match last_key_event with
          | None -> "NONE"
          | Some `Text_editing -> "`Text_editing"
          | Some `Text_input -> "`Text_input"
          | Some `Handled_key_press -> "`Handled_key_press"));*)
      match ev_type, last_key_event with
      | `Text_input, Some `Handled_key_press ->
          (*Log.warn (fun m -> m "text_input event blocked");*)
          false
      | `Key_down, Some `Keyboard_state st when st = Sdl.get_keyboard_state () ->
          [%debug "key press blocked according to keyboard state"];
          false
      | `Key_down, Some `Text_editing ->
          (*Log.warn (fun m -> m "key_down event blocked");*)
          false
      | _ ->
          let handled = self#on_sdl_event_down ~oldpos pos ev in
          (* block next text input event if key_down was handled, unblock
             when a key_down event was not handled *)
          match ev_type with
          | `Key_down ->
              let () =
                match handled, last_key_event with
                | false, Some _ -> last_key_event <- None;
                | false, None -> ()
                | true, _ when Sdl.is_text_input_active () ->
                    last_key_event <- Some `Handled_key_press
                | true, Some _ -> last_key_event <- None
                | true, None -> ()
              in
              handled
          | `Key_up ->
              last_key_event <- None;
              handled
          |  `Text_input ->
              last_key_event <- Some `Text_input;
              handled
          | `Text_editing when Sdl.Event.(get ev text_editing_length) = 0 ->
              (* to pump spurious Text_editing events when window gets the focus *)
              handled
          | `Text_editing ->
              last_key_event <- Some `Text_editing;
              handled
          | _ ->
              handled

    method! render_child ~layer rend ~offset ~g_none ~g_child =
      try super#render_child ~layer rend ~offset ~g_none ~g_child
      with e ->
        Log.err (fun m -> m "%s#render_child: %s %s" self#me (Printexc.to_string e)
          (Printexc.get_backtrace()));

    method render_window ?layers () =
      [%debug "%s#render" self#me];
      try
        (match Sdl.get_renderer_info renderer with
         | Error (`Msg msg) -> Log.err (fun m -> m "self#me: renderer_info: %s" msg)
         | _ -> ()
        );
        let> () = Sdl.set_render_target renderer None in
        let geom =
          let (w, h) = self#size in
          let g = { G.x = 0 ; y = 0 ; w ; h } in
          [%debug "%s#render g=%a" self#me G.pp g];
          match layers with
          | None ->
              [%debug "%s#render_window reset-painting %a"
                 self#me G.pp g];
              Render.fill_rect renderer None self#bg_color_now;
              self#render_child ~layer:Layer.Base renderer
                ~offset:(0,0) ~g_none:g ~g_child:g;
              Some g
          | Some map ->
              Layer.Map.fold
                (fun layer g_to_render acc ->
                   [%debug "%s#render layer=%a g_to_render=%a"
                      self#me Layer.pp layer G.pp g];
                   match G.inter g g_to_render with
                   | None -> None
                   | Some g ->
                       if layer = Layer.Base then
                         (
                          [%debug "%s#render_window reset-painting %a"
                           self#me G.pp g];
                          Render.fill_rect renderer (Some g) self#bg_color_now
                         );
                       self#render_child ~layer renderer
                         ~offset:(0,0)
                         ~g_none:g ~g_child:g;
                       match acc with
                       | None -> Some g
                       | Some acc -> Some (G.union g acc))
                map None
        in
        (*let> () = Sdl.set_render_target renderer None in
        let> () = Sdl.render_set_clip_rect renderer None in*)
        match geom with
        | None ->
            [%debug "%s#render: nothing to render" self#me]
        | Some geom ->
            [%debug "%s render_copy and present %a"
               self#me G.pp geom];
            if not self#sensitive then
              self#render_insensitive renderer ~offset:(0,0) geom;
            Sdl.render_present renderer
      with
      | e ->
          Log.err (fun m -> m "%s#render_window: %s" self#me (Printexc.to_string e))

    method render ~layer renderer ~offset g =
      [%debug "%s#render should not be called" self#me]

    method render_if_needed =
      if not (Layer.Map.is_empty to_render) then
        (
          let layers = to_render in
          to_render <- Layer.Map.empty ;
          self#render_window ~layers ()
        )

    method! destroy =
      (try super#destroy
       with e  -> Log.err (fun m -> m "%s#destroy: %s" self#me
         (Printexc.to_string e))
      );
      Sdl.destroy_window win

    method add_to_render ~layer g =
      [%debug "%s#add_to_render ~layer:%a %a"
         self#me Layer.pp layer G.pp g];
      (match layer with
       | Layer.Base -> self#add_to_render ~layer:Layer.Menu g
       | Layer.Menu -> ()
      );
      match Layer.Map.find_opt layer to_render with
      | None ->
          if g.w = 0 || g.h = 0 then
            ()
          else
            to_render <- Layer.Map.add layer g to_render
      | Some gr ->
          let res = G.union g gr in
          [%debug "%s#add_to_render ~layer:%a => %a"
               self#me Layer.pp layer G.pp res];
          to_render <- Layer.Map.add layer res to_render

    method need_render ~layer geom =
      match self#need_rendering geom with
      | None -> ()
      | Some geom -> self#add_to_render ~layer geom

(*    method child_need_render ~layer geom =
      [%debug "%s#child_need_render ~layer:%a on %a"
         self#me Layer.pp layer G.pp geom);
  *)

    (**/**)

    (** Show SDL window.*)
    method show = Sdl.show_window win

    (** Hide SDL window. *)
    method hide = Sdl.hide_window win

    (** [w#move ~x ~y] moves SDL window to [(x,y)]. *)
    method move ~x ~y =
      [%debug "%s#move ~x:%d ~y:%d" self#me x y];
      Sdl.set_window_position win ~x ~y

    initializer
      (* window will not be parented, so we must apply theme at creation *)
      self#apply_theme ;
      with_renderer <- Some with_renderer_lock ;
      self#update_geometry ();
      (* we must pump events and move again the window or else
         something goes wrong with sdl and window manager, window
         is not placed where asked. *)
      match x, y with
      | Some x, Some y -> Tsdl.Sdl.pump_events () ;self#move ~x ~y
      | _ -> ()
  end

(**/**)
let window ?classes ?name ?props ?wdata ?flags ?rflags ?resizable ?(show=true) ?x ?y ?w ?h title =
  let w = new window ?classes ?name ?props ?wdata ?flags ?rflags ?resizable ?x ?y ?w ?h title in
  if not show then w#hide;
  w