(***********************************************************************)

(*                                                                     *)

(*                 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.          *)

(*                                                                     *)

(***********************************************************************)

(* A trick by Steve Ball to do pixel scrolling on text widgets *)

(* USES frx_fit *)

open Camltk

let create top opts navigation =

  let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in

  let lf = Frame.create f [] in

  let rf = Frame.create f [] in

  let c = Canvas.create lf [BorderWidth (Pixels 0)]

  and xscroll = Scrollbar.create lf [Orient Horizontal]

  and yscroll = Scrollbar.create rf [Orient Vertical]

  and secret = Frame.create_named rf "secret" []

  in

  let t = Text.create c (BorderWidth(Pixels 0) :: opts) in

    if navigation then Frx_text.navigation_keys t;

    (* Make the text widget an embedded canvas object *)

    ignore

     (Canvas.create_window c (Pixels 0) (Pixels 0)

        [Anchor NW; Window t; Tags [Tag "main"]]);

    Canvas.focus c (Tag "main");

    (*

    Canvas.configure c [Width (Pixels (Winfo.reqwidth t));

                        Height(Pixels (Winfo.reqheight t))];

    *)

    Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)];

    (* The horizontal scrollbar is directly attached to the

     * text widget, because h scrolling works properly *)

    Scrollbar.configure xscroll [ScrollCommand (Text.xview t)];

    (* But vertical scroll is attached to the canvas *)

    Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)];

    let scroll, check = Frx_fit.vert t in

    Text.configure t [

        XScrollCommand (Scrollbar.set xscroll);

        YScrollCommand (fun first last ->

           scroll first last;

           let x,y,w,h = Canvas.bbox c [Tag "main"] in

             Canvas.configure c

               [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)])

        ];

    bind c [[],Configure] (BindSet ([Ev_Width], (fun ei ->

      Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)])));

    pack [rf] [Side Side_Right; Fill Fill_Y];

    pack [lf] [Side Side_Left; Fill Fill_Both; Expand true];

    pack [secret] [Side Side_Bottom];

    pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true];

    pack [xscroll] [Side Side_Bottom; Fill Fill_X];

    pack [c] [Side Side_Left; Fill Fill_Both; Expand true];

    f, t