  This file is part of BOGUE , by San Vu Ngoc

(* Each widget contains its personal data, and the list of connections from
   it *)

open Tsdl
open B_utils
module Avar = B_avar
module Utf8 = B_utf8
module Var = B_var
module Tvar = B_tvar
module Timeout = B_timeout
module Trigger =  B_trigger
module Draw = B_draw
module Empty = B_empty
module Image = B_image
module Box = B_box
module Sdl_area = B_sdl_area
module Label = B_label
module Button = B_button
module Slider = B_slider
module Check = B_check
module Text_display = B_text_display
module Text_input = B_text_input

type kind =
  | Empty of Empty.t
  | Box of Box.t
  | Button of Button.t
  | Check of Check.t
  | Label of Label.t
  | TextDisplay of Text_display.t
  | Image of Image.t
  | Slider of Slider.t
  | TextInput of Text_input.t
  | SdlArea of Sdl_area.t

(* What to do when the same action (= same connection id) is already running? *)
type action_priority =
  | Forget (* discard the new action *)
  execute the new after the first one has completed
  kill the first action ( if possible ) and execute the second one
  | Main (* run in the main program. So this is blocking for all subsequent
            actions *)

type active = {
    thread : Thread.t;
    (* [thread] is the thread launched by the connection with given id *)
    event : Sdl.event;
    (* [event] is the event passed to the "action".  It is used also for
       communication *)
    connect_id : int
  }

type action = t -> t -> Sdl.event -> unit

and connection = {
  source : t;
  target : t;
  action : action;
  priority : action_priority;
  triggers : Trigger.t list;
  id : int;
}

and t = {
  kind : kind;
  receiver : action Event.channel ;
  actives : (active list) Var.t;
  [ actives ] lists all active threads / connections for this widget . Most recent 
      come first in the list
     come first in the list *)
  mutable connections : connection list;
  (* the [connections] field lists all possible connections from this widget. In
     the order to be executed. Particular case: the local actions are connection
     from and to the same widget. *)
  (* mutable à cause de définition cyclique *)
  wid : int;
  mutable fresh : bool Var.t; (* is the display up-to-date? *)
  (* not really used anymore. TODO: check if this flag is still used *)
  mutable room_id : int option;
  (* [room_id] will be filled by the room id when inserted in that room *)
  mutable cursor : Sdl.cursor option
  (* use [cursor] to override the default mouse cursor *)
}

let draw_boxes = ref false
(* for debugging: draws a red rectangle around each widget layout, (fill when it
   has mouse focus (might need a redraw: CTRL-l) and a blue rect around
   container layouts *)

let id w = w.wid

let get_room_id w = match w.room_id with
  | None -> failwith "The widget does not belong to a room yet"
  | Some id -> id

let equal w1 w2 =
  w1.wid = w2.wid
let (==) = equal

type widget = t

module Hash = struct
  type t = widget
  let equal = equal
  let hash = id
end

module WHash = Weak.Make(Hash)
let widgets_wtable = WHash.create 100

let string_of_kind = function
  | Empty _ -> "Empty"
  | Box _ -> "Box"
  | Button _ -> "Button"
  | Check _ -> "Check"
  | TextDisplay _ -> "TextDisplay"
  | Label l -> "Label [" ^ xterm_red ^ (Label.text l) ^ xterm_nc ^ "]"
  | Image _ -> "Image"
  | Slider _ -> "Slider"
  | TextInput _ -> "TextInput"
  | SdlArea _ -> "SdlArea"

(* When to use this??? *)
(* in particular, when this function is called, the widget w in principle has
   already been removed from widgets_wtable *)
let free w =
  printd debug_memory "Freeing widget #%u" w.wid;
  match w.kind with
  | Empty e -> Empty.free e
  | Box b -> Box.free b
  | Check b -> Check.free b
  | Button b -> Button.free b
  | TextDisplay t -> Text_display.free t
  | Image img -> Image.free img
  | Label l -> Label.free l
  | Slider s -> Slider.free s
  | TextInput ti -> Text_input.free ti
  | SdlArea a -> Sdl_area.free a

let is_fresh w = Var.get w.fresh

(* let canvas w = match w.canvas with *)
(*   | Some c -> c *)
(*   | None -> failwith "Canvas not defined";; *)

(* let renderer w = *)
(*   (canvas w).Draw.renderer;; *)

  let   w =
(*   w.canvas <- Some canvas;; *)

let fresh_id = fresh_int ()
let fresh_wid = fresh_int ()

let create_empty kind =
  let wid = fresh_wid () in
  let w =
    { kind;
      wid;
      actives = Var.create [];
      fresh = Var.create false;
      connections = [];
      room_id = None;
      cursor = None;
    } in
  WHash.add widgets_wtable w;
  (*Gc.finalise free w;*) (* TODO: NOT A GOOD IDEA as this will ask to destroy
                             textures that maybe were already destroyed when the
                             window was closed *)
  (* However if we don't do this there is a risk that some textures are never
     freed (as long as the renderer is not destroyed) *)
  w

let dummy_widget = create_empty (Empty (Empty.create (0,0)))

let of_id wid = Hashtbl.find widgets_table wid ; ;
let of_id wid : t =
  try WHash.find widgets_wtable {dummy_widget with wid} with
  | Not_found -> (printd debug_error "Cannot find widget with wid=%d" wid;
                  raise Not_found)

(* unload all textures but the widget remains usable. (Rendering will recreate
   all textures) *)
let unload_texture w =
  printd debug_memory "Unloading texture for widget #%u" w.wid;
  match w.kind with
  | Empty b -> Empty.unload b
  | Box b -> Box.unload b
  | Check b -> Check.unload b
  | Button b -> Button.unload b
  | TextDisplay t -> Text_display.unload t
  | Image img -> Image.unload img
  | Label l -> Label.unload l
  | Slider s -> Slider.unload s
  | TextInput ti -> Text_input.unload ti
  | SdlArea a -> Sdl_area.unload a

let default_size w =
  match w.kind with
  | Empty e -> Empty.size e
  | Check b -> Check.size b
  | Box b -> Box.size b
  | TextDisplay td -> Text_display.size td
  | Label l -> let x,y = Label.size l in (x+2,y+2)
  | Image img -> Image.size img
  | Button b -> Button.size b
  | Slider s -> Slider.size s
  | TextInput ti -> Text_input.size ti
  | SdlArea a -> Sdl_area.size a

let size = default_size

let resize w size =
  match w.kind with
  | Empty e -> Empty.resize size e
  | Box b -> Box.resize size b
  | Button b -> Button.resize size b
  | Check c -> Check.resize size c
  | Label l -> Label.resize size l
  | TextDisplay t -> Text_display.resize size t
  | Image i -> Image.resize size i
  | Slider s -> Slider.resize size s
  | TextInput ti -> Text_input.resize size ti
  | SdlArea a -> Sdl_area.resize size a

let get_cursor w =
  default w.cursor
    (match w.kind with
     | Empty _
     | Box _
     | Label _
     | TextDisplay _
     | SdlArea _
     | Image _ -> go (Draw.create_system_cursor Sdl.System_cursor.arrow)
     | Button _
     | Check _
     | Slider _ -> go (Draw.create_system_cursor Sdl.System_cursor.hand)
     | TextInput _ -> go (Draw.create_system_cursor Sdl.System_cursor.ibeam)
    )

let set_cursor w cursor =
  w.cursor <- cursor

let display canvas layer w geom =
  Var.set w.fresh true;
  let geom = Draw.scale_geom geom in
  match w.kind with
  | Empty e -> printd debug_board "empty box";
    Empty.display canvas layer e geom
  | Box b -> printd debug_board "draw box";
    Box.display canvas layer b geom
  | Check b -> printd debug_board "check button: %b" (Check.state b);
    Check.display canvas layer b geom
  | SdlArea a -> printd debug_board "render SDL area";
    Sdl_area.display w.wid canvas layer a geom
  | Button b -> printd debug_board "button [%s]" (Button.text b);
    Button.display canvas layer b geom
  | TextDisplay td ->
    printd debug_board "text display: %s" (Text_display.text td);
    Text_display.display canvas layer td geom
  | Image img -> printd debug_board "image: %s" (Image.get_file img);
    Image.display canvas layer img geom
  | Label l -> printd debug_board "label: %s" (Label.text l);
    Label.display canvas layer l geom
  | Slider s -> printd debug_board "slider: %d" (Slider.value s);
    Slider.display canvas layer s geom
  | TextInput ti -> printd debug_board "Input: %s" (Text_input.text ti);
    Text_input.display canvas layer ti geom

(** ask for refresh *)
(* Warning: this is frequently called by other threads *)
(* Warning: this *resets to 0* the user_window_id *)
(* anyway, it is not clear if the user_window_id field for created event types
   is really supported by (T)SDL *)
let update w =
  printd debug_board "Please refresh widget #%i" w.wid;
  Var.set w.fresh false;
  (* if !draw_boxes then Trigger.(push_event refresh_event) *)
  (* else *)
  Trigger.push_redraw w.wid
  TODO ... use wid et / ou window_id ...
(* refresh is not used anymore. We redraw everyhting at each frame ... *)
(* before, it was not very subtle either: if !draw_boxes is false, we ask for
   clearing the background before painting. Maybe some widgets can update
   without clearing the whole background. But those with some transparency
   probably need it. This should not be necessary in case we draw a solid
   background -- for instance if draw_boxes = true *)


(** create new connection *)
  if ~join : c , on donne le même i d que la connexion c , ce qui permet 
    d'effectuer       ( avec en général 
    la priorité Join pour effectuer à la suite de c ) . Attention dans ce 
    cas , ne pas déclancher plein de ces connexions à la suite ... elles 
    s'attendent !
   d'effectuer l'action conjointement avec celle de c (avec en général
   la priorité Join pour effectuer à la suite de c). Attention dans ce
   cas, ne pas déclancher plein de ces connexions à la suite... elles
   s'attendent ! *)
