Commits

Yaron Minsky committed f5b3ab6

first working prototype

  • Participants
  • Parent commits 652d4cc

Comments (0)

Files changed (9)

 
   val poly          : posn list -> color -> image
   val line          : posn -> posn -> color -> image
+  val circle        : posn -> float -> color -> image
   val overlay       : image list -> image
   val shift         : image -> posn -> image
   val set_pin       : image -> posn -> image
   val pin_to_center : image -> image
-  val clear_pin     : image -> image
   val pin           : image -> posn option
 
   val (+:) : scene -> image -> scene
     Canvas.create_line canvas ~xys:(to_xys t) ~fill:`Green
 end
 
+module Line = Make_shape(Line_spec)
 
 module App = struct
-  type t = { toplevel: Widget.toplevel Widget.widget;
-             frame: Widget.frame Widget.widget;
-             canvas: Widget.canvas Widget.widget;
+  type t = { toplevel : Widget.toplevel Widget.widget ;
+             frame    : Widget.frame    Widget.widget ;
+             canvas   : Widget.canvas   Widget.widget ;
            }
 
   let run ~width ~height =
+let pi = 4. *. atan 1.
+
+let time =
+  let start = Unix.gettimeofday () in
+  fun () -> Unix.gettimeofday () -. start
+
+let strips = 32
+
+let render_annulus =
+  let annulus_list = ref None in
+  fun () -> match !annulus_list with
+  | Some l -> GlList.call l
+  | None ->
+    annulus_list := Some (GlList.create `compile_and_execute);
+    GlDraw.begins `triangle_strip;
+    for i = 0 to strips do
+      let theta = 2. *. pi *. float i /. float strips in
+      let x = sin theta and y = cos theta in
+      List.iter GlDraw.vertex2 [1.5 *. x, 1.5 *. y; 2. *. x,
+                                2. *. y]
+    done;
+    GlDraw.ends ();
+    GlList.ends ()
+
+let render () =
+  GlMat.mode `projection;
+  GlMat.load_identity ();
+  GluMat.perspective ~fovy:45.0 ~aspect:1. ~z:(0.1, 1000.);
+  GluMat.look_at ~eye:(3., 3., -5.) ~center:(0., 0., 0.) ~up:(0., 1., 0.);
+  GlMat.mode `modelview;
+  GlMat.load_identity ();
+  GlClear.color (0.6, 1., 0.8);
+  GlClear.clear [`color; `depth];
+  Gl.enable `depth_test;
+  GlDraw.color (0.5 *. (1. +. sin(time ())), 0., 1.);
+  GlMat.scale ~x:0.1 ~y:0.1 ~z:0.1 ();
+  for i = 1 to 20 do
+    GlMat.rotate ~angle:(-10. *. time ()) ~x:0.25
+      ~y:1. ();
+    GlMat.translate ~x:(-2.5) ()
+  done;
+  for i = 1 to 40 do
+    GlMat.translate ~x:2.5 ();
+    GlMat.rotate ~angle:(10. *. time ()) ~x:0.25
+      ~y:1. ();
+    render_annulus ()
+  done;
+  Gl.flush ();
+  Glut.swapBuffers ()
+
+let _ =
+  let _ = Glut.init Sys.argv in
+  Glut.initDisplayMode ~depth:true ~double_buffer:true ();
+  Glut.initWindowSize ~w:512 ~h:512;
+  ignore(Glut.createWindow ~title:"Annuli OpenGL demo");
+  Glut.displayFunc ~cb:render;
+  Glut.idleFunc ~cb:(Some Glut.postRedisplay);
+  Glut.keyboardFunc ~cb:(fun ~key ~x ~y -> if key=27 then exit 0);
+  Glut.mainLoop ()
+open Core.Std
+open Geometry
+open World
+
+type world = { pos: posn;
+               vel: posn;
+             }
+
+let square s color =
+  let h = s /. 2. in
+  let path = [ posn (-. h) (-. h)
+             ; posn     h  (-. h)
+             ; posn     h      h
+             ; posn (-. h)     h
+             ]
+  in
+  poly path color
+
+let ship =
+  rotate (square 25. black) ~deg:45.
+  +< square 10. blue
+
+let display w =
+  empty_scene ~ll:(posn (-.200.) (-.200.)) ~ur:(posn 200. 200.) white
+  ++ shift ship w.pos
+
+let kick = 0.2
+
+let () =
+  big_bang
+    { pos = origin; vel = origin }
+    ~display
+    ~tick:(fun w _ -> { w with pos = w.pos +! w.vel })
+    ~key:(fun w k ->
+      match k with
+      | Up | (Char 'i') ->
+        { w with vel = w.vel +! { origin with y =    kick }}
+      | Down | Char 'k' ->
+        { w with vel = w.vel +! { origin with y = -. kick }}
+      | Left | Char 'j' ->
+        { w with vel = w.vel +! { origin with x = -. kick }}
+      | Right | Char 'l' ->
+        { w with vel = w.vel +! { origin with x =    kick }}
+      | Char 'h' ->
+        { pos = origin; vel = origin }
+      | Char 'q' ->
+        exit 0
+      | _ -> w
+    )
+
+open Core.Std
+
+type posn = { x: float; y: float }
+
+let posn x y = {x;y}
+let (+!) a b = { x = a.x +. b.x;
+                 y = a.y +. b.y;
+               }
+let (-!) a b = { x = a.x -. b.x;
+                 y = a.y -. b.y;
+               }
+
+let smult p c = { x = p.x *. c; y = p.y *. c }
+
+let pi = 2. *. asin 1.
+
+let d2r deg =
+  pi *. deg /. 180.
+
+(* cosine and sine *)
+type cs = { cos: float; sin: float }
+
+let fast_rot {x;y} {cos;sin} =
+  { x =    cos *. x +. y *. sin
+  ; y = -. sin *. x +. y *. cos
+  }
+
+let cs_of_deg deg =
+  let rad = d2r deg in
+  let cos = cos rad in
+  let sin = sin rad in
+  { cos; sin }
+
+let rot p deg =
+  fast_rot p (cs_of_deg deg)
+
+let _ = rot
+
+let scale_posn_around p ~around ~by =
+  smult (p -! around) by +! around
+
+let middle p1 p2 =
+  smult (p1 +! p2) 0.5
+
+let origin = { x = 0.; y = 0. }
+let negate p = { x = -. p.x; y = -. p.y }
+;;
+
+type color = { r: float; g: float; b: float }
+let color r g b = {r;g;b}
+
+
+let black  = color 0.   0.   0.
+let white  = color 1.   1.   1.
+let blue   = color 0.   0.   1.
+let green  = color 0.   1.   0.
+let orange = color 1.   0.5  0.
+let purple = color 1.   0.   1.
+let red    = color 1.   0.   0.
+let yellow = color 1.   1.   0.
+
+type base_image =
+| Poly   of posn * posn list * color
+| Line   of posn * posn * color
+| Circle of posn * float * color
+
+let posn_map {x;y} ~f =
+  { x = f x; y = f y }
+
+let merge_posn p1 p2 ~f =
+  { x = f p1.x p2.x
+  ; y = f p1.y p2.y
+  }
+
+let posn_min = merge_posn ~f:Float.min
+let posn_max = merge_posn ~f:Float.max
+
+let base_corners = function
+  | Poly (p, ps, _) ->
+    let corner merge = List.fold ~f:merge ~init:p ps in
+    (corner posn_min, corner posn_max)
+  | Line (p1,p2,_) ->
+    (posn_min p1 p2, posn_max p1 p2)
+  | Circle (p,r,_) ->
+    (posn_map p ~f:(fun x -> x -. r),
+     posn_map p ~f:(fun x -> x +. r))
+
+let merge_corners (ll1,ur1) (ll2,ur2) =
+  (posn_min ll1 ll2, posn_max ur1 ur2)
+
+let scale_base_image_around b ~around ~by =
+  let sp = scale_posn_around ~around ~by in
+  match b with
+  | Poly (p, ps,c) ->
+    Poly (sp p, List.map ~f:sp ps, c)
+  | Line (p1,p2,c) ->
+    Line (sp p1, sp p2, c)
+  | Circle (p,r,c) ->
+    Circle (sp p, r *. by, c)
+
+type combo =
+| Base of base_image
+| Top_bottom of combo * combo
+
+let rec combo_corners = function
+  | Base b -> base_corners b
+  | Top_bottom (t,b) ->
+    merge_corners (combo_corners t) (combo_corners b)
+
+let rec combo_map combo ~f =
+  match combo with
+  | Top_bottom (t,b) ->
+    let c = combo_map ~f in
+    Top_bottom (c t, c b)
+  | Base b -> Base (f b)
+
+type image = combo option
+
+let corners image =
+  Option.map image ~f:combo_corners
+
+let rotate ?(around=origin) ~deg image  =
+  Option.map image ~f:(fun combo ->
+    let cs = cs_of_deg deg in
+    let rot p = fast_rot (p -! around) cs +! around in
+    combo_map combo ~f:(function
+    | Poly (p,ps,c) -> Poly (rot p, List.map ~f:rot ps, c)
+    | Line (p1,p2,c) -> Line (rot p1, rot p2, c)
+    | Circle (p,r,c) -> Circle (rot p, r, c)
+    ))
+
+let scale_around image ~around ~by =
+  Option.map image ~f:(fun combo ->
+    combo_map ~f:(scale_base_image_around ~around ~by) combo)
+
+let empty_image = None
+
+let scale ?(around=origin) ~by im =
+  scale_around im ~around ~by
+
+let poly edges color =
+  match edges with
+  | [] -> failwith "Polygon should have at least one point"
+  | hd :: tl ->
+    Some (Base (Poly (hd,tl,color)))
+
+let line p1 p2 color =
+  Some (Base (Line (p1,p2,color)))
+
+let circle radius color =
+  Some (Base (Circle (origin,radius,color)))
+
+let shift image offset =
+  Option.map image ~f:(fun combo ->
+    if offset.x = 0. && offset.y = 0. then combo
+    else
+      let combo = combo_map combo ~f:(function
+        | Circle (p,r,c) ->
+          Circle (p +! offset, r, c)
+        | Line (p1,p2,c) ->
+          Line (p1 +! offset, p2 +! offset,c)
+        | Poly (p,ps,c) ->
+          let f p = p +! offset in
+          Poly (f p, List.map ~f ps, c)
+      )
+      in
+      combo
+  )
+
+let recenter image =
+  match corners image with
+  | None -> image
+  | Some (ll,ur) ->
+    let mid = smult (ll +! ur) 0.5 in
+    shift image (negate mid)
+
+let overlay ~topfirst i1 i2 =
+  match (i1,i2) with
+  | None, (_ as x) | (_ as x), None -> x
+  | Some c1, Some c2 ->
+    Some (
+      if topfirst
+      then Top_bottom (c1,c2)
+      else Top_bottom (c2,c1)
+    )
+
+let (+<) = overlay ~topfirst:false
+let (+>) = overlay ~topfirst:true
+
+let image_iter image ~f =
+  Option.iter image ~f:(fun combo ->
+    let rec iter combo =
+      match combo with
+      | Base base_image -> f base_image
+      | Top_bottom (t,b) -> iter b; iter t
+    in
+    iter combo
+  )
+
+type scene = { bg: color
+             ; ll: posn
+             ; ur: posn
+             ; image : image
+             }
+
+let empty_scene ~ll ~ur bg =
+  { bg; ll; ur ; image = empty_image }
+
+let scene_ll s = s.ll
+let scene_ur s = s.ur
+let image s = s.image
+let bg s = s.bg
+
+let (++) s i =
+  { s with image = s.image +< i }
+
+
+open Core.Std
+
+type posn = { x: float; y: float }
+val posn : float -> float -> posn
+val (+!) : posn -> posn -> posn
+val (-!) : posn -> posn -> posn
+val negate : posn -> posn
+val middle : posn -> posn -> posn
+val origin : posn
+
+type color = { r: float; g: float; b: float }
+
+val black  : color
+val blue   : color
+val green  : color
+val orange : color
+val purple : color
+val red    : color
+val white  : color
+val yellow : color
+
+type base_image =
+| Poly of posn * posn list * color
+| Line of posn * posn * color
+| Circle of posn * float * color
+
+type image
+
+val empty_image : image
+val poly : posn list -> color -> image
+val line : posn -> posn -> color -> image
+val circle : float -> color -> image
+
+val scale  : ?around:posn -> by:float  -> image -> image
+val rotate : ?around:posn -> deg:float -> image -> image
+val shift : image -> posn -> image
+val recenter : image -> image
+
+val (+<) : image -> image -> image
+val (+>) : image -> image -> image
+
+(** Iterates over the [base_image]'s in the image, from lowest to highest,
+    providing an offset for each [base_image].  *)
+val image_iter : image -> f:(base_image -> unit) -> unit
+
+type scene
+
+val empty_scene : ll:posn -> ur:posn -> color -> scene
+val scene_ll : scene -> posn
+val scene_ur : scene -> posn
+val image : scene -> image
+val bg : scene -> color
+
+val (++) : scene -> image -> scene
 open Core.Std
