Re: [Caml-list] Interaction loop with labltk

[Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp>]

From: Eliot Handelman <eliot@generation.net>

> Is there some way to keep the interaction loop alive while a LablTk 
> widget is running on win32?  I think
> I've seen this topic somewhere but haven't been able to track it down 
> again.

I cannot find my previous post on the subject.

To summarize it, the problem under win32 is that all graphical calls
must occur in the same thread. In practice this means that if you want
to have your interaction loop run in parallel with the labltk main loop,
you must start labltk in a different thread, and have all labltk calls
occur in that thread.
Support for this is included in lablgtk2, but not in labltk.
The same thing can be done in labltk, and I included the needed code
at the end of this mail.

Here is an example of use:
$ ocamlc -thread -I +labltk -c tkthread.ml
$ ocaml -I +labltk -I +threads unix.cma threads.cma labltk.cma tkthread.cmo
        Objective Caml version 3.09+dev4 (2004-10-13)

# open Tkthread;;
# start();;
- : Thread.t = <abstr>
# let b = sync (Button.create ~text:"Hello world!") top;;
val b : Widget.button Widget.widget = <abstr>
# async Tk.pack [b];;
- : unit = ()

Have fun.

Jacques Garrigue

(* tkthread.ml *)
let jobs : (unit -> unit) Queue.t = Queue.create ()
let m = Mutex.create ()
let with_jobs f =
  Mutex.lock m; let y = f jobs in Mutex.unlock m; y

let loop_id = ref None
let reset () = loop_id := None
let cannot_sync () =
  match !loop_id with None -> true
  | Some id -> Thread.id (Thread.self ()) = id

let gui_safe () =
  not (Sys.os_type = "Win32") || !loop_id = Some(Thread.id (Thread.self ()))

let has_jobs () = not (with_jobs Queue.is_empty)
let n_jobs () = with_jobs Queue.length
let do_next_job () = with_jobs Queue.take ()
let async j x = with_jobs (Queue.add (fun () -> j x))
let sync f x =
  if cannot_sync () then f x else
  let m = Mutex.create () in
  let res = ref None in
  Mutex.lock m;
  let c = Condition.create () in
  let j x =
    let y = f x in Mutex.lock m; res := Some y; Mutex.unlock m;
    Condition.signal c
  in
  async j x;
  Condition.wait c m;
  match !res with Some y -> y | None -> assert false

let rec job_timer () =
  Timer.set ~ms:10 ~callback:
    (fun () -> for i = 1 to n_jobs () do do_next_job () done; job_timer())

let thread_main () =
  try
    ignore (Protocol.openTk());
    job_timer();
    loop_id := Some (Thread.id (Thread.self ()));
    Protocol.mainLoop();
    loop_id := None;
  with exn ->
    loop_id := None;
    raise exn

let start () =
  Thread.create thread_main ()

let top = Widget.default_toplevel

-------------------
To unsubscribe, mail caml-list-request@inria.fr Archives: http://caml.inria.fr
Bug reports: http://caml.inria.fr/bin/caml-bugs FAQ: http://caml.inria.fr/FAQ/
Beginner's list: http://groups.yahoo.com/group/ocaml_beginners