let connect source target action ?(priority=Forget) ?(update_target=true) ?join triggers =
  let action = if update_target
  TODO ajouter  ev ? ?
    else action in
  let action = if !debug
    then fun w1 w2 ev ->
      (printd debug_thread "Executing action";
       let t = Unix.gettimeofday () in
       action w1 w2 ev;
       printd debug_thread "End of action with time=%f" (Unix.gettimeofday () -. t))
    else action in
  let id = match join with
    | None -> fresh_id ()
    | Some c -> c.id in
  { source;
    target;
    action;
    priority;
    triggers;
    id }

let connect_after source target action triggers =
  match List.rev source.connections with
    | [] -> connect source target action ~priority:Join triggers
    | c::_ -> connect source target action ~priority:Join ~join:c triggers

let connect_main = connect ~priority:Main

let connections t =
  t.connections

(* TODO à faire automatiquement après "connect" ? *)
(* Not thread safe, should be used only in main thread. *)
let add_connection w c =
  if List.exists (fun cc -> cc.id = c.id) w.connections
  then printd (debug_error + debug_user) "Connection is already present in widget"
  else w.connections <- List.rev (c :: List.rev w.connections)

(* Remove connection. Not thread safe, should be used only in main thread. *)
let remove_connection w c =
  let clist = List.filter (fun cc -> cc.id <> c.id) w.connections in
  if List.compare_lengths clist w.connections <> 0
  then w.connections <- clist
  else printd (debug_error + debug_user)
      "Cannot remove connection because it is not present in the widget."

(* Remove all connection that respond to the given trigger (=event) *)
let remove_trigger w tr =
  let clist = List.filter (fun cc -> not (List.mem tr cc.triggers)) w.connections in
  if List.compare_lengths clist w.connections <> 0
  then w.connections <- clist
  else printd (debug_warning + debug_user)
      "[remove_trigger] There is no trigger of that kind in the list of connections."

let get_box w =
  match w.kind with
  | Box b -> b
  | _ -> invalid_arg "Expecting a box, not a %s" (string_of_kind w.kind)

let get_check w =
  match w.kind with
    | Check b -> b
    | _ -> invalid_arg "Expecting a check box, not a %s" (string_of_kind w.kind)

let get_label w =
 match w.kind with
    | Label l -> l
    | _ -> invalid_arg "Expecting a label, not a %s" (string_of_kind w.kind)

let get_button w =
  match w.kind with
    | Button b -> b
    | _ -> invalid_arg "Expecting a button, not a %s" (string_of_kind w.kind)

let get_slider w =
 match w.kind with
    | Slider s -> s
    | _ -> invalid_arg "Expecting a slider, not a %s" (string_of_kind w.kind)

let get_text_display w =
 match w.kind with
    | TextDisplay td -> td
    | _ -> invalid_arg "Expecting a text display, not a %s" (string_of_kind w.kind)

let get_text_input w =
 match w.kind with
    | TextInput ti -> ti
    | _ -> invalid_arg "Expecting a text input, not a %s" (string_of_kind w.kind)

let get_image w =
 match w.kind with
   | Image im -> im
   | _ -> invalid_arg "Expecting an image, not a %s" (string_of_kind w.kind)

let get_sdl_area w =
  match w.kind with
  | SdlArea a -> a
  | _ -> invalid_arg "Expecting an Sdl_area, not a %s" (string_of_kind w.kind)

(** creation of simple widgets *)
let check_box ?state ?style () =
  let b = create_empty  (Check (Check.create ?state ?style ())) in
  let action = fun w _ _ -> Check.action (get_check w) in
  let c = connect_main b b action Trigger.buttons_down in
  add_connection b c;
  b


(*let get_check_state b =
  Check.state (get_check b)
*)

let set_check_state b s =
  Check.set (get_check b) s

let empty ~w ~h () =
  create_empty (Empty (Empty.create (w,h)))

let text_display ?w ?h text =
  create_empty (TextDisplay (Text_display.create_from_string ?w ?h text))

