]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/dcalendar.ml
* new semantics with 2 continuations
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / examples / dcalendar.ml
1 (* $Id$ *)
2
3 (* A small calendar *)
4 (* Needs Unix module, so use with lablgtk_t *)
5
6 open Printf
7
8 type date = { mutable year: int; mutable mon: int; mutable mday: int }
9
10     (* Load the schedule data *)
11 let calendar_file = Filename.concat (Sys.getenv "HOME") ".camlendar"
12
13 let schedule =
14   try
15     let ichan = open_in calendar_file in
16     let (s : (int * int * int, string) Hashtbl.t) =
17       Marshal.from_channel ichan in
18     close_in ichan;
19     s
20   with Sys_error msg ->
21     prerr_endline msg; flush stderr;
22     Hashtbl.create 13;;
23
24     (* Saves the schedule data when the application terminates *)
25 at_exit (fun () ->
26   let ochan = open_out calendar_file in
27   Marshal.to_channel ochan schedule ~mode: [];
28   close_out ochan);;
29
30     (* date: Current date initialized to "today" *)
31 let date =
32   let tm = Unix.localtime (Unix.time ()) in
33   { year = 1900 + tm.Unix.tm_year; mon = tm.Unix.tm_mon; mday = 1 }
34
35
36     (* previous_month, next_month: change application status *)
37 let previous_month () =
38   date.mday <- 1;
39   if date.mon = 0 then
40     (date.year <- date.year - 1; date.mon <- 11)
41   else date.mon <- date.mon - 1
42
43 let next_month () =
44   date.mday <- 1;
45   if date.mon = 11 then (date.year <- date.year + 1; date.mon <- 0)
46   else date.mon <- date.mon + 1
47
48     (* leap, mon_name, wday_name: Calendar related function and data *)
49 let leap year =
50   (year mod 400 = 0) or
51   (year mod 4 = 0) & (year mod 100 <> 0)
52
53 let mdays_in_month = [|31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31|]
54
55 let mon_name =
56   [|"Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
57     "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec"|]
58
59 let wday_name =
60   [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|]
61
62 let s_normal = 0 and s_focused = 1 and s_planned = 2
63 let styles =
64   let default = (Obj.magic () : GObj.style) in
65   [| default; default; default |]
66
67    (* class date_button: one button for each day in the month *)
68 class date_button i (calendar : GPack.table) =
69   let mday = i + 1 in
70
71   object (self)
72     val widget = GButton.button ~label: (string_of_int mday) ~show: false ()
73     val mday = mday
74     val mutable show = false
75     val mutable have_plan = false
76
77     method widget = widget
78     method focus_on =
79       date.mday <- mday;
80       widget#misc#set_style styles.(s_focused)
81     method focus_off =
82       widget#misc#set_style styles.(if have_plan then s_planned else s_normal)
83     method set_plan =
84       have_plan <- true;
85       widget#misc#set_style styles.(s_planned)
86     method unset_plan =
87       have_plan <- false;
88       widget#misc#set_style styles.(s_normal)
89         
90     method show wday0 =
91       if not show then
92         let top = (mday + wday0) / 7 + 1
93         and left = (mday + wday0) mod 7 in
94         calendar#attach ~left ~top ~expand:`BOTH widget#coerce;
95         widget#misc#show ();
96         show <- true
97             
98     method hide =
99       if show then
100         (widget#misc#hide ();
101          calendar#remove widget#coerce;
102          show <- false)
103   end
104
105 let update_calendar (calendar : GPack.table) (buttons : date_button array) =
106   let now = Unix.localtime (Unix.gettimeofday ()) in
107   let _, first = Unix.mktime { now with 
108                                Unix.tm_mday = 1;
109                                Unix.tm_mon = date.mon;
110                                Unix.tm_year = date.year - 1900 } in
111
112   (* wday0: day of the week of the zero'th day in the month *)
113   let wday0 = (first.Unix.tm_wday - 1 + 7) mod 7 in
114   
115   let ndays =
116     if date.mon = 1 & leap date.year then mdays_in_month.(date.mon) + 1
117     else mdays_in_month.(date.mon) in
118
119   Array.iter ~f: (fun button -> button#hide)
120     buttons;
121
122   for i = 0 to ndays - 1 do buttons.(i)#show wday0 done
123
124 let create_GUI () =
125   
126   (* views part *)
127
128   let win =
129     GWindow.window ~title: "Camlendar" ~show: true
130       ~allow_shrink: false ~allow_grow: false () in
131   win#event#connect#delete
132     ~callback: (fun _ -> GMain.Main.quit (); exit 0; false);
133
134   let style = win#misc#style#copy in
135   styles.(s_normal) <- style;
136   
137   let style = style#copy in
138   style#set_bg [`NORMAL, `NAME "light green";
139                 `PRELIGHT, `NAME "light green"];
140   styles.(s_focused) <- style;
141
142   styles.(s_focused) <- style;
143   let style = style#copy in
144   style#set_bg [`NORMAL, `NAME "sky blue";
145                 `PRELIGHT, `NAME "sky blue"];
146   styles.(s_planned) <- style;
147
148   let vbox = GPack.vbox ~packing: win#add () in
149   let packing = vbox#add in
150   let toolbar = GButton.toolbar ~style: `TEXT ~packing () in
151
152   let prev =
153     toolbar#insert_button ~text: "Prev" ~tooltip: "Show previous month" () in
154   let next =
155     toolbar#insert_button ~text: "Next" ~tooltip: "Show next month" () in
156   
157   let calendar =
158     GPack.table ~homogeneous: true ~rows: 7 ~columns: 7
159       ~border_width: 10 ~row_spacings: 2 ~col_spacings: 2 ~packing () in
160
161   Array.iteri
162     ~f: (fun i wday ->
163       ignore (GButton.button ~label: wday
164                 ~packing:(calendar#attach ~top: 0 ~left: i ~expand:`BOTH) ()))
165     wday_name;
166
167   let buttons =
168     Array.init 31 ~f: (fun i -> new date_button i calendar) in
169
170   let date_view = GMisc.label ~justify: `CENTER ~packing () in
171
172   let text = GEdit.text ~editable: true ~width: 70 ~height: 50 ~packing () in
173
174   (* Controls part *)
175
176   let save_text () =
177     let data = text#get_chars ~start: 0 ~stop: text#length in
178     let key = (date.year, date.mon, date.mday) in
179     Hashtbl.remove schedule key;
180     if data <> "" then
181       (Hashtbl.add schedule ~key ~data;
182        buttons.(date.mday - 1)#set_plan)
183     else buttons.(date.mday - 1)#unset_plan in
184
185   let restore_text () =
186     text#delete_text ~start: 0 ~stop: text#length;
187     try
188       text#insert_text ~pos: 0
189         (Hashtbl.find schedule (date.year, date.mon, date.mday));
190       ()
191     with Not_found -> () in
192
193   let update_date_view () =
194     date_view#set_text (sprintf "%d %s, %d\n"
195                           date.mday mon_name.(date.mon) date.year) in
196   
197   let update_view () =
198     update_calendar calendar buttons;
199     update_date_view ();
200     Array.iteri ~f: (fun i button ->
201       (try
202         Hashtbl.find schedule (date.year, date.mon, i + 1);
203         button#set_plan
204       with Not_found -> button#unset_plan);
205       button#focus_off) buttons;
206     win#set_title (sprintf "Camlendar: %s, %d"
207                      mon_name.(date.mon) date.year) in
208
209   prev#connect#clicked
210     ~callback: (fun () ->
211       save_text ();
212       previous_month ();
213       
214       update_view ();
215       restore_text ();
216       buttons.(0)#focus_on);
217   
218   next#connect#clicked
219     ~callback: (fun () ->
220       save_text ();
221       next_month ();
222       
223       update_view ();
224       restore_text ();
225       buttons.(0)#focus_on);
226   
227   Array.iteri
228     ~f: (fun i button ->
229       button#widget#connect#clicked
230         ~callback: (fun () ->
231           save_text ();
232           buttons.(date.mday - 1)#focus_off;
233
234           button#focus_on;
235           restore_text ();
236           update_date_view ());
237       ())
238     buttons;
239
240   update_view ();
241   buttons.(0)#focus_on;;
242
243 GMain.Main.init ();
244 print_endline (GtkMain.Main.set_locale ());
245 flush stdout;
246 create_GUI ();
247 GMain.Main.main ()