]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/rpn.ml
"Final" commit that patches termViewer while still enabling XML Diffing.
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-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()