Commits

Anonymous committed 6fa3e9f

いにしゃるこみっと

  • Participants

Comments (0)

Files changed (2)

+<html>
+  <head>
+    <meta charset="utf-8">
+    <script src="test.js"></script>
+  </head>
+  <body>
+    <h1 id="xyz">ant</h1>
+    <div id=canvas></div>
+    <div id=button></div>
+    <div id=fps></div>
+  </body>
+</html>
+open Js ;;
+
+let js = string ;;
+
+let (!%) = Printf.sprintf ;;
+
+let st = Js.string ;;
+
+module H = Dom_html ;;
+module E = Lwt_js_events ;;
+
+module Array = ArrayLabels ;;
+module List = ListLabels ;;
+
+let foi = float_of_int ;;
+let iof = int_of_float ;;
+
+let debug = true ;;
+
+let debug s =
+  if debug then Firebug.console##log (js s) ;;
+
+(* constants *)
+module C = struct
+  let w = 800. ;;
+  let h = 400. ;;
+
+  let field = 700. ;;
+  let field_h = 300. ;;
+  let space = (w -. field) /. 2. ;;
+  
+  (* 1目盛りの大きさ *)
+  let scale = 70. ;;
+
+  let fps = 50 ;;
+
+  let vel_f = scale /. foi fps
+  let vel = 1. /. (field /. scale) /. foi fps;;
+
+  let eps = 0.007
+  let pi = 3.141592
+end
+;;
+
+let cur_vel = ref C.vel ;;
+
+let document = H.document ;;
+
+let get ?(message="") () o = Opt.get o (fun () -> failwith message) ;;
+
+let button name callback =
+  let res = document##createDocumentFragment() in
+  let input = H.createInput ~_type:(js"submit") document in
+  input##value <- js name;
+  input##onclick <- H.handler (callback input);
+  Dom.appendChild res input;
+  res
+;;
+
+let radio name values callback =
+  let res = document##createDocumentFragment() in
+  let input = H.createInput ~_type:(js"radio") document in
+  let buts = List.map values ~f:(fun value ->
+    let label = H.createLabel document in
+    label##innerHTML <- js value;
+    let input = H.createInput ~name:(js name) ~_type:(js"radio") document in
+    input##value <- js value;
+    input##onchange <- H.handler (callback input);
+    Dom.appendChild label input;
+    label
+  ) in
+  List.iter buts ~f:(fun b -> Dom.appendChild res b |> ignore);
+  res
+;;
+  
+let get_canvas w h =
+  let div = Dom_html.document##getElementById (Js.string "canvas") |> get () in
+  let c = Dom_html.createCanvas Dom_html.document in
+  c##width <- w;
+  c##height <- h;
+  Dom.appendChild div c;
+  c
+;;
+
+let drawline ctx x1 y1 x2 y2 =
+  ctx##beginPath();
+  ctx##moveTo(y1, x1);
+  ctx##lineTo(y2, x2);
+  ctx##closePath();
+  ctx##stroke();
+;;
+
+let draw_init ctx = begin
+  let open C in
+  (* 枠線 *)
+  drawline ctx 0. 0. 0. w;
+  drawline ctx h  0. h  w;
+  drawline ctx 0. 0. h  0.;
+  drawline ctx 0. w  h  w;
+  (* 地面 *)
+  drawline ctx field_h space field_h (field +. space);
+
+  for i = 0 to iof (field /. scale) do
+    let x = foi i *. scale +. space in
+    let y = field_h in
+    drawline ctx (y -. 5.) x (y +. 5.) x
+  done
+end
+;;
+
+let convert_coord x =
+  if x < 50 then 0.
+  else if 750 < x then 1.
+  else begin
+    let open C in
+    let x = x - iof space in
+    foi (x - (x mod iof scale)) /. field
+  end
+;;
+
+let to_pos x = (x *. C.field +. C.space, C.field_h)
+;;
+
+let draw_rect ctx x =
+  let x = float_of_int x in
+  ctx##fillRect (x *. 70. +. 50., 230., 70., 70.);
+;;
+
+type ant = {color : string; mutable dir : float; id : int; mutable x : float} ;;
+
+let ants : ant list ref = ref [] ;;
+let counter = ref 0 ;;
+
+let next_id = ref 0 ;;
+let next_id () =
+  let i = !next_id in
+  incr next_id;
+  i
+;;
+
+let new_ant e =
+  let new_ant x =
+    let f i = 63 + 64 * i in
+    let i = !counter in
+    incr counter;
+    let r, g, b = f (i mod 4), f ((i / 4) mod 4), f ((i / 16) mod 4) in
+    {color = !% "rgb(%d, %d, %d)" r g b;
+     dir = 1.; id = next_id (); x = x} in
+  
+  let x, y = e##clientX, e##clientY in
+  let ant_x = convert_coord x in
+  try
+    let a = List.find !ants ~f:(fun a -> abs_float @@ a.x -. ant_x < C.eps) in
+    a.dir <- -. a.dir;
+  with
+  | Not_found -> ants := new_ant ant_x :: !ants
+;;
+
+type crash = {cx : float; mutable cy : float; mutable alpha : float} ;;
+let crashes : crash list ref = ref [] ;;
+
+let new_crash x =
+  {cx = x; cy = 0.; alpha = 1.}
+;;
+    
+let move_ants () =
+  let in_field nextx = nextx >= 0. && nextx < 1. in
+
+  let nextx a = a.dir *. !cur_vel +. a.x in
+  
+  List.iter !ants ~f:(fun a ->
+    List.iter !ants ~f:(fun b ->
+      if a.id <> b.id &&
+        a.dir *. b.dir < 0. &&
+        a.dir *. (b.x -. a.x) > 0. &&
+        b.dir *. (a.x -. b.x) > 0. &&
+        abs_float (a.x -. b.x) < C.eps then begin
+          crashes := new_crash a.x :: !crashes;
+          a.dir <- -. a.dir;
+          b.dir <- -. b.dir;
+        end
+    ));
+  
+  ants := List.filter !ants ~f:(fun a ->
+    let nextx = nextx a in
+    if in_field nextx then begin a.x <- nextx; true end
+    else false)
+;;
+
+let draw_arrow ctx x y w h vec =
+  ctx##translate (x,y);
+  vec ctx;
+  ctx##beginPath ();
+  ctx##moveTo (-.w,-.h);
+  ctx##lineTo (0.,-.h);
+  ctx##lineTo (0.,-.w);
+  ctx##lineTo (w, 0.);
+  ctx##lineTo (0.,w);
+  ctx##lineTo (0.,h);
+  ctx##lineTo (-.w,h);
+  ctx##lineTo (-.w,-.h);
+  ctx##stroke ();
+  ctx##fill ();
+  ctx##closePath ();
+  ctx##setTransform(1.,0.,0.,1.,0.,0.);
+;;
+
+let draw_pos ctx a =
+  let (x, y) = to_pos a.x in
+  ctx##fillStyle <- js a.color;
+  draw_arrow ctx x (y +. 10.) 10. 5. (fun ctx -> ctx##rotate (-. C.pi /. 2.))
+;;
+
+let draw_vec ctx a = begin
+  let (x, y) = to_pos a.x in
+  ctx##fillStyle <- js a.color;
+  draw_arrow ctx x (y -. 20.) 10. 5. (fun ctx -> ctx##rotate (if a.dir > 0. then 0. else -. C.pi));
+end
+
+let draw_ants ctx =
+  ctx##clearRect (0., 0., 800., 400.);
+  draw_init ctx;
+  
+  List.iter !ants ~f:(fun a ->
+    ctx##fillStyle <- (string a.color);
+    draw_pos ctx a; draw_vec ctx a)
+;;
+
+let draw_crash ctx =
+  List.iter !crashes ~f:(fun c ->
+    let convert_crash x y =
+      let open C in
+      let x = x *. C.field +. C.space in
+      let y = field_h -. 25. -. y *. 80. in
+      (x, y) in
+    let (x, y) = convert_crash c.cx c.cy in
+
+    ctx##fillStyle <- js (!% "rgba(255, 0, 0, %.1f)" c.alpha);
+    ctx##font <- js "12px 'Times New Roman'";
+    ctx##fillText (js "crash!!", x, y))
+;;
+
+let move_crash ctx =
+  List.iter !crashes ~f:(fun c ->
+    c.cy <- c.cy +. 0.01;
+    c.alpha <- c.alpha -. 0.05;);
+  crashes := List.filter !crashes ~f:(fun c -> c.alpha > 0.);
+;;
+
+let event_init ctx canvas =
+  E.mousedowns canvas (fun e _ ->
+    new_ant e;
+    draw_ants ctx;
+    Lwt.return ()) |> ignore;
+  
+  let moving = ref None in
+  let but_div = Dom_html.document##getElementById (js "button") |> get () in
+  Dom.appendChild but_div (button "move" (fun input _ -> begin
+    match !moving with
+    | None ->
+      input##value <- js "stop";
+      let open Lwt in
+      let getsec () = (jsnew date_now ())##getTime () in
+      let i = ref (to_float @@ getsec ()) in
+      let rec iter () =
+        move_ants (); draw_ants ctx;
+        move_crash ctx; draw_crash ctx;
+        Lwt_js.sleep
+          (max (1. /. foi C.fps -. (to_float (getsec ()) -. !i) /. 1000.) 0. ) >>= fun () ->
+        i := to_float @@ getsec ();
+        iter () in
+      moving := Some (iter ())
+    | Some s ->
+      input##value <- js "move";
+      Lwt.cancel s; moving := None
+  end; _false));
+
+  let fps_div = Dom_html.document##getElementById (js "fps") |> get () in
+  Dom.appendChild fps_div (radio "fps" ["x1"; "x2"; "x4"] (fun e _ ->
+    debug "called";
+    begin
+      if e##value = js "x1" then
+        cur_vel := C.vel
+      else if e##value = js "x2" then
+        cur_vel := C.vel *. 2.
+      else 
+        cur_vel := C.vel *. 4.
+    end; _false))
+;;    
+
+let onload () =
+  let c = get_canvas 800 400 in
+  let ctx = c##getContext (H._2d_) in
+  ctx##fillStyle <- (string "rgb(0, 0, 0)");
+  draw_init ctx;
+  event_init ctx c;
+;;
+
+let () = H.window##onload <- H.handler (fun _ -> onload (); _false) ;;