helm/DEVEL/lablgtk/lablgtk_20001129-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 ()