1 files changed, 112 insertions, 0 deletions
diff --git a/otherlibs/labltk/example/calc.ml b/otherlibs/labltk/example/calc.ml
new file mode 100644
index 0000000000..a330a9ecb3
--- /dev/null
+++ b/otherlibs/labltk/example/calc.ml
@@ -0,0 +1,112 @@
+(* $Id$ *)
+
+(* A simple calculator demonstrating OO programming with O'Labl
+   and LablTk.
+
+   LablTk itself is not OO, but it is good to wrap complex
+   structures in objects. Even if the absence of initializers
+   makes things a little bit awkward.
+*)
+
+open Tk
+
+let mem_string elt:c s =
+  try
+    for i = 0 to String.length s -1 do
+      if s.[i] = c then raise Exit
+    done; false
+  with Exit -> true
+
+let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)]
+
+(* The abstract calculator class.
+   Does not use Tk (only Textvariable) *)
+
+class calc () = object (calc)
+  val variable = Textvariable.create ()
+  val mutable x = 0.0
+  val mutable op = None
+  val mutable displaying = true
+
+  method set = Textvariable.set variable
+  method get = Textvariable.get variable
+  method insert s = calc#set to:(calc#get ^ s)
+  method get_float = float_of_string (calc#get)
+
+  method command s =
+    if s <> "" then match s.[0] with
+      '0'..'9' ->
+	if displaying then (calc#set to:""; displaying <- false);
+	calc#insert s
+    | '.' ->
+	if displaying then
+	  (calc#set to:"0."; displaying <- false)
+	else
+	  if not (mem_string elt:'.' calc#get) then calc#insert s
+    | '+'|'-'|'*'|'/' as c ->
+	displaying <- true;
+	begin match op with
+	  None ->
+	    x <- calc#get_float;
+	    op <- Some (List.assoc key:c ops)
+	| Some f ->
+	    x <- f x (calc#get_float);
+	    op <- Some (List.assoc key:c ops);
+	    calc#set to:(string_of_float x)
+	end
+    | '='|'\n'|'\r' ->
+	displaying <- true;
+	begin match op with
+	  None -> ()
+	| Some f ->
+	    x <- f x (calc#get_float);
+	    op <- None;
+	    calc#set to:(string_of_float x)
+	end
+    | 'q' -> closeTk (); exit 0
+    | _ -> ()
+end
+
+(* Buttons for the calculator *)
+
+let m =
+  [|["7";"8";"9";"+"];
+    ["4";"5";"6";"-"];
+    ["1";"2";"3";"*"];
+    ["0";".";"=";"/"]|]
+
+(* The physical calculator. Inherits from the abstract one *)
+
+class calculator :parent = object
+  inherit calc () as calc
+
+  val label = Label.create :parent anchor:`E relief:`Sunken padx:(`Pix 10) ()
+  val frame = Frame.create :parent ()
+
+  initializer
+    let buttons =
+      Array.map fun:
+	(List.map fun:
+	   (fun text ->
+	     Button.create parent:frame :text
+	       command:(fun () -> calc#command text) ()))
+	m
+    in
+    Label.configure textvariable:variable label;
+    calc#set to:"0";
+    bind parent events:[[],`KeyPress]
+      action:(`Set([`Char],fun ev -> calc#command ev.ev_Char));
+    for i = 0 to Array.length m - 1 do
+      Grid.configure row:i buttons.(i)
+    done;
+    pack side:`Top fill:`X [label];
+    pack side:`Bottom fill:`Both expand:true [frame];
+end
+
+(* Finally start everything *)
+
+let top = openTk ()
+
+let applet = new calculator parent:top
+
+let _ = mainLoop ()