RE: threads & OCamlTK

[Don Syme <dsyme@microsoft.com>]

Thanks to everyone who replied!  I'll take a good look at ThreadTk shortly.

William Chesters writes:

> > And, on a vaguely related topic, is it possible to use threads with
> > programs that also use OCamlTK? I know Tk is not threadsafe, but if
> > only one thread is calling Tk functions, then perhaps it's still OK?

>   No, `Tk.mainLoop' blocks the whole process.

Hmm... it seems not to, under Windows NT/bytecode.  Maybe this is because
Tk.mainLoop gets linked against a non-blocking library of code under
Windows.

Here's an example program where I used polling to kill looping computations.

Cheers & thanks,
Don

---------------------------------------------------------------

let loopy = ref [];;

let mk_loopy_thread id = 
  let control = ref false in
  let kill () = control := true in
  let rec loop n = 
    Format.printf "loopy thread %d computes %d@." id n;
    if !control then Thread.exit() else loop (n+1) in
  let t = Thread.create loop 0 in
  kill;;

let tk_thread = 
  Thread.create (fun () ->
    let top = openTk ()  in
  (* The widgets. They all have "top" as parent widget. *)
    let en1 = Entry.create top [TextWidth 6; Relief Sunken] in
    let lab1 = Label.create top [Text "plus"] in
    let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in
    let lab2 = Label.create top [Text "="] in
    let but1 = Button.create top [Text "loopy thread"] in
    let but2 = Button.create top [Text "kill loopy thread"] in
    let result_display = Label.create top [] in
  (* References holding values of entry widgets *)
    let n1 = ref 0
    and n2 = ref 0  in
  (* Refresh result *)
    let refresh () =
      Label.configure result_display [Text (string_of_int (!n1 + !n2))]  in
  (* Electric *)
    let get_and_refresh (w,r) =
      fun _ _ ->
	try
	  r := int_of_string (Entry.get w);
	  let _ = refresh () in
	  ()
	with
      	  Failure "int_of_string" ->
            Label.configure result_display [Text "error"]
    in
  (* Set the callbacks *)
    Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ];
    Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ];
    let loopy_command _ = 
      loopy := (mk_loopy_thread (List.length !loopy))::(!loopy) in
    let kill_loopy_command _ = 
      (List.hd !loopy) ();
      loopy := List.tl !loopy in
    Button.configure but1 [Command loopy_command ];
    Button.configure but2 [Command kill_loopy_command ];
  (* Map the widgets *)
    pack [en1;lab1;en2;lab2;result_display;but1;but2;] [];
  (* Make the window resizable *)
    Wm.minsize_set top 1 1;
  (* Start interaction (event-driven program) *)
    mainLoop ()) ();;

Thread.join tk_thread;;