(* This program was written by Yasuhiko Minamide, nan@kurims.kyoto-u.ac.jp *)
(* $Id: tennis.ml,v 1.17 2001/05/08 01:58:26 garrigue Exp $ *)
open StdLabels
let image_height = 64
and image_width = 64
let make_image () =
let image =
GlPix.create `ubyte ~width:image_width ~height:image_height ~format:`rgba in
for i = 0 to image_width - 1 do
for j = 0 to image_height - 1 do
Raw.sets (GlPix.to_raw image) ~pos:(4*(i*image_height+j))
(if (((i land 6 ) = 6) or ((j land 6) = 6))
then [|0;0;0;255|]
else [|255;255;255;0|])
done
done;
image
let image_height = 256
and image_width = 256
let make_image2 () =
let on_circle (x0,y0) (x,y) =
let d = (x -. x0) *. (x -. x0) +. (y -. y0) *. (y -. y0) in
((d > 0.9 *. 0.9) && (d < 1.1 *. 1.1)) in
let on_line (x,y) =
if x <= -.2.0 then on_circle (-. 2.0, 0.0) (x,y)
else if x >= 2.0 then on_circle (2.0, 0.0) (x,y)
else ((0.9 < y) && (y < 1.1)) || ((-1.1 <= y) && ( y <= -0.9)) in
let on_white (i,j) =
let x = (float (i - 128) /. 128.0) *. 6.0 in
let y = (float (j - 128) /. 128.0) *. 2.0 in
on_line (x,y) in
let image =
GlPix.create `ubyte ~width:image_width ~height:image_height ~format:`rgb in
for i = 0 to image_width - 1 do
for j = 0 to image_height - 1 do
Raw.sets (GlPix.to_raw image) ~pos:(3*(i*image_height+j))
(if on_white (j,i)
then [|255;255;255|]
else [|255;255;0|])
done
done;
image
let ft x = x *. 0.03
let cw = ft (9.0 +. 4.5)
let cl = ft 39.0
let sw = ft 9.0
let sl = ft 21.0
let lw = 0.015
let wlw = 0.02
let square (x1, y1) (x2, y2) =
List.iter ~f:GlDraw.vertex2
[ x1, y1;
x2, y1;
x2, y2;
x1, y2 ]
let collide ~pos ~vel ~plane ~func =
let between (a,b,x) =
let (a,b) = if a > b then (b,a) else (a,b) in
(x > a) && (x < b) in
let (xpos,ypos,zpos) = pos in
let (dx,dy,dz) = vel in
if dx = 0.0 then (xpos, ypos +. dy, zpos +. dz) else
let ((x1,y1,z1),(x2,y2,z2)) = plane in
let y = if dy = 0.0 then ypos else (dy /. dx) *. (x1 -. xpos) +. ypos in
let z = if dz = 0.0 then zpos else (dz /. dx) *. (x1 -. xpos) +. zpos in
if between (y1, y2, y) && between (z1, z2, z) && between (xpos, xpos +. dx, x1)
then begin func (); (x1, y, z) end
else (xpos +. dx, ypos +. dy, zpos +. dz)
class ball () = object (self)
val mutable x = 0.0
val mutable y = 0.0
val mutable z = 0.2
val mutable target_x = 0.0
val mutable target_y = 0.0
val mutable velocity = 0.0
val mutable angle_z = 0.0
val mutable vel_z = 0.0
val mutable vel_y = 0.0
val mutable vel_x = 0.0
val mutable moving = false
val image = make_image2 ()
method set_vel v = velocity <- v /. 36.0;
method set_velz v = angle_z <- v
method reset = ()
method draw =
Gl.disable `blend;
GlDraw.color (1.0, 1.0, 0.0);
GlMat.push ();
GlMat.translate ~x ~y ~z ();
GluQuadric.sphere ~radius:0.01 ~slices:8 ~stacks:8 ();
GlMat.pop ()
method drawtexture =
let q = GluQuadric.create () in
GlMat.push ();
Gl.enable `texture_2d;
GlTex.image2d image;
List.iter ~f:(GlTex.parameter ~target:`texture_2d)
[ `wrap_s `repeat;
`wrap_t `repeat;
`mag_filter `nearest;
`min_filter `nearest ];
GlMat.translate ~x ~y ~z ();
GluQuadric.texture q true;
GluQuadric.sphere ~radius:0.01 ~slices:16 ~stacks:8 ~quad:q ();
Gl.disable `texture_2d;
GlMat.pop ()
method draw_shadow =
Gl.disable `blend;
GlDraw.color (0.0, 0.0, 0.0);
GlMat.push ();
GlMat.translate ~x ~y ();
GluQuadric.disk ~inner:0.0 ~outer:0.01 ~slices:8 ~loops:8 ();
GlMat.pop ()
method draw_target =
let (x,y) = (target_x, target_y) in
GlDraw.begins `quads;
GlDraw.color (0.0, 0.0, 1.0);
square (x -. 0.05, y +. 0.05) (x +. 0.05, y -. 0.05);
GlDraw.ends ()
method do_tick delta =
if moving then
let (x',y',z') = collide ~pos:(x,y,z) ~vel:(-. vel_x *. delta,
vel_y *. delta,
vel_z *. delta)
~plane:((0.0, -. cw, 0.0), (0.0, cw, 0.1))
~func:(function () ->
begin
vel_x <- 0.0;
vel_y <- 0.0;
vel_z <- 0.0
end) in
let vel_z' = vel_z in
let (z',vel_z') =
if z' < 0.01 then (-. (z' -. 0.01) +. 0.01,
-. vel_z' *. 0.7) else (z',vel_z') in
let vel_z' = vel_z' -. delta *. 0.98 in
vel_z <- vel_z';
x <- x';
y <- y';
z <- z'
else ();
moving
method set_position x' y' = x <- x'; y <- y'
method set_target x' y' = target_x <- x'; target_y <- y'
method set_z z' = z <- z' /. 100.
method get_position = (x, y)
method calc_vel =
let dx = x -. target_x
and dy = target_y -. y in
let d' = sqrt ( dx *. dx +. dy *. dy) in
let cos_z = cos(angle_z /. 180. *. 3.14) in
if cos_z = 0.0 or d' = 0.0 then () else
let dz = d' *. (tan(angle_z /. 180. *. 3.14)) in
let d = d' /. cos_z in
begin
vel_x <- velocity *. dx /. d;
vel_y <- velocity *. dy /. d;
vel_z <- velocity *. dz /. d
end
method switch = if moving then self#reset else self#calc_vel;
moving <- not moving;
moving
end
class poll = object
val r = 0.008
val y = cw +. 0.05 +. 0.008
method draw =
Gl.disable `blend;
GlDraw.color (0.0, 0.0, 0.0);
GlMat.push ();
GlMat.translate ~y ();
GluQuadric.cylinder ~slices:8 ~stacks:8 ~height:0.12 ~top:r ~base:r ();
GlMat.pop ();
GlMat.push ();
GlMat.translate ~y:(-. y) ();
GluQuadric.cylinder ~slices:8 ~stacks:8 ~height:0.12 ~top:r ~base:r ();
GlMat.pop ()
end
class court ~togl = object
val court =
Togl.make_current togl;
let court = GlList.create `compile in
GlDraw.shade_model `flat;
GlDraw.begins `quads;
GlDraw.color (0.2, 0.7, 0.2);
square (cl, cw) (-.cl, -.cw);
(* Lines *)
GlDraw.color (1.0, 1.0, 1.0);
square (-.cl, cw) (cl, cw -. lw);
square (-.cl, -.cw) (cl, -.cw +. lw);
square (cl, cw) (cl -. wlw, -. cw);
square (-.cl, cw) (-.cl +. wlw, -.cw);
square (-.sl, lw /. 2.) (sl, -.lw /. 2.);
square (-.cl, sw) (cl, sw -. lw);
square (-.cl, -.sw) (cl, -.sw +. lw);
square (sl, sw) (sl -. lw, -. sw);
square (-.sl, sw) (-.sl +. lw, -.sw);
GlDraw.ends ();
GlList.ends ();
court
method draw = GlList.call court
end
class player = object
(* position of a player *)
val mutable x = -1.0
val mutable y = 0.5
method move x' y' =
x <- -. x';
y <- y'
method position = (x,y)
end
class net ~togl = object
val texture =
Togl.make_current togl;
make_image ()
(* let image = make_image () in
GlTex.image2d image;
List.iter f:(GlTex.parameter target:`texture_2d)
[ `wrap_s `repeat;
`wrap_t `repeat;
`mag_filter `nearest;
`min_filter `nearest ]; *)
method draw =
Gl.enable `blend;
GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
GlDraw.color (0.0, 0.0, 0.0) ~alpha:1.0;
GlTex.env (`mode `replace);
Gl.enable `texture_2d;
GlTex.image2d texture;
List.iter ~f:(GlTex.parameter ~target:`texture_2d)
[ `wrap_s `repeat;
`wrap_t `repeat;
`mag_filter `nearest;
`min_filter `nearest ];
GlDraw.begins `quads;
GlTex.coord2(0.0, 0.0); GlDraw.vertex3(0.0, cw +. 0.05, 0.0);
GlTex.coord2(0.0, 3.0); GlDraw.vertex3(0.0, cw +. 0.05, 0.115);
GlTex.coord2(9.0, 3.0); GlDraw.vertex3(0.0, 0.0, 0.09);
GlTex.coord2(9.0, 0.0); GlDraw.vertex3(0.0, 0.0, 0.0);
GlTex.coord2(0.0, 0.0); GlDraw.vertex3(0.0, 0.0, 0.0);
GlTex.coord2(0.0, 3.0); GlDraw.vertex3(0.0, 0.0, 0.09);
GlTex.coord2(9.0, 3.0); GlDraw.vertex3(0.0, -.cw -. 0.05, 0.115);
GlTex.coord2(9.0, 0.0); GlDraw.vertex3(0.0, -.cw -. 0.05, 0.0);
GlDraw.ends ();
Gl.disable `texture_2d;
Gl.disable `blend;
GlDraw.color (1.0, 1.0, 1.0);
GlDraw.begins `quad_strip;
List.iter ~f:(fun (y,z) -> GlDraw.vertex ~x:0. ~y ~z ())
[ cw +. 0.05, 0.11;
cw +. 0.05, 0.115;
0.0, 0.085;
0.0, 0.09;
-.cw -. 0.05, 0.11;
-.cw -. 0.05, 0.115 ];
GlDraw.ends ()
end
class view3d ~togl ~ball ~player ~viewtype = object
val ball : ball = ball
val player : player = player
val court = new court ~togl
val net = new net ~togl
val poll = new poll
method draw =
Togl.make_current togl;
GlClear.color (0.5, 0.5, 1.0);
GlClear.clear [`color;`depth];
if viewtype () = "Top View" then
begin
GlMat.mode `projection;
GlMat.load_identity ();
GlMat.rotate ~angle:90.0 ~z:1.0 ();
GlMat.ortho ~x:(-1.2,1.2) ~y:(-1.2,1.2) ~z:(0.0,2.0);
GlMat.mode `modelview;
GlMat.load_identity ();
GluMat.look_at
~eye:(0.0, 0.0, 2.0) ~center:(0.0, 0.0, 0.0) ~up:(0.0, 1.0, 0.0)
end
else
begin
GlMat.mode `projection;
GlMat.load_identity ();
GluMat.perspective ~fovy:40.0 ~aspect:1.0 ~z:(0.1,4.0);
GlMat.mode `modelview;
if viewtype () = "Center" then
begin
GlMat.load_identity ();
let (x,y) = player#position in
GluMat.look_at
~eye:(x, y, 0.2) ~center:(0.0, 0.0, 0.09) ~up:(-. x, -. y, 0.0)
end
else
begin
GlMat.load_identity ();
let (x,y) = player#position in
let (x',y') = ball#get_position in
GluMat.look_at
~eye:(x, y, 0.2) ~center:(x', y', 0.09) ~up:(x' -. x, y' -. y, 0.0)
end;
end;
GlDraw.shade_model `flat;
(* Ground *)
GlDraw.begins `quads;
GlDraw.color (0.5, 0.5, 0.5);
square (-5.0, 5.0) (5.0, -5.0);
GlDraw.ends ();
court#draw;
let (x,y) = ball#get_position
in
if x < 0.0 then
(net#draw;
ball#draw_shadow;
ball#draw)
else
(ball#draw_shadow;
ball#draw;
net#draw);
poll#draw;
Togl.swap_buffers togl;
Gl.flush ()
end
class view2d ~togl ~ball ~player = object
val ball : ball = ball
val player : player = player
val court = new court ~togl:togl
method draw =
Togl.make_current togl;
GlClear.clear [`color;`depth];
GlMat.mode `projection;
GlMat.load_identity ();
GlMat.rotate ~angle:90.0 ~z:1.0 ();
GlMat.ortho ~x:(-1.5,1.5) ~y:(-1.5,1.5) ~z:(0.0,2.0);
GlMat.mode `modelview;
GlMat.load_identity ();
let (x,y) = player#position in
GluMat.look_at
~eye:(0.0, 0.0, 2.0) ~center:(0.0, 0.0, 0.0) ~up:(0.0, 1.0, 0.0);
court#draw;
ball#draw;
let (x,y) = player#position in
GlDraw.begins `quads;
GlDraw.color (1.0, 0.0, 0.0);
square (x -. 0.02, y +. 0.02) (x +. 0.02, y -. 0.02);
GlDraw.ends ();
ball#draw_target;
Togl.swap_buffers togl;
Gl.flush ()
end
open Tk
let main () =
let top = openTk () in
Wm.title_set top "Tennis Court";
let f0 = Frame.create top in
let court3d =
Togl.create f0 ~width:600 ~height:600
~rgba:true ~double:true ~depth:true
and f1 = Frame.create f0 in
let court2d =
Togl.create f1 ~width:200 ~height:200
~rgba:true ~double:true ~depth:true
and sx =
Scale.create f1 ~label:"Velocity"
~min:0. ~max:200. ~orient:`Horizontal
and sz =
Scale.create f1 ~label:"Direction"
~min: (-. 90.) ~max:90. ~orient:`Horizontal
and sht =
Scale.create f1 ~label:"Height"
~min: 0. ~max:100. ~orient:`Horizontal
and start =
Button.create f1 ~text:"Start"
in
let viewseltv = Textvariable.create () in
Textvariable.set viewseltv "Top View";
let viewself = Frame.create f1 in
let viewsel = List.map ["Top View"; "Center"; "Ball"] ~f:
begin fun t ->
Radiobutton.create viewself ~text: t ~value: t
~variable: viewseltv
end
in
pack viewsel;
let viewtype = fun () -> Textvariable.get viewseltv in
let ball = new ball () in
let player = new player in
let view3d = new view3d ~togl:court3d ~viewtype ~ball ~player
and view2d = new view2d ~togl:court2d ~ball ~player
in
Scale.configure sx ~command:(ball#set_vel);
Scale.configure sz ~command:(ball#set_velz);
Button.configure start ~command:
begin fun () ->
Button.configure start ~text:(if ball#switch then "Stop" else "Start")
end;
Togl.timer_func ~ms:20
~cb:(fun () -> if ball#do_tick 0.02 then (view3d#draw; view2d#draw));
Togl.display_func court3d ~cb:(fun () -> view3d#draw);
Togl.display_func court2d ~cb:(fun () -> view2d#draw);
bind court3d ~events:[`Modified([`Button1],`Motion)] ~fields:[`MouseX;`MouseY]
~action:(fun ev ->
let width = Togl.width court3d
and height =Togl.height court3d in
let y = -. (float ev.ev_MouseX /. float width) +. 0.5
and x = float ev.ev_MouseY /. float height in
player#move x y;
view2d#draw;
view3d#draw);
bind court2d ~events:[`Modified([`Button1],`Motion)] ~fields:[`MouseX;`MouseY]
~action:(fun ev ->
let width = Togl.width court2d
and height =Togl.height court2d in
let y = (float ev.ev_MouseX /. float width ) -. 0.5
and x = (float ev.ev_MouseY /. float height) -. 0.5 in
let y = -. (y *. 3.0)
and x = -. (x *. 3.0) in
ball#set_position x y;
view2d#draw;
view3d#draw);
bind court2d ~events:[`Modified([`Button2],`Motion)] ~fields:[`MouseX;`MouseY]
~action:(fun ev ->
let width = Togl.width court2d
and height =Togl.height court2d in
let y = (float ev.ev_MouseX /. float width ) -. 0.5
and x = (float ev.ev_MouseY /. float height) -. 0.5 in
let y = -. (y *. 3.0)
and x = -. (x *. 3.0) in
ball#set_target x y;
print_float x;
print_float y;
print_string "\n";
view2d#draw;
view3d#draw);
let rec viewselfn () =
begin
Textvariable.handle viewseltv ~callback:viewselfn;
view3d#draw
end in
viewselfn ();
Scale.configure sht ~command:(fun z -> ball#set_z z; view3d#draw);
pack [coe court2d; coe sx; coe sz; coe sht;coe start; coe viewself];
pack [coe court3d; coe f1] ~side:`Left;
pack [f0] ~expand:true ~fill:`Both;
mainLoop ()
let _ = main ()
