(***********************************************************************)
(*                                                                     *)
(*                 MLTk, Tcl/Tk interface of OCaml                     *)
(*                                                                     *)
(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
(*               projet Cristal, INRIA Rocquencourt                    *)
(*            Jacques Garrigue, Kyoto University RIMS                  *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique and Kyoto University.  All rights reserved.         *)
(*  This file is distributed under the terms of the GNU Library        *)
(*  General Public License, with the special exception on linking      *)
(*  described in file LICENSE found in the OCaml source tree.          *)
(*                                                                     *)
(***********************************************************************)
open Camltk

let debug = ref false

let vert wid =
  let newsize = ref 0
  and pending_resize = ref false
  and last_last = ref 0.0 in
  let rec resize () =
    pending_resize := false;
    if !debug then
      (Printf.eprintf "%s Resize %d\n"
                      (Widget.name wid) !newsize; flush stderr);
    Text.configure wid [TextHeight !newsize];
    ()
  and check () =
    let first, last = Text.yview_get wid in
      check1 first last

  and check1 first last =
    let curheight = int_of_string (cget wid CHeight) in
      if !debug then begin
         Printf.eprintf "%s C %d %f %f\n"
                        (Widget.name wid) curheight first last;
         flush stderr
         end;
      if first = 0.0 && last = 1.0 then ()
      (* Don't attempt anything if widget is not visible *)
      else if not (Winfo.viewable wid) then begin
        if !debug then
          (Printf.eprintf "%s C notviewable\n" (Widget.name wid);
           flush stderr);
        (* Try again later *)
        bind wid [[], Expose] (BindSet ([], fun _ ->
               bind wid [[], Expose] BindRemove;
               check()))
        end
      else  begin
        let delta =
          if last = 0.0 then 1
          else if last = !last_last then
            (* it didn't change since our last resize ! *)
            1
           else begin
            last_last := last;
            (* never to more than double *)
            let visible = max 0.5 (last -. first) in
            max 1 (truncate (float curheight *. (1. -. visible)))
            end in
        newsize := max (curheight + delta) !newsize;
        if !debug then
           (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize;
            flush stderr);
        if !pending_resize then ()
        else begin
          pending_resize := true;
          Timer.set 300 (fun () -> Frx_after.idle resize)
          end
        end

    and scroll first last =
      if !debug then
        (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last;
         flush stderr);
      if first = 0.0 && last = 1.0 then ()
      else check1 first last
    in
      scroll, check