otherlibs/labltk/frx/frx_fit.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16 open Camltk
  17
  18 let debug = ref false
  19
  20 let vert wid =
  21   let newsize = ref 0
  22   and pending_resize = ref false
  23   and last_last = ref 0.0 in
  24   let rec resize () =
  25     pending_resize := false;
  26     if !debug then
  27       (Printf.eprintf "%s Resize %d\n"
  28                       (Widget.name wid) !newsize; flush stderr);
  29     Text.configure wid [TextHeight !newsize];
  30     ()
  31   and check () =
  32     let first, last = Text.yview_get wid in
  33       check1 first last
  34
  35   and check1 first last =
  36     let curheight = int_of_string (cget wid CHeight) in
  37       if !debug then begin
  38          Printf.eprintf "%s C %d %f %f\n"
  39                         (Widget.name wid) curheight first last;
  40          flush stderr
  41          end;
  42       if first = 0.0 && last = 1.0 then ()
  43       (* Don't attempt anything if widget is not visible *)
  44       else if not (Winfo.viewable wid) then begin
  45         if !debug then
  46           (Printf.eprintf "%s C notviewable\n" (Widget.name wid);
  47            flush stderr);
  48         (* Try again later *)
  49         bind wid [[], Expose] (BindSet ([], fun _ ->
  50                bind wid [[], Expose] BindRemove;
  51                check()))
  52         end
  53       else  begin
  54         let delta =
  55           if last = 0.0 then 1
  56           else if last = !last_last then
  57             (* it didn't change since our last resize ! *)
  58             1
  59            else begin
  60             last_last := last;
  61             (* never to more than double *)
  62             let visible = max 0.5 (last -. first) in
  63             max 1 (truncate (float curheight *. (1. -. visible)))
  64             end in
  65         newsize := max (curheight + delta) !newsize;
  66         if !debug then
  67            (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize;
  68             flush stderr);
  69         if !pending_resize then ()
  70         else begin
  71           pending_resize := true;
  72           Timer.set 300 (fun () -> Frx_after.idle resize)
  73           end
  74         end
  75
  76     and scroll first last =
  77       if !debug then
  78         (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last;
  79          flush stderr);
  80       if first = 0.0 && last = 1.0 then ()
  81       else check1 first last
  82     in
  83       scroll, check