Commits

Yaron Minsky committed dce59d0

added key_up, changed how thrust works in foo

Comments (0)

Files changed (6)

 true: syntax(camlp4o)
-true: package(core,sexplib.syntax,bin_prot.syntax,comparelib.syntax,fieldslib.syntax,variantslib.syntax,labltk,lablgl.glut)
+true: package(core,sexplib.syntax,bin_prot.syntax,comparelib.syntax,fieldslib.syntax,variantslib.syntax,lablgl.glut)
 true: thread,debug,annot
 
 eval `opam config -env`
 
-echo $PATH
-echo $CAML_LD_LIBRARY_PATH
-echo `which ocamlbuild`
-
 for TARGET in $*
 do
   ocamlbuild -use-ocamlfind $TARGET -cflags "-w @A-4-33" && ./$TARGET
 open Geometry
 open World
 
+type thrust =
+  { up: bool;
+    down: bool;
+    left: bool;
+    right: bool;
+  }
+
+let init_thrust =
+  { up    = false;
+    down  = false;
+    left  = false;
+    right = false;
+  }
+
+let kick = 0.06
+let grav = posn 0. (-0.015)
+
+let acc_of_thrust thrust =
+  let zero = posn 0. 0. in
+  (if thrust.up then posn 0. (-. kick) else zero)
+  +! (if thrust.down then posn 0. kick else zero)
+  +! (if thrust.left then posn kick 0. else zero)
+  +! (if thrust.right then posn (-.kick) 0. else zero)
+
+let some_thrust {left;right;up;down} =
+  up || left || right || down
+
+type dir = Dir_up | Dir_down | Dir_left | Dir_right
+
+let get_thrust thrust dir =
+  match dir with
+  | Dir_up -> thrust.up
+  | Dir_down -> thrust.down
+  | Dir_left -> thrust.left
+  | Dir_right -> thrust.right
+
 type platform = { height: float;
                   start: float;
                   stop: float;
 
 type world = { pos: posn;
                vel: posn;
-               plats: platform list
+               plats: platform list;
+               thrust: thrust;
+               time: Time.t;
              }
 
 let onplat plat posn =
   in
   poly path color
 
-let ship =
-  rotate (square 25. (color 0.3 0.3 1.)) ~deg:45.
-  ++ square 10. yellow
-
 let platform_image p =
   let path = [ posn p.start p.height
              ; posn p.stop  p.height
   List.fold ps ~init:empty_image
     ~f:(fun x p -> x ++ platform_image p)
 
+let bg =
+  empty_scene ~ll:(posn (-.500.) (-.400.)) ~ur:(posn 500. 400.) white
+
+let sqrt3 = sqrt 3.
+
+let tri w c =
+  poly [ posn (-. w /. 2.) 0.
+       ; posn (w /. 2.) 0.
+       ; posn 0. (w *. sqrt3 /. 2.)
+       ]
+    c
+
+let flicker time c1 c2 =
+  let cond =
+    Time.to_ofday time (Zone.machine_zone ())
+    |! Time.Ofday.to_span_since_start_of_day
+    |! Time.Span.to_us
+    |! (fun x -> Float.to_int x % 2 = 0)
+  in
+  if cond then c1 else c2
+
+let ship thrust time =
+  let base_color = color 0.3 0.3 1. in
+  let corner dir =
+    if not (get_thrust thrust dir) then empty_image
+    else
+      let base =
+        let t = (tri 20. (flicker time red orange)) in
+        shift t (posn 0. 10.)
+      in
+      match dir with
+      | Dir_up -> base
+      | Dir_down -> rotate base ~deg:180.
+      | Dir_left -> rotate base ~deg:270.
+      | Dir_right -> rotate base ~deg:90.
+ in
+  rotate (square 25. base_color) ~deg:45.
+  ++ square 10. yellow
+  ++ corner Dir_up
+  ++ corner Dir_down
+  ++ corner Dir_left
+  ++ corner Dir_right
+
 let display w =
-  empty_scene ~ll:(posn (-.500.) (-.200.)) ~ur:(posn 500. 200.) white
+  bg
   +: platforms w.plats
-  +: shift ship w.pos
+  +: shift (ship w.thrust w.time) w.pos
 
 let rec on_some_plat plats posn =
   match plats with
     if onplat hd posn then true
     else on_some_plat tl posn
 
-
-let tick w _ =
-  if on_some_plat w.plats w.pos
+let tick w time =
+  if on_some_plat w.plats w.pos && w.vel.y < 0.
   then
-    if w.vel.y < 0.
-    then { w with vel = origin;}
-    else
-      { w with
-        pos = w.pos +! w.vel;
-        vel = w.vel +! posn 0. (-.0.008);
-      }
+    { w with vel = origin; time}
   else
     let new_vel =
-      if w.vel.y < 3.
-      then if w.vel.y > -3.
-        then w.vel +! posn 0. (-.0.008)
-        else { w.vel with y = -3.}
-      else { w.vel with y = 3.}
+      if w.vel.y > 5.       then { w.vel with y =  5.}
+      else if w.vel.y < -5. then { w.vel with y = -5.}
+      else w.vel +! grav +! acc_of_thrust w.thrust
+    in
+    let wrap pos =
+      if pos.x <  (scene_ll bg).x then
+        { pos with x = (scene_ur bg).x }
+      else if pos.x > (scene_ur bg).x then
+        { pos with x = (scene_ll bg).x }
+      else
+        pos
     in
     { w with
-      pos = w.pos +! w.vel;
+      pos = wrap (w.pos +! w.vel);
       vel = new_vel;
+      time;
     }
 
-let kick = 0.4
 
 let world =
   { pos = origin;
             ; platform 40. (-30.) 20.
             ; platform (-80.) (-30.) (150.)
             ; platform 120.  (-30.) 30.
-            ; platform (-195.) (-200.)200.
-            ]
+            ; platform (-195.) (-500.) 500.
+            ];
+    thrust = init_thrust;
+    time = Time.now ();
   }
 
 
 let key w k =
   match k with
   | Up | (Char 'i') ->