let rich_text ?size ?w ?h paragraphs =
  create_empty (TextDisplay (Text_display.create ?size ?w ?h paragraphs))

let lines_display ?w ?h lines =
  create_empty (TextDisplay (Text_display.create_from_lines ?w ?h lines))

let verbatim text =
  create_empty (TextDisplay (Text_display.create_verbatim text))

let html ?w ?h text =
  create_empty (TextDisplay (Text_display.create_from_html ?w ?h text))

let box ?w ?h ?style () =
  create_empty (Box (Box.create ?width:w ?height:h ?style ()))

let sdl_area ~w ~h ?style () =
  create_empty (SdlArea (Sdl_area.create ~width:w ~height:h ?style ()))

let label ?size ?fg ?font ?align text =
  create_empty (Label (Label.create ?size ?fg ?font ?align text))

(* alias for fontawesome icon labels *)
let icon ?size ?fg name =
  create_empty (Label (Label.icon ?size ?fg name))

let image ?w ?h ?bg ?noscale ?angle file =
  create_empty (Image (Image.create ?width:w ?height:h ?bg ?noscale ?angle file))

let image_from_svg ?w ?h ?bg file =
  let svg = Draw.convert_svg ?w ?h file in
  let w,h = Draw.unscale_size (Draw.image_size svg) in
  image ~w ~h ?bg svg

let image_copy ?rotate w =
  create_empty (Image (Image.copy ?rotate (get_image w)))

(* action is executed "on release" (mouse or keyboard). If you need an action
   that depends on the button itself, use on_button_release instead.  *)
let button ?(kind = Button.Trigger) ?label ?label_on ?label_off
    ?fg ?bg_on ?bg_off ?bg_over ?state
    ?border_radius ?border_color ?action text =
  let b = create_empty
      (Button (Button.create ?label ?label_on ?label_off ?fg
                 ?bg_on ?bg_off ?bg_over
                 ?border_radius ?border_color ?state ?action kind text)) in
  let press = fun _ _ _ -> Button.press (get_button b) in
  let c = connect_main b b press Trigger.buttons_down in
  add_connection b c;
  let release = match kind with (* move this test to Button ? *)
    | Button.Trigger -> fun _ _ _ -> Button.release (get_button b)
    | Button.Switch -> fun _ _ ev -> Button.switch (get_button b) ev
  in
  let c = connect_main b b release Trigger.buttons_up in
  add_connection b c;
  let c = connect_main b b (fun b _ _ -> Button.mouse_enter (get_button b))
      [Trigger.mouse_enter] in
  add_connection b c;
  let c = connect_main b b (fun b _ _ -> Button.mouse_leave (get_button b))
      [Trigger.mouse_leave] in
  add_connection b c;
  let c = connect_main b b (fun b _ ev -> Button.receive_key (get_button b) ev)
      [Trigger.key_down; Trigger.key_up] in
  add_connection b c;
  b

