Initial revision

[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / examples / kaimono.ml

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/kaimono.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/kaimono.ml
new file mode 100644 (file)
index 0000000..e524156
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/kaimono.ml
@@ -0,0 +1,130 @@
+(* $Id$ *)
+
+open GMain
+open Printf
+
+let file_dialog ~title ~callback ?filename () =
+  let sel = GWindow.file_selection ~title ~modal:true ?filename () in
+  sel#cancel_button#connect#clicked ~callback:sel#destroy;
+  sel#ok_button#connect#clicked ~callback:
+    begin fun () ->
+      let name = sel#get_filename in
+      sel#destroy ();
+      callback name
+    end;
+  sel#show ()
+
+let w = GWindow.window ~title:"Okaimono" ()
+let vb = GPack.vbox ~packing:w#add ()
+
+let menubar = GMenu.menu_bar ~packing:vb#pack ()
+let factory = new GMenu.factory menubar
+let file_menu = factory#add_submenu "File"
+let edit_menu = factory#add_submenu "Edit"
+
+let sw = GBin.scrolled_window ~height:200 ~packing:vb#add
+    ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
+let vp = GBin.viewport ~width:340 ~shadow_type:`NONE ~packing:sw#add ()
+let table = GPack.table ~columns:4 ~rows:256 ~packing:vp#add ()
+let _ =
+  table#focus#set_vadjustment (Some vp#vadjustment)
+
+let top = ref 0
+and left = ref 0
+let add_to_table  w =
+  table#attach ~left:!left ~top:!top ~expand:`X w;
+  incr left;
+  if !left >= 4 then (incr top; left := 0)
+
+let entry_list = ref []
+
+let add_entry () =
+  let entry =
+    List.map [40;200;40;60]
+      ~f:(fun width -> GEdit.entry ~packing:add_to_table ~width ())
+  in entry_list := entry :: !entry_list
+
+let _ =
+  List.iter2 ["Number";"Name";"Count";"Price"] [40;200;40;60] ~f:
+    begin fun text width ->
+      ignore (GButton.button ~label:text ~width ~packing:add_to_table ())
+    end;
+  for i = 1 to 9 do add_entry () done
+
+let split ~sep s =
+  let len = String.length s in
+  let rec loop pos =
+    let next =
+      try String.index_from s pos sep with Not_found -> len
+    in
+    let sub = String.sub s ~pos ~len:(next-pos) in
+    if next = len then [sub] else sub::loop (next+1)
+  in loop 0
+
+let load name =
+  try
+    let ic = open_in name in
+    List.iter !entry_list
+      ~f:(fun l -> List.iter l ~f:(fun e -> e#set_text ""));
+    let entries = Stack.create () in
+    List.iter !entry_list ~f:(fun x -> Stack.push x entries);
+    try while true do
+      let line = input_line ic in
+      let fields = split ~sep:'\t' line in
+      let entry =
+       try Stack.pop entries
+       with Stack.Empty ->
+         add_entry (); List.hd !entry_list
+      in
+      List.fold_left fields ~init:entry ~f:
+       begin fun acc field ->
+         (List.hd acc)#set_text field;
+         List.tl acc
+       end
+    done
+    with End_of_file -> close_in ic
+  with Sys_error _ -> ()
+    
+
+let save name =
+  try
+    let oc = open_out name in
+    List.iter (List.rev !entry_list) ~f:
+      begin fun entry ->
+       let l = List.map entry ~f:(fun e -> e#text) in
+       if List.exists l ~f:((<>) "") then
+         let rec loop = function
+             [] -> ()
+           | [x] -> fprintf oc "%s\n" x
+           | x::l -> fprintf oc "%s\t" x; loop l
+         in loop l
+      end;
+    close_out oc
+  with Sys_error _ -> ()
+
+open GdkKeysyms
+
+let _ =
+  w#connect#destroy ~callback:Main.quit;
+  w#event#connect#key_press ~callback:
+    begin fun ev ->
+      let key = GdkEvent.Key.keyval ev and adj = vp#vadjustment in
+      if key = _Page_Up then
+       adj#set_value (adj#value -. adj#page_increment)
+      else if key = _Page_Down then
+       adj#set_value (min (adj#value +. adj#page_increment)
+                        (adj#upper -. adj#page_size));
+      false
+    end;
+  w#add_accel_group factory#accel_group;
+  let ff = new GMenu.factory file_menu ~accel_group:factory#accel_group in
+  ff#add_item ~key:_O "Open..."
+    ~callback:(file_dialog ~title:"Open data file" ~callback:load);
+  ff#add_item ~key:_S "Save..."
+    ~callback:(file_dialog ~title:"Save data" ~callback:save);
+  ff#add_separator ();
+  ff#add_item ~key:_Q "Quit" ~callback:w#destroy;
+  let ef = new GMenu.factory edit_menu ~accel_group:factory#accel_group in
+  ef#add_item ~key:_A "Add line" ~callback:add_entry;
+  w#show ();
+  Main.main ()