]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/calc.ml
"Final" commit that patches termViewer while still enabling XML Diffing.
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / examples / calc.ml
1 (* $Id$ *)
2
3 (* A simple calculator ported from LablTk to LablGtk *)
4
5 let mem_string ~char s =
6   try
7     for i = 0 to String.length s -1 do
8       if s.[i] = char then raise Exit
9     done; false
10   with Exit -> true
11
12 let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)]
13
14 (* The abstract calculator class. Does not use Gtk *)
15
16 class virtual calc = object (calc)
17   val mutable x = 0.0
18   val mutable op = None
19   val mutable displaying = true
20
21   method virtual set : string -> unit
22   method virtual get : string
23   method virtual quit : unit -> unit
24   method insert s = calc#set (calc#get ^ s)
25   method get_float = float_of_string (calc#get)
26
27   initializer calc#set "0"
28
29   method command s =
30     if s <> "" then match s.[0] with
31       '0'..'9' ->
32         if displaying then (calc#set ""; displaying <- false);
33         calc#insert s
34     | '.' ->
35         if displaying then
36           (calc#set "0."; displaying <- false)
37         else
38           if not (mem_string ~char:'.' calc#get) then calc#insert s
39     | '+'|'-'|'*'|'/' as c ->
40         displaying <- true;
41         begin match op with
42           None ->
43             x <- calc#get_float;
44             op <- Some (List.assoc c ops)
45         | Some f ->
46             x <- f x (calc#get_float);
47             op <- Some (List.assoc c ops);
48             calc#set (string_of_float x)
49         end
50     | '='|'\n'|'\r' ->
51         displaying <- true;
52         begin match op with
53           None -> ()
54         | Some f ->
55             x <- f x (calc#get_float);
56             op <- None;
57             calc#set (string_of_float x)
58         end
59     | 'q' -> calc#quit ()
60     | _ -> ()
61 end
62
63 (* Buttons for the calculator *)
64
65 let m =
66   [|[|"7";"8";"9";"+"|];
67     [|"4";"5";"6";"-"|];
68     [|"1";"2";"3";"*"|];
69     [|"0";".";"=";"/"|]|]
70
71 (* The physical calculator. Inherits from the abstract one *)
72
73 open GMain
74
75 class calculator ?packing ?show () =
76   let table = GPack.table ~rows:5 ~columns:4 ~homogeneous:true ~show:false () in
77   object (calc)
78     inherit calc
79
80     val label =
81       let frame = GBin.frame ~shadow_type:`IN ()
82         ~packing:(table#attach ~left:0 ~top:0 ~right:4 ~expand:`BOTH) in
83       let evbox = GBin.event_box ~packing:frame#add () in
84       evbox#misc#set_style evbox#misc#style#copy;
85       evbox#misc#style#set_bg [`NORMAL,`WHITE];
86       GMisc.label ~justify:`RIGHT ~xalign:0.95 ~packing:evbox#add ()
87     val table = table
88
89     method set = label#set_text
90     method get = label#text
91     method quit = Main.quit
92
93     initializer
94       for i = 0 to 3 do for j = 0 to 3 do
95         let button =
96           GButton.button ~label:("  " ^ m.(i).(j) ^ "  ")
97             ~packing:(table#attach ~top:(i+1) ~left:j ~expand:`BOTH) () in
98         button#connect#clicked ~callback:(fun () -> calc#command m.(i).(j));
99       done done;
100       ignore (GObj.pack_return table ~packing ~show)
101   end
102
103 (* Finally start everything *)
104
105 let w = GWindow.window ~auto_shrink:true ()
106
107 let applet = new calculator ~packing: w#add ()
108
109 let _ =
110   w#connect#destroy ~callback: Main.quit;
111   w#event#connect#key_press
112     ~callback:(fun ev -> applet#command (GdkEvent.Key.string ev); true);
113   w#show ();
114   Main.main ()