Re: [Caml-list] interactive graphics with Tcl/Tk

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

From: "Yaron M. Minsky" <yminsky@CS.Cornell.EDU>

> I'm trying to use tcl/tk for doing interactive graphics from the toplevel.
>  And, lord help me, I'm trying to do it on cygwin.
> My basic solution I came up with is this:  I have one thread doing all the
> labltk calls.  That thread also polls a channel where it effectively picks
> up RPC requests.  SO, when I want to draw something on the screen, I stuff
> the appropriate function into the channel, the TclTk thread picks it up
> and executes that function, and then sends back a response, at which point
> the calling thread continues.

Sound OK.

> Anyway, it all seems well and good, but when I actually try to do it, for
> some reason the i/o on the caml toplevel locks up.  So if I type:
> # Graphing.init (); print_string "Hello World!\n";;
> Hello World!
> - : unit = ()
> #
> 
> Graphing.init starts up the Tcl/Tk window as expected, and the print
> works, also as expected.  But from that point on until I kill the Tcl/Tk
> window, I can't get the toplevel to respond to keypresses.  It's as if the
> Tcl/Tk thread has stolen stdin.  Does anyone know how to work around this?
> y

There's one trouble: you can only switch between ocaml threads when
they are executing ocaml code.
This means that you should setup a timeout with Timer.add in your tk
thread, and call Thread.yield there. Note that this works with
posix and win32 threads, but not bytecode threads, since you cannot
switch threads in callbacks with them.

Here is the code. I only tested it with MSVC version, but this should
be ok on cygwin too (it works on Unix).
In fact, I wrote this code for lablgtk, because although it is
reentrant (contrary to labltk), on windows you can only call it from
one thread. This will be in the next lablgtk release.

Other threads should only use the sync and async functions.

$ ocaml -I +threads -I +labltk unix.cma threads.cma labltk.cma

        Objective Caml version 3.06

# 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 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
  ;;
val jobs : (unit -> unit) Queue.t = <abstr>
val m : Mutex.t = <abstr>
val with_jobs : ((unit -> unit) Queue.t -> 'a) -> 'a = <fun>
val loop_id : int option ref = {contents = None}
val cannot_sync : unit -> bool = <fun>
val gui_safe : unit -> bool = <fun>
val has_jobs : unit -> bool = <fun>
val n_jobs : unit -> int = <fun>
val do_next_job : unit -> unit = <fun>
val async : ('a -> unit) -> 'a -> unit = <fun>
val sync : ('a -> 'b) -> 'a -> 'b = <fun>
# open Tk;;
# let tk_thread () =  
    let top = openTk () in
    let rec cb () = for i = 1 to n_jobs () do do_next_job () done;
        Timer.set 1 cb; Thread.yield () in
      Timer.set 1 cb;
      mainLoop ();;
val tk_thread : unit -> unit = <fun>
# Thread.create tk_thread ();;
- : Thread.t = <abstr>
# let top = Widget.default_toplevel ;;
val top : Widget.toplevel Widget.widget = <abstr>
# let b = sync (Button.create ~text:"Hello world!") top;;
val b : Widget.button Widget.widget = <abstr>
# async pack [b];;
- : unit = ()
# async (Button.configure ~command:(fun () -> prerr_endline "Hello")) b;;
- : unit = ()

---------------------------------------------------------------------------
Jacques Garrigue      Kyoto University     garrigue at kurims.kyoto-u.ac.jp
		<A HREF=http://wwwfun.kurims.kyoto-u.ac.jp/~garrigue/>JG</A>
-------------------
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