1 files changed, 150 insertions, 0 deletions
diff --git a/otherlibs/labltk/example/demo.ml b/otherlibs/labltk/example/demo.ml
new file mode 100644
index 000000000..2e72f386d
--- /dev/null
+++ b/otherlibs/labltk/example/demo.ml
@@ -0,0 +1,150 @@
+(* 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: (`Pix 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: (`Pix 100) 
+      height: (`Pix 100) borderwidth: (`Pix 1) relief: `Sunken
+    in
+    Canvas.create_oval can x1:(`Pix 10) y1:(`Pix 10) 
+                           x2:(`Pix 90) y2:(`Pix 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 to: "One";
+    let radf = Frame.create right in
+    let rads = List.map
+        fun:(fun t -> Radiobutton.create radf text: t value: t variable: tv)
+        ["One"; "Two"; "Three"] in
+    
+    (* Scale *)
+    let sca = Scale.create right label: "Scale" length: (`Pix 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 fun:(fun (w, t, c, a) ->
+        let b = Button.create top2 text:t command:c in
+        bind b events: [[], `Enter] 
+               action:(`Set ([], fun _ -> a selcol));
+        bind b events: [[], `Leave] 
+               action:(`Set ([], 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 fun:(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 () 
+