helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/examples/rpn.ml

   1 (* $Id$ *)
   2
   3 (* reverse polish calculator *)
   4
   5 open GMain
   6
   7 let wow _ = prerr_endline "Wow!"; ()
   8 let main () =
   9   let stack = Stack.create () in
  10
  11   (* toplevel window *)
  12   let window =
  13     GWindow.window ~border_width: 10 ~title:"Reverse Polish Calculator" () in
  14   window#connect#destroy ~callback:Main.quit;
  15
  16
  17   (* vbox *)
  18   let vbx = GPack.vbox ~packing:window#add () in
  19
  20   (* entry *)
  21   let entry =
  22     GEdit.entry ~text:"0" ~editable:false ~max_length: 20 ~packing: vbx#add () in
  23
  24   (* BackSpace, Clear, All Clear, Quit *)
  25   let table0 = GPack.table ~rows:1 ~columns:4 ~packing:vbx#add () in
  26   let bs_clicked _ = begin
  27     let txt = entry#text in
  28     let len = String.length txt in
  29     if len <= 1 then
  30       entry#set_text "0"
  31     else entry#set_text (String.sub txt ~pos:0 ~len:(len-1))
  32   end in
  33   let c_clicked _ = entry#set_text("0") in
  34   let ac_clicked _ = Stack.clear stack; entry#set_text("0") in
  35   let labels0 = [("BS", bs_clicked) ; ("C", c_clicked);
  36                  ("AC", ac_clicked); ("Quit", window#destroy)] in
  37   let rec loop0 labels n =
  38     match labels
  39     with  [] -> ()
  40         | (lbl, cb) :: t  ->
  41     let button =
  42       GButton.button ~label:lbl
  43         ~packing:(table0#attach ~left:n ~top:1 ~expand:`BOTH) () in
  44     button#connect#clicked ~callback:cb;
  45     loop0 t (n+1) in
  46   loop0 labels0 1;
  47
  48   (* Numerals *)
  49   let table1 = GPack.table ~rows:4 ~columns:5 ~packing:vbx#add () in
  50   let labels1 = ["7"; "8"; "9"; "4"; "5"; "6"; "1"; "2"; "3"; "0"] in
  51   let numClicked n _ =
  52      let txt = entry#text in
  53      if (txt = "0") then
  54        entry#set_text n
  55      else begin
  56        entry#append_text n
  57      end in
  58   let rec loop1 labels n =
  59     match labels with [] -> ()
  60     | lbl :: lbls ->
  61         let button = GButton.button ~label:(" "^lbl^" ")
  62             ~packing:(table1#attach ~left:(n mod 3) ~top:(n/3) ~expand:`BOTH)
  63             () in
  64         button#connect#clicked ~callback:(numClicked lbl);
  65         loop1 lbls (n+1) in
  66   loop1 labels1 0;
  67
  68   (* Period *)
  69   let periodClicked _ =
  70      let txt = entry#text in
  71      if (String.contains txt '.') then begin
  72         Printf.printf "\a";
  73         flush stdout;
  74      end
  75      else
  76        entry#append_text "." in
  77   (GButton.button ~label:" . "
  78      ~packing:(table1#attach ~left:1 ~top:3 ~expand:`BOTH) ())
  79     #connect#clicked ~callback:periodClicked;
  80
  81   (* Enter (Push) *)
  82   let enterClicked _ =
  83      let txt = entry#text in
  84      let n = float_of_string txt in begin
  85        Stack.push n stack;
  86        entry#set_text "0"
  87      end in
  88   (GButton.button ~label:"Ent"
  89      ~packing:(table1#attach ~left:2 ~top:3 ~expand:`BOTH) ())
  90     #connect#clicked ~callback:enterClicked;
  91
  92   (* Operators *)
  93   let op2Clicked op _ =
  94     let n1 = float_of_string (entry#text) in
  95     let n2 = Stack.pop stack in
  96     entry#set_text (string_of_float (op n2 n1))
  97   in
  98   let op1Clicked op _ =
  99     let n1 = float_of_string (entry#text) in
 100     entry#set_text (string_of_float (op n1))
 101   in
 102   let modClicked _ =
 103     let n1 = int_of_string (entry#text) in
 104     let n2 = truncate (Stack.pop stack) in
 105     entry#set_text (string_of_int (n2 mod n1))
 106   in
 107   let labels2 = [(" / ", op2Clicked (/.)); (" * ", op2Clicked ( *. ));
 108                  (" - ", op2Clicked (-.)); (" + ", op2Clicked (+.));
 109                  ("mod", modClicked); (" ^ ", op2Clicked ( ** ));
 110                  ("+/-", op1Clicked (~-.));
 111                  ("1/x", op1Clicked (fun x -> 1.0/.x))] in
 112   let rec loop2 labels n =
 113     match labels
 114     with [] -> ()
 115     | (lbl, cb) :: t ->
 116         let button = GButton.button ~label:lbl
 117             ~packing:(table1#attach ~left:(3 + n/4) ~top: (n mod 4)
 118                         ~expand:`BOTH)
 119             () in
 120         button#connect#clicked ~callback:cb;
 121         loop2 t (n+1)
 122   in
 123   loop2 labels2 0;
 124
 125   (* show all and enter event loop *)
 126   window#show ();
 127   Main.main ()
 128
 129 let _ = Printexc.print main()