helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/kaimono.ml

   1 (* $Id$ *)
   2
   3 open GMain
   4 open Printf
   5
   6 let file_dialog ~title ~callback ?filename () =
   7   let sel = GWindow.file_selection ~title ~modal:true ?filename () in
   8   sel#cancel_button#connect#clicked ~callback:sel#destroy;
   9   sel#ok_button#connect#clicked ~callback:
  10     begin fun () ->
  11       let name = sel#get_filename in
  12       sel#destroy ();
  13       callback name
  14     end;
  15   sel#show ()
  16
  17 let w = GWindow.window ~title:"Okaimono" ()
  18 let vb = GPack.vbox ~packing:w#add ()
  19
  20 let menubar = GMenu.menu_bar ~packing:vb#pack ()
  21 let factory = new GMenu.factory menubar
  22 let file_menu = factory#add_submenu "File"
  23 let edit_menu = factory#add_submenu "Edit"
  24
  25 let sw = GBin.scrolled_window ~height:200 ~packing:vb#add
  26     ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
  27 let vp = GBin.viewport ~width:340 ~shadow_type:`NONE ~packing:sw#add ()
  28 let table = GPack.table ~columns:4 ~rows:256 ~packing:vp#add ()
  29 let _ =
  30   table#focus#set_vadjustment (Some vp#vadjustment)
  31
  32 let top = ref 0
  33 and left = ref 0
  34 let add_to_table  w =
  35   table#attach ~left:!left ~top:!top ~expand:`X w;
  36   incr left;
  37   if !left >= 4 then (incr top; left := 0)
  38
  39 let entry_list = ref []
  40
  41 let add_entry () =
  42   let entry =
  43     List.map [40;200;40;60]
  44       ~f:(fun width -> GEdit.entry ~packing:add_to_table ~width ())
  45   in entry_list := entry :: !entry_list
  46
  47 let _ =
  48   List.iter2 ["Number";"Name";"Count";"Price"] [40;200;40;60] ~f:
  49     begin fun text width ->
  50       ignore (GButton.button ~label:text ~width ~packing:add_to_table ())
  51     end;
  52   for i = 1 to 9 do add_entry () done
  53
  54 let split ~sep s =
  55   let len = String.length s in
  56   let rec loop pos =
  57     let next =
  58       try String.index_from s pos sep with Not_found -> len
  59     in
  60     let sub = String.sub s ~pos ~len:(next-pos) in
  61     if next = len then [sub] else sub::loop (next+1)
  62   in loop 0
  63
  64 let load name =
  65   try
  66     let ic = open_in name in
  67     List.iter !entry_list
  68       ~f:(fun l -> List.iter l ~f:(fun e -> e#set_text ""));
  69     let entries = Stack.create () in
  70     List.iter !entry_list ~f:(fun x -> Stack.push x entries);
  71     try while true do
  72       let line = input_line ic in
  73       let fields = split ~sep:'\t' line in
  74       let entry =
  75         try Stack.pop entries
  76         with Stack.Empty ->
  77           add_entry (); List.hd !entry_list
  78       in
  79       List.fold_left fields ~init:entry ~f:
  80         begin fun acc field ->
  81           (List.hd acc)#set_text field;
  82           List.tl acc
  83         end
  84     done
  85     with End_of_file -> close_in ic
  86   with Sys_error _ -> ()
  87
  88
  89 let save name =
  90   try
  91     let oc = open_out name in
  92     List.iter (List.rev !entry_list) ~f:
  93       begin fun entry ->
  94         let l = List.map entry ~f:(fun e -> e#text) in
  95         if List.exists l ~f:((<>) "") then
  96           let rec loop = function
  97               [] -> ()
  98             | [x] -> fprintf oc "%s\n" x
  99             | x::l -> fprintf oc "%s\t" x; loop l
 100           in loop l
 101       end;
 102     close_out oc
 103   with Sys_error _ -> ()
 104
 105 open GdkKeysyms
 106
 107 let _ =
 108   w#connect#destroy ~callback:Main.quit;
 109   w#event#connect#key_press ~callback:
 110     begin fun ev ->
 111       let key = GdkEvent.Key.keyval ev and adj = vp#vadjustment in
 112       if key = _Page_Up then
 113         adj#set_value (adj#value -. adj#page_increment)
 114       else if key = _Page_Down then
 115         adj#set_value (min (adj#value +. adj#page_increment)
 116                          (adj#upper -. adj#page_size));
 117       false
 118     end;
 119   w#add_accel_group factory#accel_group;
 120   let ff = new GMenu.factory file_menu ~accel_group:factory#accel_group in
 121   ff#add_item ~key:_O "Open..."
 122     ~callback:(file_dialog ~title:"Open data file" ~callback:load);
 123   ff#add_item ~key:_S "Save..."
 124     ~callback:(file_dialog ~title:"Save data" ~callback:save);
 125   ff#add_separator ();
 126   ff#add_item ~key:_Q "Quit" ~callback:w#destroy;
 127   let ef = new GMenu.factory edit_menu ~accel_group:factory#accel_group in
 128   ef#add_item ~key:_A "Add line" ~callback:add_entry;
 129   w#show ();
 130   Main.main ()