+open Geometry
 
+let start = Time.now ()
 
-let init () =
-  let _argv = Glut.init ~argv:Sys.argv in
-  Glut.initDisplayMode ();
-  Glut.initWindowPosition ~x:0 ~y:0;
-  Glut.initWindowSize ~w:500 ~h:500;
-  let _win_id = Glut.createWindow ~title:"foo" in
-  Glut.mainLoop ()
-;;
+let square s color =
+  let h = s /. 2. in
+  let path = [ posn (-. h) (-. h)
+             ; posn     h  (-. h)
+             ; posn     h      h
+             ; posn (-. h)     h
+             ]
+  in
+  poly path color
 
+let build_scene now =
+  let sec = Time.Span.to_sec (Time.diff now start) in
+  let scale im = scale  im ~by:(sec *. 2.)   in
+  let rot im   = rotate im ~deg:(sec *. 60.) in
+  empty_scene ~ll:(posn (-.100.) (-.100.)) ~ur:(posn 100. 100.) yellow
+  ++ rot (shift (scale (square 20. orange)) (posn 10. 40.))
+  ++ shift (square 40. red)  (posn (-10.) (-10.))
+  ++ rot (square 10. green)
 
-let () = init ()
+let gl_color {r;g;b} = (r,g,b)
+
+let command =
+  Command.basic
+    ~summary:"Test OpenGL program"
+    Command.Spec.(
+      empty
+      +> flag "-width"  (optional_with_default 512 int) ~doc:" Screen width"
+      +> flag "-height" (optional_with_default 512 int) ~doc:" Screen height"
+    )
+    (fun w h () ->
+      Glut.initDisplayMode ~double_buffer:true ();
+      Glut.initWindowSize ~w ~h;
+      ignore (Glut.createWindow ~title:"Play");
+      let scene = build_scene (Time.now ()) in
+      GlClear.color (gl_color (bg scene));
+      GlDraw.shade_model `smooth;
+      let render () =
+        let scene = build_scene (Time.now ()) in
+        GlMat.mode `projection;
+        GlMat.load_identity ();
+        let ll = scene_ll scene in
+        let ur = scene_ur scene in
+        GluMat.ortho2d ~x:(ll.x,ur.x) ~y:(ll.y, ur.y);
+        GlMat.mode `modelview;
+        GlMat.load_identity ();
+        GlClear.clear [ `color ];
+        image_iter (image scene) ~f:(fun base ->
+          match base with
+          | Circle _ -> assert false
+          | Line _ -> assert false
+          | Poly (first,rest,color) ->
+            GlDraw.begins `polygon;
+            GlDraw.color (gl_color color);
+            List.iter (first::rest) ~f:(fun posn ->
+              GlDraw.vertex2 (posn.x,posn.y));
+            GlDraw.ends ();
+        );
+        Gl.flush ();
+        Glut.swapBuffers ()
+      in
+      Glut.displayFunc ~cb:render;
+      Glut.idleFunc ~cb:(Some Glut.postRedisplay);
+      Glut.keyboardFunc ~cb:(fun ~key ~x:_ ~y:_ ->
+        printf "%4d -- %c\n%!" key (Char.of_int_exn key);
+        if Char.of_int key = Some 'q' then exit 0
+      );
+      Glut.mainLoop ()
+    )
+
+let () =
+  let argv = Array.to_list (Glut.init ~argv:Sys.argv) in
+  Command.run ~argv command
+
+open Core.Std
+open Geometry
+
+type key =
+| Char of Char.t
+| Up
+| Down
+| Left
+| Right
+| Page_up
+| Page_down
+
+let special_key_to_key = function
+  | Glut.KEY_UP -> Some Up
+  | Glut.KEY_DOWN -> Some Down
+  | Glut.KEY_PAGE_UP -> Some Page_up
+  | Glut.KEY_PAGE_DOWN -> Some Page_down
+  | Glut.KEY_LEFT -> Some Left
+  | Glut.KEY_RIGHT -> Some Right
+  | _ -> None
+
+
+let gl_color {r;g;b} = (r,g,b)
+
+let draw_base_image = function
+  | Circle _ -> assert false
+  | Line _ -> assert false
+  | Poly (first,rest,color) ->
+    GlDraw.begins `polygon;
+    GlDraw.color (gl_color color);
+    List.iter (first::rest) ~f:(fun posn ->
+      GlDraw.vertex2 (posn.x,posn.y));
+    GlDraw.ends ()
+
+let big_bang world ~display ~tick ~key =
+  let command =
+    (* Setup some shared state *)
+    let world = ref (world,display world) in
+    let render () =
+      let scene = snd !world in
+      GlMat.mode `projection;
+      GlMat.load_identity ();
+      let ll = scene_ll scene in
+      let ur = scene_ur scene in
+      GluMat.ortho2d ~x:(ll.x,ur.x) ~y:(ll.y, ur.y);
+      GlMat.mode `modelview;
+      GlMat.load_identity ();
+      GlClear.clear [ `color ];
+      image_iter (image scene) ~f:draw_base_image;
+      Gl.flush ();
+      Glut.swapBuffers ()
+    in
+    let granularity = sec 0.02 in
+    let set_world new_world =
+      world := (new_world, display new_world)
+    in
+    let rec timer_loop () =
+      let start = Time.now () in
+      let world' = tick (fst !world) start in
+      let new_world = tick world' start in
+      set_world new_world;
+      let after = Time.now () in
+      let next = Time.add start granularity in
+      let remaining = Time.diff next after in
+      Glut.timerFunc ~ms:(Float.to_int (Time.Span.to_ms remaining))
+        ~value:() ~cb:(fun ~value:() -> timer_loop ())
+    in
+    Command.basic
+      ~summary:"Test OpenGL program"
+      Command.Spec.(
+        empty
+        +> flag "-width"  (optional_with_default 512 int) ~doc:" Screen width"
+        +> flag "-height" (optional_with_default 512 int) ~doc:" Screen height"
+      )
+      (fun w h () ->
+        Glut.initDisplayMode ~double_buffer:true ();
+        Glut.initWindowSize ~w ~h;
+        ignore (Glut.createWindow ~title:"Play");
+        GlClear.color (gl_color (bg (snd !world)));
+        GlDraw.shade_model `smooth;
+        timer_loop ();
+        Glut.displayFunc ~cb:render;
+        Glut.idleFunc ~cb:(Some Glut.postRedisplay);
+        Glut.keyboardFunc ~cb:(fun ~key:key_num ~x:_ ~y:_ ->
+          set_world (key (fst !world) (Char (Char.of_int_exn key_num)))
+        );
+        Glut.keyboardFunc ~cb:(fun ~key:key_num ~x:_ ~y:_ ->
+          set_world (key (fst !world) (Char (Char.of_int_exn key_num)))
+        );
+        Glut.specialFunc ~cb:(fun ~key:special_key ~x:_ ~y:_ ->
+          let new_key = special_key_to_key special_key in
+          Option.iter new_key ~f:(fun k ->
+            set_world (key (fst !world) k)));
+        Glut.mainLoop ()
+      )
+  in
+  let argv = Array.to_list (Glut.init ~argv:Sys.argv) in
+  Command.run ~argv command
+
+open Core.Std
+open Geometry
+
+type key =
+| Char of Char.t
+| Up
+| Down
+| Left
+| Right
+| Page_up
+| Page_down
+
+
+val big_bang
+  :  'world
+  -> display:('world -> scene)
+  -> tick:('world -> Time.t -> 'world)
+  -> key:('world -> key -> 'world)
+  -> unit