(* use ~lock if the user is not authorized to slide *)
let slider ?(priority=Main) ?step ?value ?kind ?var ?length ?thickness
      ?tick_size ?(lock = false) ?w ?h maxi =
  let w = create_empty (Slider (Slider.create ?step ?value ?kind ?var ?length
                                  ?thickness ?tick_size ?w ?h maxi)) in
  if not lock then begin
      let onbutton_down = fun w _ ev -> Slider.click (get_slider w) ev in
      let c = connect_main w w onbutton_down Trigger.buttons_down in
      add_connection w c;
      (* let onclick = fun w _ ev -> Slider.click_focus (get_slider w) ev in *)
  let c = connect_main w w onclick [  . Event.mouse_button_up ] in
      (* add_connection w c; *)
      let on_release = fun w _ _ -> Slider.release (get_slider w) in
      let c = connect_main w w on_release Trigger.buttons_up in
      add_connection w c;
      let slide = fun w _ ev ->
        let ti = get_slider w in
        if Trigger.mm_pressed ev || Trigger.event_kind ev = `Finger_motion
        then (Slider.slide ti ev; update w)
      in
      let c = connect ~priority ~update_target:false w w slide Trigger.pointer_motion in
      add_connection w c;
      let get_keys = fun w _ ev -> Slider.receive_key (get_slider w) ev
      in
      let c = connect ~priority w w get_keys [Sdl.Event.key_down] in
      add_connection w c
    end;
  w

  create a slider with a simple Tvar that executes an action each time the 
    local value of the slider is modified by the slider
   local value of the slider is modified by the slider *)
let slider_with_action ?priority ?step ?kind ~value ?length ?thickness ?tick_size
    ~action max =
  let v = Var.create (Avar.var value) in
  let t_from a = Avar.get a in
  let t_to x = action x; Avar.var x in
  let var = Tvar.create v ~t_from ~t_to in
  slider ?priority ?step ?kind ~var ?length ?thickness ?tick_size max

let text_input ?(text = "") ?prompt ?size ?filter ?max_size () =
  let ti = Text_input.create ?size ?prompt ?filter ?max_size text in
  let w = create_empty (TextInput ti) in
  let onbutton_down = fun w _ ev ->
    let ti = get_text_input w in (* = ti ! *)
    Text_input.button_down ti ev in
  let c = connect_main w w onbutton_down Trigger.buttons_down in
  add_connection w c;
  let onclick = fun w _ ev ->
    let ti = get_text_input w in (* = ti ! *)
    Text_input.click ti ev in
  let c = connect_main w w onclick Trigger.buttons_up in
  add_connection w c;
  let ontab = fun w _ ev ->
    let ti = get_text_input w in (* = ti ! *)
    Text_input.tab ti ev in
  let c = connect_main w w ontab [Sdl.Event.key_down] in
  add_connection w c;
  let selection = fun w _ ev ->
    let ti = get_text_input w in (* = ti ! *)
    if Trigger.mm_pressed ev then (Text_input.mouse_select ti ev; update w)
  in
  let c = connect_main ~update_target:false w w selection [Sdl.Event.mouse_motion] in
  add_connection w c;
  let get_keys = fun w _ ev -> Text_input.receive_key (get_text_input w) ev
  in
  let c2 = connect_main w w get_keys [Sdl.Event.text_editing; Sdl.Event.text_input; Sdl.Event.key_down; Sdl.Event.key_up] in
  add_connection w c2;
  w


  Some generic functions or ' methods ' that can make sense for one or several 
    types of widgets
   types of widgets *)

let get_text w =
  match w.kind with
  | Button b -> Button.text b
  | TextDisplay td -> Text_display.text td
  | Label l -> Label.text l
  | TextInput ti -> Text_input.text ti
  | _ -> (printd debug_error "This type of widget does not have a text function";
          "")

let set_text w text =
  match w.kind with
  | Button b -> Button.set_label b text
  | TextDisplay td -> let pa = Text_display.paragraphs_of_string text in
    Text_display.update td pa
  | Label l -> Label.set l text
  | TextInput ti -> let k = Utf8.split text in
    Text_input.set ti k
  | _ -> printd debug_error "Cannot set text to this type of widget"

let get_state w =
  match w.kind with
  | Button b -> Button.state b
  | Check c -> Check.state c
  | _ -> (printd debug_error "This type of widget does not have a state function";
          false)

let set_state w s =
  match w.kind with
  | Button b -> Button.set b s
  | Check c -> Check.set c s
  | _ -> (printd debug_error "Cannot set the state for this type of widget.")

(** creation of combined widgets *)
let check_box_with_label text =
  let b = check_box () in
  let l = label text in
  let action = fun _ w _ -> Check.action (get_check w) in
  let c = connect_main l b action Trigger.buttons_down in
  add_connection l c;
  b,l

(****)

(* some useful connections *)
  the disadvantage is that these functions do not take advantage of the two 
    widgets + event entry . Thus they are less ' functional ' and require more 
    global variables ( closures ) . Also , they all work with " connect_main " , so are 
    ok only for very fast actions .
   widgets + event entry. Thus they are less 'functional' and require more
   global variables (closures). Also, they all work with "connect_main", so are
   ok only for very fast actions. *)

let mouse_over ?(enter = nop) ?(leave = nop) w =
  let c = connect w w (fun w _ _ -> enter w) [Trigger.mouse_enter] in
  add_connection w c;
  let c' = connect w w (fun w _ _ -> leave w) [Trigger.mouse_leave] in
  add_connection w c'

let on_click ~click w =
  let c = connect_main w w (fun w _ _ -> click w) Trigger.buttons_down in
  add_connection w c

let on_release ~release w =
  let c = connect_main w w (fun w _ _ -> release w)
      Trigger.buttons_up in
  add_connection w c

let on_button_release ~release w =
  let c = connect_main w w (fun w _ ev ->
      if Trigger.of_event ev <> Trigger.key_up
      || Button.check_key (get_button w) ev
      then release w) (Trigger.key_up :: Trigger.buttons_up) in
  add_connection w c

(****)

* check if connection is in the active list , and return the most 
     recent (= first in list ) active , or None
    recent (=first in list) active, or None *)
let is_active alist c =
  let rec loop = function
    | [] -> None
    | a::rest -> if a.connect_id = c.id then Some a else loop rest
  in loop alist

(** remove an 'active' from the active list of the widget *)
(* it should occur only once in the list *)
let remove widget thread_id =
  let rec loop list acc = match list with
    | [] -> acc
    | a::rest -> (* if a.connect_id = active.connect_id *)
      (* test inutile, le suivant suffit *)
      if Thread.id a.thread = thread_id
      then List.concat [List.rev rest; acc]
      else loop rest (a::acc)
  in Var.set widget.actives (List.rev (loop (Var.get widget.actives) []))

let add widget active =
  Var.set widget.actives (active :: (Var.get widget.actives))

(** ask a thread to remove itself from a widget *)
let remove_me c_id widget =
  printd debug_thread "Removing connection #%d" c_id;
  remove widget (Thread.id (Thread.self ()));
  decr threads_created

(* check if connection is terminated *)
(* (only if the thread decided to signal this, for instance by setting the event
   to Trigger.stopped) *)
let has_terminated active =
  Sdl.Event.(get active.event typ) <> Trigger.stop

(* indicate to an active connection that its thread should terminate *)
  TODO protect this with mutex or Var
let terminate ?(timeout = 50) active =
  printd debug_thread "Ask for terminating connection #%u" active.connect_id;
  Sdl.Event.(set active.event typ) Trigger.stop;
  ignore (Timeout.add timeout (fun () ->
              if not (has_terminated active)
              then printd debug_thread "Cannot terminate thread for connection #%u after %u ms." active.connect_id timeout
    ))

(* ask for terminate and wait (blocking) until it really terminates by itself *)
let wait_terminate active =
  terminate active;
  Thread.join active.thread

(** activate an action (via a thread) on the connection *)
let add_action c action ev =
  printd debug_thread "Create thread for connection #%d" c.id;
  (* Trigger.renew_my_event (); *)
  (* we used to create a new event for the main loop, so that "ev" can be safely
     sent to the thread, and the thread can examine later, even after several
     main loops, without it being altered (except when exiting is required) *)
  (* Now we use a more natural, solution would be to copy the event before
     sending it to the thread, but there is no "copy_event" function
     available... *)
  WARNING : at this point it is not possible to copy the drop_file_file field
  let e_copy = Trigger.copy_event ev in
  incr threads_created;
  add c.source
    { thread = Thread.create (action c.source c.target) e_copy;
      event = e_copy;
      connect_id = c.id }

(** check if the trigger can wake up a connection, and if so, run the action *)
let wake_up event c =
  if List.mem (Trigger.of_event event) c.triggers then
    begin
      printd debug_thread "Activating connection #%d" c.id;
  TODO add a more precise ~test before launching the thread ?
      if c.priority = Main then c.action c.source c.target event
      (* = direct action, no thread! Should we still add it to the active list?
      *)
      else begin
        let action = fun w1 w2 ev ->
          c.action w1 w2 ev;
          remove_me c.id w1 in
        let alist = Var.get c.source.actives in
        let tho = is_active alist c in
        if alist = [] || tho = None then add_action c action event
        else match c.priority, tho with
          | Forget, _ -> printd debug_thread "Forgetting connection #%d" c.id
          | Join, Some a ->
            let action = fun w1 w2 ev -> (Thread.join a.thread; action w1 w2 ev) in
            add_action c action event
          | Replace, Some a -> begin
  printd debug_thread " Killing connection # % d " a.connect_id ;
              (* Thread.kill a.thread; *) (* Thread.kill is in fact NOT
                                             implemented... ! *)
              terminate a;
              remove c.source (Thread.id a.thread);
              add_action c action event
            end
          | _ -> failwith "This should not happen"
      end
    end

let wake_up_all ev w =
  List.iter (wake_up ev) w.connections

(** remove all active connections from this widget and ask for the threads to
    terminate *)
let remove_active_connections widget =
  let actives = Var.get widget.actives in
  List.iter wait_terminate actives;
  Var.set widget.actives []


(*******************)

  Some widgets directly react to a click event to activate themselves . Some , 
    like text_input , even react to the TAB key . In fact , keyboard_focus is 
    treated globally by the main loop , therefore one could ( should ? ) rely on 
    this function below instead of adding new reactions to TAB & click
   like text_input, even react to the TAB key. In fact, keyboard_focus is
   treated globally by the main loop, therefore one could (should?) rely on
   this function below instead of adding new reactions to TAB & click *)
let set_keyboard_focus w =
  match w.kind with
  | TextInput _ -> () (* already done by the widget *)
  | Slider s -> Slider.set_focus s
  | Button b -> Button.set_focus b
  | _ -> ()

let remove_keyboard_focus w =
  match w.kind with
  | TextInput ti -> Text_input.stop ti
  | Slider s -> Slider.unfocus s
  | Button b -> Button.unfocus b
  | _ -> ()

let guess_unset_keyboard_focus w =
  match w.kind with
  | TextInput _ -> Some false
  | Slider _ -> Some false
  | Button _ -> Some false
  | _ -> None

(*************************)
(* Some examples of "pure" actions (actions that don't depend on external
   variables) *)

let copy_text w1 w2 _ =
  let text = get_text w1 in
  set_text w2 text

let map_text f w1 w2 _ =
  let text = get_text w1 in
  set_text w2 (f text)

 Each widget contains its personal data, and the list of connections from
   it 
 What to do when the same action (= same connection id) is already running? 
 discard the new action 
 run in the main program. So this is blocking for all subsequent
            actions 
 [thread] is the thread launched by the connection with given id 
 [event] is the event passed to the "action".  It is used also for
       communication 
 the [connections] field lists all possible connections from this widget. In
     the order to be executed. Particular case: the local actions are connection
     from and to the same widget. 
 mutable à cause de définition cyclique 
 is the display up-to-date? 
 not really used anymore. TODO: check if this flag is still used 
 [room_id] will be filled by the room id when inserted in that room 
 use [cursor] to override the default mouse cursor 
 for debugging: draws a red rectangle around each widget layout, (fill when it
   has mouse focus (might need a redraw: CTRL-l) and a blue rect around
   container layouts 
 When to use this??? 
 in particular, when this function is called, the widget w in principle has
   already been removed from widgets_wtable 
 let canvas w = match w.canvas with 
   | Some c -> c 
   | None -> failwith "Canvas not defined";; 
 let renderer w = 
   (canvas w).Draw.renderer;; 
   w.canvas <- Some canvas;; 
Gc.finalise free w;
 TODO: NOT A GOOD IDEA as this will ask to destroy
                             textures that maybe were already destroyed when the
                             window was closed 
 However if we don't do this there is a risk that some textures are never
     freed (as long as the renderer is not destroyed) 
 unload all textures but the widget remains usable. (Rendering will recreate
   all textures) 
* ask for refresh 
 Warning: this is frequently called by other threads 
 Warning: this *resets to 0* the user_window_id 
 anyway, it is not clear if the user_window_id field for created event types
   is really supported by (T)SDL 
 if !draw_boxes then Trigger.(push_event refresh_event) 
 else 
 refresh is not used anymore. We redraw everyhting at each frame ... 
 before, it was not very subtle either: if !draw_boxes is false, we ask for
   clearing the background before painting. Maybe some widgets can update
   without clearing the whole background. But those with some transparency
   probably need it. This should not be necessary in case we draw a solid
   background -- for instance if draw_boxes = true 
* create new connection 
 TODO à faire automatiquement après "connect" ? 
 Not thread safe, should be used only in main thread. 
 Remove connection. Not thread safe, should be used only in main thread. 
 Remove all connection that respond to the given trigger (=event) 
* creation of simple widgets 
let get_check_state b =
  Check.state (get_check b)

 alias for fontawesome icon labels 
 action is executed "on release" (mouse or keyboard). If you need an action
   that depends on the button itself, use on_button_release instead.  
 move this test to Button ? 
 use ~lock if the user is not authorized to slide 
 let onclick = fun w _ ev -> Slider.click_focus (get_slider w) ev in 
 add_connection w c; 
 = ti ! 
 = ti ! 
 = ti ! 
 = ti ! 
* creation of combined widgets 
**
 some useful connections 
**
* remove an 'active' from the active list of the widget 
 it should occur only once in the list 
 if a.connect_id = active.connect_id 
 test inutile, le suivant suffit 
* ask a thread to remove itself from a widget 
 check if connection is terminated 
 (only if the thread decided to signal this, for instance by setting the event
   to Trigger.stopped) 
 indicate to an active connection that its thread should terminate 
 ask for terminate and wait (blocking) until it really terminates by itself 
* activate an action (via a thread) on the connection 
 Trigger.renew_my_event (); 
 we used to create a new event for the main loop, so that "ev" can be safely
     sent to the thread, and the thread can examine later, even after several
     main loops, without it being altered (except when exiting is required) 
 Now we use a more natural, solution would be to copy the event before
     sending it to the thread, but there is no "copy_event" function
     available... 
* check if the trigger can wake up a connection, and if so, run the action 
 = direct action, no thread! Should we still add it to the active list?
      
 Thread.kill a.thread; 
 Thread.kill is in fact NOT
                                             implemented... ! 
* remove all active connections from this widget and ask for the threads to
    terminate 
*****************
 already done by the widget 
***********************
 Some examples of "pure" actions (actions that don't depend on external
   variables) 
  This file is part of BOGUE , by San Vu Ngoc


open Tsdl
open B_utils
module Avar = B_avar
module Utf8 = B_utf8
module Var = B_var
module Tvar = B_tvar
module Timeout = B_timeout
module Trigger =  B_trigger
module Draw = B_draw
module Empty = B_empty
module Image = B_image
module Box = B_box
module Sdl_area = B_sdl_area
module Label = B_label
module Button = B_button
module Slider = B_slider
module Check = B_check
module Text_display = B_text_display
module Text_input = B_text_input

type kind =
  | Empty of Empty.t
  | Box of Box.t
  | Button of Button.t
  | Check of Check.t
  | Label of Label.t
  | TextDisplay of Text_display.t
  | Image of Image.t
  | Slider of Slider.t
  | TextInput of Text_input.t
  | SdlArea of Sdl_area.t

type action_priority =
  execute the new after the first one has completed
  kill the first action ( if possible ) and execute the second one

type active = {
    thread : Thread.t;
    event : Sdl.event;
    connect_id : int
  }

type action = t -> t -> Sdl.event -> unit

and connection = {
  source : t;
  target : t;
  action : action;
  priority : action_priority;
  triggers : Trigger.t list;
  id : int;
}

and t = {
  kind : kind;
  receiver : action Event.channel ;
  actives : (active list) Var.t;
  [ actives ] lists all active threads / connections for this widget . Most recent 
      come first in the list
     come first in the list *)
  mutable connections : connection list;
  wid : int;
  mutable room_id : int option;
  mutable cursor : Sdl.cursor option
}

let draw_boxes = ref false

let id w = w.wid

let get_room_id w = match w.room_id with
  | None -> failwith "The widget does not belong to a room yet"
  | Some id -> id

let equal w1 w2 =
  w1.wid = w2.wid
let (==) = equal

type widget = t

module Hash = struct
  type t = widget
  let equal = equal
  let hash = id
end

module WHash = Weak.Make(Hash)
let widgets_wtable = WHash.create 100

let string_of_kind = function
  | Empty _ -> "Empty"
  | Box _ -> "Box"
  | Button _ -> "Button"
  | Check _ -> "Check"
  | TextDisplay _ -> "TextDisplay"
  | Label l -> "Label [" ^ xterm_red ^ (Label.text l) ^ xterm_nc ^ "]"
  | Image _ -> "Image"
  | Slider _ -> "Slider"
  | TextInput _ -> "TextInput"
  | SdlArea _ -> "SdlArea"

let free w =
  printd debug_memory "Freeing widget #%u" w.wid;
  match w.kind with
  | Empty e -> Empty.free e
  | Box b -> Box.free b
  | Check b -> Check.free b
  | Button b -> Button.free b
  | TextDisplay t -> Text_display.free t
  | Image img -> Image.free img
  | Label l -> Label.free l
  | Slider s -> Slider.free s
  | TextInput ti -> Text_input.free ti
  | SdlArea a -> Sdl_area.free a

let is_fresh w = Var.get w.fresh



  let   w =

let fresh_id = fresh_int ()
let fresh_wid = fresh_int ()

let create_empty kind =
  let wid = fresh_wid () in
  let w =
    { kind;
      wid;
      actives = Var.create [];
      fresh = Var.create false;
      connections = [];
      room_id = None;
      cursor = None;
    } in
  WHash.add widgets_wtable w;
  w

let dummy_widget = create_empty (Empty (Empty.create (0,0)))

let of_id wid = Hashtbl.find widgets_table wid ; ;
let of_id wid : t =
  try WHash.find widgets_wtable {dummy_widget with wid} with
  | Not_found -> (printd debug_error "Cannot find widget with wid=%d" wid;
                  raise Not_found)

let unload_texture w =
  printd debug_memory "Unloading texture for widget #%u" w.wid;
  match w.kind with
  | Empty b -> Empty.unload b
  | Box b -> Box.unload b
  | Check b -> Check.unload b
  | Button b -> Button.unload b
  | TextDisplay t -> Text_display.unload t
  | Image img -> Image.unload img
  | Label l -> Label.unload l
  | Slider s -> Slider.unload s
  | TextInput ti -> Text_input.unload ti
  | SdlArea a -> Sdl_area.unload a

let default_size w =
  match w.kind with
  | Empty e -> Empty.size e
  | Check b -> Check.size b
  | Box b -> Box.size b
  | TextDisplay td -> Text_display.size td
  | Label l -> let x,y = Label.size l in (x+2,y+2)
  | Image img -> Image.size img
  | Button b -> Button.size b
  | Slider s -> Slider.size s
  | TextInput ti -> Text_input.size ti
  | SdlArea a -> Sdl_area.size a

let size = default_size

let resize w size =
  match w.kind with
  | Empty e -> Empty.resize size e
  | Box b -> Box.resize size b
  | Button b -> Button.resize size b
  | Check c -> Check.resize size c
  | Label l -> Label.resize size l
  | TextDisplay t -> Text_display.resize size t
  | Image i -> Image.resize size i
  | Slider s -> Slider.resize size s
  | TextInput ti -> Text_input.resize size ti
  | SdlArea a -> Sdl_area.resize size a

let get_cursor w =
  default w.cursor
    (match w.kind with
     | Empty _
     | Box _
     | Label _
     | TextDisplay _
     | SdlArea _
     | Image _ -> go (Draw.create_system_cursor Sdl.System_cursor.arrow)
     | Button _
     | Check _
     | Slider _ -> go (Draw.create_system_cursor Sdl.System_cursor.hand)
     | TextInput _ -> go (Draw.create_system_cursor Sdl.System_cursor.ibeam)
    )

let set_cursor w cursor =
  w.cursor <- cursor

let display canvas layer w geom =
  Var.set w.fresh true;
  let geom = Draw.scale_geom geom in
  match w.kind with
  | Empty e -> printd debug_board "empty box";
    Empty.display canvas layer e geom
  | Box b -> printd debug_board "draw box";
    Box.display canvas layer b geom
  | Check b -> printd debug_board "check button: %b" (Check.state b);
    Check.display canvas layer b geom
  | SdlArea a -> printd debug_board "render SDL area";
    Sdl_area.display w.wid canvas layer a geom
  | Button b -> printd debug_board "button [%s]" (Button.text b);
    Button.display canvas layer b geom
  | TextDisplay td ->
    printd debug_board "text display: %s" (Text_display.text td);
    Text_display.display canvas layer td geom
  | Image img -> printd debug_board "image: %s" (Image.get_file img);
    Image.display canvas layer img geom
  | Label l -> printd debug_board "label: %s" (Label.text l);
    Label.display canvas layer l geom
  | Slider s -> printd debug_board "slider: %d" (Slider.value s);
    Slider.display canvas layer s geom
  | TextInput ti -> printd debug_board "Input: %s" (Text_input.text ti);
    Text_input.display canvas layer ti geom

let update w =
  printd debug_board "Please refresh widget #%i" w.wid;
  Var.set w.fresh false;
  Trigger.push_redraw w.wid
  TODO ... use wid et / ou window_id ...


  if ~join : c , on donne le même i d que la connexion c , ce qui permet 
    d'effectuer       ( avec en général 
    la priorité Join pour effectuer à la suite de c ) . Attention dans ce 
    cas , ne pas déclancher plein de ces connexions à la suite ... elles 
    s'attendent !
   d'effectuer l'action conjointement avec celle de c (avec en général
   la priorité Join pour effectuer à la suite de c). Attention dans ce
   cas, ne pas déclancher plein de ces connexions à la suite... elles
   s'attendent ! *)
let connect source target action ?(priority=Forget) ?(update_target=true) ?join triggers =
  let action = if update_target
  TODO ajouter  ev ? ?
    else action in
  let action = if !debug
    then fun w1 w2 ev ->
      (printd debug_thread "Executing action";
       let t = Unix.gettimeofday () in
       action w1 w2 ev;
       printd debug_thread "End of action with time=%f" (Unix.gettimeofday () -. t))
    else action in
  let id = match join with
    | None -> fresh_id ()
    | Some c -> c.id in
  { source;
    target;
    action;
    priority;
    triggers;
    id }

let connect_after source target action triggers =
  match List.rev source.connections with
    | [] -> connect source target action ~priority:Join triggers
    | c::_ -> connect source target action ~priority:Join ~join:c triggers

let connect_main = connect ~priority:Main

let connections t =
  t.connections

let add_connection w c =
  if List.exists (fun cc -> cc.id = c.id) w.connections
  then printd (debug_error + debug_user) "Connection is already present in widget"
  else w.connections <- List.rev (c :: List.rev w.connections)

let remove_connection w c =
  let clist = List.filter (fun cc -> cc.id <> c.id) w.connections in
  if List.compare_lengths clist w.connections <> 0
  then w.connections <- clist
  else printd (debug_error + debug_user)
      "Cannot remove connection because it is not present in the widget."

let remove_trigger w tr =
  let clist = List.filter (fun cc -> not (List.mem tr cc.triggers)) w.connections in
  if List.compare_lengths clist w.connections <> 0
  then w.connections <- clist
  else printd (debug_warning + debug_user)
      "[remove_trigger] There is no trigger of that kind in the list of connections."

let get_box w =
  match w.kind with
  | Box b -> b
  | _ -> invalid_arg "Expecting a box, not a %s" (string_of_kind w.kind)

let get_check w =
  match w.kind with
    | Check b -> b
    | _ -> invalid_arg "Expecting a check box, not a %s" (string_of_kind w.kind)

let get_label w =
 match w.kind with
    | Label l -> l
    | _ -> invalid_arg "Expecting a label, not a %s" (string_of_kind w.kind)

let get_button w =
  match w.kind with
    | Button b -> b
    | _ -> invalid_arg "Expecting a button, not a %s" (string_of_kind w.kind)

let get_slider w =
 match w.kind with
    | Slider s -> s
    | _ -> invalid_arg "Expecting a slider, not a %s" (string_of_kind w.kind)

let get_text_display w =
 match w.kind with
    | TextDisplay td -> td
    | _ -> invalid_arg "Expecting a text display, not a %s" (string_of_kind w.kind)

let get_text_input w =
 match w.kind with
    | TextInput ti -> ti
    | _ -> invalid_arg "Expecting a text input, not a %s" (string_of_kind w.kind)

let get_image w =
 match w.kind with
   | Image im -> im
   | _ -> invalid_arg "Expecting an image, not a %s" (string_of_kind w.kind)

let get_sdl_area w =
  match w.kind with
  | SdlArea a -> a
  | _ -> invalid_arg "Expecting an Sdl_area, not a %s" (string_of_kind w.kind)

let check_box ?state ?style () =
  let b = create_empty  (Check (Check.create ?state ?style ())) in
  let action = fun w _ _ -> Check.action (get_check w) in
  let c = connect_main b b action Trigger.buttons_down in
  add_connection b c;
  b



let set_check_state b s =
  Check.set (get_check b) s

let empty ~w ~h () =
  create_empty (Empty (Empty.create (w,h)))

let text_display ?w ?h text =
  create_empty (TextDisplay (Text_display.create_from_string ?w ?h text))

let rich_text ?size ?w ?h paragraphs =
  create_empty (TextDisplay (Text_display.create ?size ?w ?h paragraphs))

let lines_display ?w ?h lines =
  create_empty (TextDisplay (Text_display.create_from_lines ?w ?h lines))

let verbatim text =
  create_empty (TextDisplay (Text_display.create_verbatim text))

let html ?w ?h text =
  create_empty (TextDisplay (Text_display.create_from_html ?w ?h text))

let box ?w ?h ?style () =
  create_empty (Box (Box.create ?width:w ?height:h ?style ()))

let sdl_area ~w ~h ?style () =
  create_empty (SdlArea (Sdl_area.create ~width:w ~height:h ?style ()))

let label ?size ?fg ?font ?align text =
  create_empty (Label (Label.create ?size ?fg ?font ?align text))

let icon ?size ?fg name =
  create_empty (Label (Label.icon ?size ?fg name))

let image ?w ?h ?bg ?noscale ?angle file =
  create_empty (Image (Image.create ?width:w ?height:h ?bg ?noscale ?angle file))

let image_from_svg ?w ?h ?bg file =
  let svg = Draw.convert_svg ?w ?h file in
  let w,h = Draw.unscale_size (Draw.image_size svg) in
  image ~w ~h ?bg svg

let image_copy ?rotate w =
  create_empty (Image (Image.copy ?rotate (get_image w)))

let button ?(kind = Button.Trigger) ?label ?label_on ?label_off
    ?fg ?bg_on ?bg_off ?bg_over ?state
    ?border_radius ?border_color ?action text =
  let b = create_empty
      (Button (Button.create ?label ?label_on ?label_off ?fg
                 ?bg_on ?bg_off ?bg_over
                 ?border_radius ?border_color ?state ?action kind text)) in
  let press = fun _ _ _ -> Button.press (get_button b) in
  let c = connect_main b b press Trigger.buttons_down in
  add_connection b c;
    | Button.Trigger -> fun _ _ _ -> Button.release (get_button b)
    | Button.Switch -> fun _ _ ev -> Button.switch (get_button b) ev
  in
  let c = connect_main b b release Trigger.buttons_up in
  add_connection b c;
  let c = connect_main b b (fun b _ _ -> Button.mouse_enter (get_button b))
      [Trigger.mouse_enter] in
  add_connection b c;
  let c = connect_main b b (fun b _ _ -> Button.mouse_leave (get_button b))
      [Trigger.mouse_leave] in
  add_connection b c;
  let c = connect_main b b (fun b _ ev -> Button.receive_key (get_button b) ev)
      [Trigger.key_down; Trigger.key_up] in
  add_connection b c;
  b

let slider ?(priority=Main) ?step ?value ?kind ?var ?length ?thickness
      ?tick_size ?(lock = false) ?w ?h maxi =
  let w = create_empty (Slider (Slider.create ?step ?value ?kind ?var ?length
                                  ?thickness ?tick_size ?w ?h maxi)) in
  if not lock then begin
      let onbutton_down = fun w _ ev -> Slider.click (get_slider w) ev in
      let c = connect_main w w onbutton_down Trigger.buttons_down in
      add_connection w c;
  let c = connect_main w w onclick [  . Event.mouse_button_up ] in
      let on_release = fun w _ _ -> Slider.release (get_slider w) in
      let c = connect_main w w on_release Trigger.buttons_up in
      add_connection w c;
      let slide = fun w _ ev ->
        let ti = get_slider w in
        if Trigger.mm_pressed ev || Trigger.event_kind ev = `Finger_motion
        then (Slider.slide ti ev; update w)
      in
      let c = connect ~priority ~update_target:false w w slide Trigger.pointer_motion in
      add_connection w c;
      let get_keys = fun w _ ev -> Slider.receive_key (get_slider w) ev
      in
      let c = connect ~priority w w get_keys [Sdl.Event.key_down] in
      add_connection w c
    end;
  w

  create a slider with a simple Tvar that executes an action each time the 
    local value of the slider is modified by the slider
   local value of the slider is modified by the slider *)
