other files missing in 20001129

[helm.git] / helm / DEVEL / lablgtk / lablgtk_20001129-0.1.0 / examples / fixpoint.ml

diff --git a/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/examples/fixpoint.ml b/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/examples/fixpoint.ml
new file mode 100644 (file)
index 0000000..c33b74d
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/examples/fixpoint.ml
@@ -0,0 +1,30 @@
+(* $Id$ *)
+
+open GMain
+
+let rec fix ~f ~eq x =
+  let x' = f x in
+  if eq x x' then x
+  else fix ~f ~eq x'
+
+let eq_float x y = abs_float (x -. y) < 1e-13
+
+let _ =
+  let top = GWindow.window () in
+  top#connect#destroy ~callback:Main.quit;
+  let vbox = GPack.vbox ~packing: top#add () in
+  let entry = GEdit.entry ~max_length: 20 ~packing: vbox#add () in
+  let tips = GData.tooltips () in
+  tips#set_tip entry#coerce ~text:"Initial value for fix-point";
+  let result =
+    GEdit.entry ~max_length: 20 ~editable: false ~packing: vbox#add () in
+
+  entry#connect#activate ~callback:
+    begin fun () ->
+      let x = try float_of_string entry#text with _ -> 0.0 in
+      entry#set_text (string_of_float (cos x));
+      let res = fix ~f:cos ~eq:eq_float x in
+      result#set_text (string_of_float res)
+    end;
+  top#show ();
+  Main.main ()