1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
(**************************************************************************)
(* Lablgtk - Examples *)
(* *)
(* This code is in the public domain. *)
(* You may freely copy parts of it in your application. *)
(* *)
(**************************************************************************)
(* $Id$ *)
open StdLabels
class planet area = object (self)
val area : GlGtk.area = area
val mutable year = 0.0
val mutable day = 0.0
val mutable eye = 0.0
val mutable time = 0.0
method tick new_time =
if time = 0. then time <- new_time else
let diff = new_time -. time in
time <- new_time;
day <- mod_float (day +. diff *. 200.) 360.0;
year <- mod_float (year +. diff *. 20.) 360.0
method day_add () =
day <- mod_float (day +. 10.0) 360.0
method day_subtract () =
day <- mod_float (day -. 10.0) 360.0
method year_add () =
year <- mod_float (year +. 5.0) 360.0
method year_subtract () =
year <- mod_float (year -. 5.0) 360.0
method eye x =
eye <- x; self#display ()
method display () =
GlClear.clear [`color;`depth];
GlDraw.color (1.0, 1.0, 1.0);
GlMat.push();
GlMat.rotate ~angle:eye ~x:1. ();
(* draw sun *)
GlLight.material ~face:`front (`specular (1.0,1.0,0.0,1.0));
GlLight.material ~face:`front (`shininess 5.0);
GluQuadric.sphere ~radius:1.0 ~slices:32 ~stacks:32 ();
(* draw smaller planet *)
GlMat.rotate ~angle:year ~y:1.0 ();
GlMat.translate ~x:3.0 ();
GlMat.rotate ~angle:day ~y:1.0 ();
GlDraw.color (0.0, 1.0, 1.0);
GlDraw.shade_model `flat;
GlLight.material ~face:`front(`shininess 128.0);
GluQuadric.sphere ~radius:0.2 ~slices:10 ~stacks:10 ();
GlDraw.shade_model `smooth;
GlMat.pop ();
Gl.flush ();
area#swap_buffers ()
end
let myinit () =
let light_ambient = 0.5, 0.5, 0.5, 1.0
and light_diffuse = 1.0, 0.8, 0.2, 1.0
and light_specular = 1.0, 1.0, 1.0, 1.0
(* light_position is NOT default value *)
and light_position = 1.0, 1.0, 1.0, 0.0
in
List.iter ~f:(GlLight.light ~num:0)
[ `ambient light_ambient; `diffuse light_diffuse;
`specular light_specular; `position light_position ];
GlFunc.depth_func `less;
List.iter ~f:Gl.enable [`lighting; `light0; `depth_test];
GlDraw.shade_model `smooth
let my_reshape ~width:w ~height:h =
GlDraw.viewport ~x:0 ~y:0 ~w ~h;
GlMat.mode `projection;
GlMat.load_identity();
GluMat.perspective ~fovy:60.0 ~aspect:(float w /. float h) ~z:(1.0,20.0);
GlMat.mode `modelview;
GlMat.load_identity();
GlMat.translate ~z:(-5.0) ()
(* Main Loop
* Open window with initial window size, title bar,
* RGBA display mode, and handle input events.
*)
open GMain
open GdkKeysyms
let main () =
let w = GWindow.window ~title:"Planet" () in
w#connect#destroy ~callback:(fun () -> Main.quit (); exit 0);
w#set_resize_mode `IMMEDIATE;
let hb = GPack.hbox ~packing:w#add () in
let area = GlGtk.area [`DOUBLEBUFFER;`RGBA;`DEPTH_SIZE 1]
~width:700 ~height:500 ~packing:hb#add () in
area#event#add [`KEY_PRESS];
let planet = new planet area in
let adjustment = GData.adjustment ~value:0. ~lower:(-90.) ~upper:90.
~step_incr:1. ~page_incr:5. ~page_size:5. () in
let scale = GRange.scale `VERTICAL ~adjustment ~draw_value:false
~packing:hb#pack () in
adjustment#connect#value_changed
~callback:(fun () -> planet#eye adjustment#value);
w#event#connect#key_press ~callback:
begin fun ev ->
let key = GdkEvent.Key.keyval ev in
if key = _Left then planet#year_subtract () else
if key = _Right then planet#year_add () else
if key = _Up then planet#day_add () else
if key = _Down then planet#day_subtract () else
if key = _Escape then w#destroy ();
planet#display ();
true
end;
Timeout.add ~ms:20 ~callback:
begin fun () ->
planet#tick (Sys.time ()); planet#display (); true
end;
area#connect#display ~callback:planet#display;
area#connect#reshape ~callback:my_reshape;
area#connect#realize ~callback:
begin fun () ->
myinit ();
my_reshape ~width:700 ~height:500
end;
w#show ();
Main.main ()
let _ = Printexc.print main ()
|
