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

(*                                                                     *)

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

(*                                                                     *)

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

(* $Id$ *)

(* Some CamlTk4 Demonstration by JPF *)

(* First, open these modules for convenience *)

open StdLabels

open Tk

(* Dummy let *)

let _ =

(* Initialize Tk *)

let top = openTk () in

(* Title setting *)

Wm.title_set top "LablTk demo";

(* Base frame *)

let base = Frame.create top in

pack [base];

(* Menu bar *)

let bar = Frame.create ~borderwidth:2 ~relief:`Raised  base in

pack ~fill:`X [bar];

  (* Menu and Menubutton *)

  let meb = Menubutton.create ~text:"Menu" bar in

  let men = Menu.create meb in

  Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men;

  Menubutton.configure ~menu:men meb;

  (* Frames *)

  let base2 = Frame.create base in

  let left = Frame.create base2 in

  let right = Frame.create base2 in

  pack [base2];

  pack ~side:`Left [left; right];

    (* Widgets on left and right *)

    (* Button *)

    let but = Button.create ~text:"Welcome to LablTk" left in

    (* Canvas *)

    let can =

      Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left

    in

    let oval = Canvas.create_oval ~x1: 10 ~y1: 10

                                  ~x2: 90 ~y2: 90

                                  ~fill: `Red

                                  can

    in ignore oval;

    (* Check button *)

    let che = Checkbutton.create ~text:"Check" left in

    (* Entry *)

    let ent = Entry.create ~width:10 left in

    (* Label *)

    let lab = Label.create ~text:"Welcome to LablTk" left in

    (* Listbox *)

    let lis = Listbox.create left in

    Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"];

    (* Message *)

    let mes = Message.create

        ~text: "Hello this is a message widget with very long text, but ..."

        left in

    (* Radio buttons *)

    let tv = Textvariable.create () in

    Textvariable.set tv "One";

    let radf = Frame.create right in

    let rads = List.map

        ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf)

        ["One"; "Two"; "Three"] in

    (* Scale *)

    let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in

    (* Text and scrollbar *)

    let texf = Frame.create right in

      (* Text *)

      let tex = Text.create ~width:20 ~height:8 texf in

      Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex;

      (* Scrollbar *)

      let scr = Scrollbar.create texf in

      (* Text and Scrollbar widget link *)

      let scroll_link sb tx =

        Text.configure ~yscrollcommand:(Scrollbar.set sb) tx;

        Scrollbar.configure ~command:(Text.yview tx) sb in

      scroll_link scr tex;

      pack ~side:`Right ~fill:`Y [scr];

      pack ~side:`Left ~fill:`Both ~expand:true [tex];

    (* Pack them *)

    pack ~side:`Left [meb];

    pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes];

    pack [coe radf; coe sca; coe texf];

    pack rads;

  (* Toplevel *)

  let top2 = Toplevel.create top in

  Wm.title_set top2 "LablTk demo control";

  let defcol = `Color "#dfdfdf" in

  let selcol = `Color "#ffdfdf" in

  let buttons =

    List.map ~f:(fun (w, t, c, a) ->

        let b = Button.create ~text:t ~command:c top2 in

        bind ~events:[`Enter] ~action:(fun _ -> a selcol) b;

        bind ~events:[`Leave] ~action:(fun _ -> a defcol) b;

        b)

      [coe bar, "Frame", (fun () -> ()),

       (fun background -> Frame.configure ~background bar);

       coe meb, "Menubutton", (fun () -> ()),

       (fun background -> Menubutton.configure ~background meb);

       coe but, "Button", (fun () -> ()),

       (fun background -> Button.configure ~background but);

       coe can, "Canvas", (fun () -> ()),

       (fun background -> Canvas.configure ~background can);

       coe che, "CheckButton", (fun () -> ()),

       (fun background -> Checkbutton.configure ~background che);

       coe ent, "Entry", (fun () -> ()),

       (fun background -> Entry.configure ~background ent);

       coe lab, "Label", (fun () -> ()),

       (fun background -> Label.configure ~background lab);

       coe lis, "Listbox", (fun () -> ()),

       (fun background -> Listbox.configure ~background lis);

       coe mes, "Message", (fun () -> ()),

       (fun background -> Message.configure ~background mes);

       coe radf, "Radiobox", (fun () -> ()),

       (fun background ->

         List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads);

       coe sca, "Scale", (fun () -> ()),

       (fun background -> Scale.configure ~background sca);

       coe tex, "Text", (fun () -> ()),

       (fun background -> Text.configure ~background tex);

       coe scr, "Scrollbar", (fun () -> ()),

       (fun background -> Scrollbar.configure ~background scr)

      ]

  in

    pack ~fill:`X buttons;

(* Main Loop *)

Printexc.print mainLoop ()