ocaml/otherlibs/labltk/example/demo.ml

(*************************************************************************)
(*                                                                       *)
(*                Objective Caml LablTk library                          *)
(*                                                                       *)
(*         Jun Furuse, projet Cristal, INRIA Rocquencourt                *)
(*            Jacques Garrigue, Kyoto University RIMS                    *)
(*                                                                       *)
(*   Copyright 1999 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.                                             *)
(*                                                                       *)
(*************************************************************************)

(* $Id$ *)

(* Some CamlTk4 Demonstration by JPF *)

(* First, open these modules for convenience *)
open Tk

(* Dummy let *)
let _ =

(* Initialize Tk *)
let top = openTk () in 
(* Title setting *)
Wm.title_set top ~title:"LablTk demo";

(* Base frame *)
let base = Frame.create top in
pack [base];

(* Menu bar *)
let bar = Frame.create base ~borderwidth: 2 ~relief: `Raised  in 
pack [bar] ~fill: `X;

  (* Menu and Menubutton *)
  let meb = Menubutton.create bar ~text: "Menu" in
  let men = Menu.create meb in
  Menu.add_command men ~label: "Quit" ~command: (fun () -> closeTk (); exit 0);
  Menubutton.configure meb ~menu: men; 
  
  (* Frames *)
  let base2 = Frame.create base in
  let left = Frame.create base2 in
  let right = Frame.create base2 in
  pack [base2];
  pack [left; right] ~side: `Left;
  
    (* Widgets on left and right *)
    
    (* Button *)
    let but = Button.create left ~text: "Welcome to LablTk" in
    
    (* Canvas *)
    let can = Canvas.create left ~width: 100
      ~height: 100 ~borderwidth: 1 ~relief: `Sunken
    in
    Canvas.create_oval can ~x1: 10 ~y1: 10 
                           ~x2: 90 ~y2: 90
                           ~fill:`Red; 

    (* Check button *)
    let che = Checkbutton.create left ~text: "Check" in
    
    (* Entry *)
    let ent = Entry.create left ~width: 10 in 
    
    (* Label *)
    let lab = Label.create left ~text: "Welcome to LablTk" in
    
    (* Listbox *)
    let lis = Listbox.create left in
    Listbox.insert lis ~index: `End ~texts: ["This"; "is"; "Listbox"];
    
    (* Message *)
    let mes = Message.create left
      ~text: "Hello this is a message widget with very long text, but ..." 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 radf ~text: t ~value: t ~variable: tv)
        ["One"; "Two"; "Three"] in
    
    (* Scale *)
    let sca = Scale.create right ~label: "Scale" ~length: 100
      ~showvalue: true in
    
    (* Text and scrollbar *)
    let texf = Frame.create right in 
    
      (* Text *)
      let tex = Text.create texf ~width: 20 ~height: 8 in
      Text.insert tex ~text: "This is a text widget." ~index: (`End,[])
         ~tags: [];
      
      (* Scrollbar *)
      let scr = Scrollbar.create texf in
      
      (* Text and Scrollbar widget link *)
      let scroll_link sb tx =
        Text.configure tx ~yscrollcommand: (Scrollbar.set sb);
        Scrollbar.configure sb ~command: (Text.yview tx) in
      scroll_link scr tex;
      
      pack [scr] ~side: `Right ~fill: `Y;
      pack [tex] ~side: `Left ~fill: `Both ~expand: true;
       
    (* Pack them *)
    pack [meb] ~side: `Left;
    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 ~title:"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 top2 ~text:t ~command:c in
        bind b ~events: [`Enter] ~action:(fun _ -> a selcol);
        bind b ~events: [`Leave] ~action:(fun _ -> a defcol);
        b)
      [coe bar, "Frame", (fun () -> ()),
       (fun background -> Frame.configure bar ~background);
       coe meb, "Menubutton", (fun () -> ()),
       (fun background -> Menubutton.configure meb ~background);
       coe but, "Button", (fun () -> ()),
       (fun background -> Button.configure but ~background);
       coe can, "Canvas", (fun () -> ()),
       (fun background -> Canvas.configure can ~background);
       coe che, "CheckButton", (fun () -> ()),
       (fun background -> Checkbutton.configure che ~background);
       coe ent, "Entry", (fun () -> ()),
       (fun background -> Entry.configure ent ~background);
       coe lab, "Label", (fun () -> ()),
       (fun background -> Label.configure lab ~background);
       coe lis, "Listbox", (fun () -> ()),
       (fun background -> Listbox.configure lis ~background);
       coe mes, "Message", (fun () -> ()),
       (fun background -> Message.configure mes ~background);
       coe radf, "Radiobox", (fun () -> ()),
       (fun background ->
         List.iter rads ~f:(fun b -> Radiobutton.configure b ~background));
       coe sca, "Scale", (fun () -> ()),
       (fun background -> Scale.configure sca ~background);
       coe tex, "Text", (fun () -> ()),
       (fun background -> Text.configure tex ~background);
       coe scr, "Scrollbar", (fun () -> ()),
       (fun background -> Scrollbar.configure scr ~background)
      ]
  in
    pack buttons ~fill: `X;

(* Main Loop *)
Printexc.print mainLoop ()