-    { w with vel = w.vel +! (posn 0. kick)}
+    { w with thrust = { w.thrust with up = true }}
   | Down | Char 'k' ->
-    { w with vel = w.vel +! (posn 0. (-. kick))}
+    { w with thrust = { w.thrust with down = true }}
   | Left | Char 'j' ->
-    { w with vel = w.vel +! (posn (-. kick) 0.)}
+    { w with thrust = { w.thrust with left = true }}
   | Right | Char 'l' ->
-    { w with vel = w.vel +! (posn kick 0.)}
+    { w with thrust = { w.thrust with right = true }}
   | Char 'h' ->
     { w with pos = origin; vel = origin }
   | Char 'q' ->
     exit 0
   | _ -> w
 
+let key_up w k =
+  match k with
+  | Up | (Char 'i') ->
+    { w with thrust = { w.thrust with up = false }}
+  | Down | Char 'k' ->
+    { w with thrust = { w.thrust with down = false }}
+  | Left | Char 'j' ->
+    { w with thrust = { w.thrust with left = false }}
+  | Right | Char 'l' ->
+    { w with thrust = { w.thrust with right = false }}
+  | _ -> w
+
 let () =
   big_bang world
     ~display
     ~tick
     ~key
+    ~key_up
 
+(*
+let scene = empty_scene ~ll:(posn 0. 0.) ~ur:(posn 1. 1.) blue
+let () =
+  big_bang ()
+    ~display:(fun () -> scene)
+    ~tick:(fun () _ -> ())
+    ~key:(fun () _ -> ())
+*)
   ; y = -. sin *. x +. y *. cos
   }
 
-let cs_of_deg deg =
+let deg_cs_table = Float.Table.create ()
+
+let base_cs_of_deg deg =
   let rad = d2r deg in
   let cos = cos rad in
   let sin = sin rad in
   { cos; sin }
 