let slider_with_action ?priority ?step ?kind ~value ?length ?thickness ?tick_size
    ~action max =
  let v = Var.create (Avar.var value) in
  let t_from a = Avar.get a in
  let t_to x = action x; Avar.var x in
  let var = Tvar.create v ~t_from ~t_to in
  slider ?priority ?step ?kind ~var ?length ?thickness ?tick_size max

let text_input ?(text = "") ?prompt ?size ?filter ?max_size () =
  let ti = Text_input.create ?size ?prompt ?filter ?max_size text in
  let w = create_empty (TextInput ti) in
  let onbutton_down = fun w _ ev ->
    Text_input.button_down ti ev in
  let c = connect_main w w onbutton_down Trigger.buttons_down in
  add_connection w c;
  let onclick = fun w _ ev ->
    Text_input.click ti ev in
  let c = connect_main w w onclick Trigger.buttons_up in
  add_connection w c;
  let ontab = fun w _ ev ->
    Text_input.tab ti ev in
  let c = connect_main w w ontab [Sdl.Event.key_down] in
  add_connection w c;
  let selection = fun w _ ev ->
    if Trigger.mm_pressed ev then (Text_input.mouse_select ti ev; update w)
  in
  let c = connect_main ~update_target:false w w selection [Sdl.Event.mouse_motion] in
  add_connection w c;
  let get_keys = fun w _ ev -> Text_input.receive_key (get_text_input w) ev
  in
  let c2 = connect_main w w get_keys [Sdl.Event.text_editing; Sdl.Event.text_input; Sdl.Event.key_down; Sdl.Event.key_up] in
  add_connection w c2;
  w


  Some generic functions or ' methods ' that can make sense for one or several 
    types of widgets
   types of widgets *)

