]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/kaimono.ml
* new semantics with 2 continuations
[helm.git] / 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 ()