+let () =
+  List.iter (List.range 0 9) ~f:(fun i ->
+    let deg = float i *. 45. in
+    Hashtbl.replace deg_cs_table ~key:deg ~data:(base_cs_of_deg deg)
+  )
+
+let cs_of_deg deg =
+  match Hashtbl.find deg_cs_table deg with
+  | Some x -> x
+  | None -> base_cs_of_deg deg
+
 let rot p deg =
   fast_rot p (cs_of_deg deg)
 
           = [posn 1. 1.001; posn 0. 0.;  posn 3. 3.]);
 ;;
 
-let _ = convex_test
+let () = convex_test ()
 
 type color = { r: float; g: float; b: float }
 let color r g b = {r;g;b}
   (Float.to_int w, Float.to_int h)
 ;;
 
-let start_world world ~w ~h ~display ~tick ~key =
+let start_world world ~w ~h ~display ~tick ~key ~key_up ~granularity =
   (* Setup some shared state *)
   let state = State.create world display in
   let render () =
     Gl.flush ();
     Glut.swapBuffers ()
   in
-  let granularity = sec 0.02 in
   let rec timer_loop () =
     let start = Time.now () in
     let world = tick (State.world state) start in
   timer_loop ();
   Glut.displayFunc ~cb:render;
   Glut.idleFunc ~cb:(Some Glut.postRedisplay);
-  Glut.keyboardFunc ~cb:(fun ~key:key_num ~x:_ ~y:_ ->
-    State.set state (key (State.world state)
+
+  let on_key ~up ~key:key_num ~x:_ ~y:_ =
+    let cb = if up then key_up else key in
+    State.set state (cb (State.world state)
                        (Char (Char.of_int_exn key_num)))
-  );
-  Glut.keyboardFunc ~cb:(fun ~key:key_num ~x:_ ~y:_ ->
-    State.set state (key (State.world state)
-                       (Char (Char.of_int_exn key_num)))
-  );
-  Glut.specialFunc ~cb:(fun ~key:special_key ~x:_ ~y:_ ->
+  in
+  Glut.keyboardFunc   ~cb:(on_key ~up:false);
+  Glut.keyboardUpFunc ~cb:(on_key ~up:true);
+
+  let on_special_key ~up ~key:special_key ~x:_ ~y:_ =
     let new_key = special_key_to_key special_key in
+    let cb = if up then key_up else key in
     Option.iter new_key ~f:(fun k ->
-      State.set state (key (State.world state) k)));
+      State.set state (cb (State.world state) k))
+  in
+  Glut.specialFunc   ~cb:(on_special_key ~up:false);
+  Glut.specialUpFunc ~cb:(on_special_key ~up:true);
+
   Glut.mainLoop ()
 
-
-
-let big_bang world ~display ~tick ~key =
+let big_bang ~display ~tick ~key ?(key_up=(fun w _ -> w)) world =
   let command =
     Command.basic
       ~summary:"Test OpenGL program"
       Command.Spec.(
+        let span = Arg_type.create Time.Span.of_string in
         empty
         +> flag "-width"  (optional_with_default 1024 int) ~doc:" Max screen width"
         +> flag "-height" (optional_with_default 768 int) ~doc:" Max screen height"
+        +> flag "-granularity" (optional_with_default (sec 0.02) span)
+          ~doc:" Time granularity"
       )
-      (fun w h () -> start_world world ~w ~h ~display ~tick ~key)
+      (fun w h granularity () ->
+        start_world world ~w ~h ~display ~tick ~key ~key_up ~granularity)
   in
   let argv = Array.to_list (Glut.init ~argv:Sys.argv) in
   Command.run ~argv command
 
+
 
 
 val big_bang
-  :  'world
-  -> display:('world -> scene)
+  :  display:('world -> scene)
   -> tick:('world -> Time.t -> 'world)
   -> key:('world -> key -> 'world)
+  -> ?key_up:('world -> key -> 'world)
+  -> 'world
   -> unit