let get_text w =
  match w.kind with
  | Button b -> Button.text b
  | TextDisplay td -> Text_display.text td
  | Label l -> Label.text l
  | TextInput ti -> Text_input.text ti
  | _ -> (printd debug_error "This type of widget does not have a text function";
          "")

let set_text w text =
  match w.kind with
  | Button b -> Button.set_label b text
  | TextDisplay td -> let pa = Text_display.paragraphs_of_string text in
    Text_display.update td pa
  | Label l -> Label.set l text
  | TextInput ti -> let k = Utf8.split text in
    Text_input.set ti k
  | _ -> printd debug_error "Cannot set text to this type of widget"

let get_state w =
  match w.kind with
  | Button b -> Button.state b
  | Check c -> Check.state c
  | _ -> (printd debug_error "This type of widget does not have a state function";
          false)

let set_state w s =
  match w.kind with
  | Button b -> Button.set b s
  | Check c -> Check.set c s
  | _ -> (printd debug_error "Cannot set the state for this type of widget.")

let check_box_with_label text =
  let b = check_box () in
  let l = label text in
  let action = fun _ w _ -> Check.action (get_check w) in
  let c = connect_main l b action Trigger.buttons_down in
  add_connection l c;
  b,l


  the disadvantage is that these functions do not take advantage of the two 
    widgets + event entry . Thus they are less ' functional ' and require more 
    global variables ( closures ) . Also , they all work with " connect_main " , so are 
    ok only for very fast actions .
   widgets + event entry. Thus they are less 'functional' and require more
   global variables (closures). Also, they all work with "connect_main", so are
   ok only for very fast actions. *)

let mouse_over ?(enter = nop) ?(leave = nop) w =
  let c = connect w w (fun w _ _ -> enter w) [Trigger.mouse_enter] in
  add_connection w c;
  let c' = connect w w (fun w _ _ -> leave w) [Trigger.mouse_leave] in
  add_connection w c'

let on_click ~click w =
  let c = connect_main w w (fun w _ _ -> click w) Trigger.buttons_down in
  add_connection w c

let on_release ~release w =
  let c = connect_main w w (fun w _ _ -> release w)
      Trigger.buttons_up in
  add_connection w c

let on_button_release ~release w =
  let c = connect_main w w (fun w _ ev ->
      if Trigger.of_event ev <> Trigger.key_up
      || Button.check_key (get_button w) ev
      then release w) (Trigger.key_up :: Trigger.buttons_up) in
  add_connection w c


* check if connection is in the active list , and return the most 
     recent (= first in list ) active , or None
    recent (=first in list) active, or None *)
let is_active alist c =
  let rec loop = function
    | [] -> None
    | a::rest -> if a.connect_id = c.id then Some a else loop rest
  in loop alist

let remove widget thread_id =
  let rec loop list acc = match list with
    | [] -> acc
      if Thread.id a.thread = thread_id
      then List.concat [List.rev rest; acc]
      else loop rest (a::acc)
  in Var.set widget.actives (List.rev (loop (Var.get widget.actives) []))

let add widget active =
  Var.set widget.actives (active :: (Var.get widget.actives))

let remove_me c_id widget =
  printd debug_thread "Removing connection #%d" c_id;
  remove widget (Thread.id (Thread.self ()));
  decr threads_created

let has_terminated active =
  Sdl.Event.(get active.event typ) <> Trigger.stop

  TODO protect this with mutex or Var
let terminate ?(timeout = 50) active =
  printd debug_thread "Ask for terminating connection #%u" active.connect_id;
  Sdl.Event.(set active.event typ) Trigger.stop;
  ignore (Timeout.add timeout (fun () ->
              if not (has_terminated active)
              then printd debug_thread "Cannot terminate thread for connection #%u after %u ms." active.connect_id timeout
    ))

let wait_terminate active =
  terminate active;
  Thread.join active.thread

let add_action c action ev =
  printd debug_thread "Create thread for connection #%d" c.id;
  WARNING : at this point it is not possible to copy the drop_file_file field
  let e_copy = Trigger.copy_event ev in
  incr threads_created;
  add c.source
    { thread = Thread.create (action c.source c.target) e_copy;
      event = e_copy;
      connect_id = c.id }

let wake_up event c =
  if List.mem (Trigger.of_event event) c.triggers then
    begin
      printd debug_thread "Activating connection #%d" c.id;
  TODO add a more precise ~test before launching the thread ?
      if c.priority = Main then c.action c.source c.target event
      else begin
        let action = fun w1 w2 ev ->
          c.action w1 w2 ev;
          remove_me c.id w1 in
        let alist = Var.get c.source.actives in
        let tho = is_active alist c in
        if alist = [] || tho = None then add_action c action event
        else match c.priority, tho with
          | Forget, _ -> printd debug_thread "Forgetting connection #%d" c.id
          | Join, Some a ->
            let action = fun w1 w2 ev -> (Thread.join a.thread; action w1 w2 ev) in
            add_action c action event
          | Replace, Some a -> begin
  printd debug_thread " Killing connection # % d " a.connect_id ;
              terminate a;
              remove c.source (Thread.id a.thread);
              add_action c action event
            end
          | _ -> failwith "This should not happen"
      end
    end

let wake_up_all ev w =
  List.iter (wake_up ev) w.connections

let remove_active_connections widget =
  let actives = Var.get widget.actives in
  List.iter wait_terminate actives;
  Var.set widget.actives []



  Some widgets directly react to a click event to activate themselves . Some , 
    like text_input , even react to the TAB key . In fact , keyboard_focus is 
    treated globally by the main loop , therefore one could ( should ? ) rely on 
    this function below instead of adding new reactions to TAB & click
   like text_input, even react to the TAB key. In fact, keyboard_focus is
   treated globally by the main loop, therefore one could (should?) rely on
   this function below instead of adding new reactions to TAB & click *)
let set_keyboard_focus w =
  match w.kind with
  | Slider s -> Slider.set_focus s
  | Button b -> Button.set_focus b
  | _ -> ()

let remove_keyboard_focus w =
  match w.kind with
  | TextInput ti -> Text_input.stop ti
  | Slider s -> Slider.unfocus s
  | Button b -> Button.unfocus b
  | _ -> ()

let guess_unset_keyboard_focus w =
  match w.kind with
  | TextInput _ -> Some false
  | Slider _ -> Some false
  | Button _ -> Some false
  | _ -> None


let copy_text w1 w2 _ =
  let text = get_text w1 in
  set_text w2 text

let map_text f w1 w2 _ =
  let text = get_text w1 in
  set_text w2 (f text)
