Source

play / foo.ml

open Core.Std
open Geometry
open World

type platform = { height: float;
                  start: float;
                  stop: float;
                }

let platform height start stop = { height; start; stop }

type world = { pos: posn;
               vel: posn;
               plats: platform list
             }

let onplat plat posn =
  ((posn.x <  plat.stop) && (posn.x > plat.start))
  && (posn.y > (plat.height +. 5.) && (posn.y < (plat.height +. 10.)))

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. (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
             ; posn p.stop  (p.height -. 5.)
             ; posn p.start (p.height -. 5.)
             ]
  in
  poly path orange

let platforms ps =
  List.fold ps ~init:empty_image
    ~f:(fun x p -> x ++ platform_image p)

let display w =
  empty_scene ~ll:(posn (-.500.) (-.200.)) ~ur:(posn 500. 200.) white
  +: platforms w.plats
  +: shift ship w.pos

let rec on_some_plat plats posn =
  match plats with
  | [] -> false
  | hd :: tl ->
    if onplat hd posn then true
    else on_some_plat tl posn


let tick w _ =
  if on_some_plat w.plats w.pos
  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);
      }
  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.}
    in
    { w with
      pos = w.pos +! w.vel;
      vel = new_vel;
    }

let kick = 0.4

let world =
  { pos = origin;
    vel = origin;
    plats = [ platform (-20.) 50. 100.
            ; platform 40. (-30.) 20.
            ; platform (-80.) (-30.) (150.)
            ; platform 120.  (-30.) 30.
            ; platform (-195.) (-200.)200.
            ]
  }


let key w k =
  match k with
  | Up | (Char 'i') ->
    { w with vel = w.vel +! (posn 0. kick)}
  | Down | Char 'k' ->
    { w with vel = w.vel +! (posn 0. (-. kick))}
  | Left | Char 'j' ->
    { w with vel = w.vel +! (posn (-. kick) 0.)}
  | Right | Char 'l' ->
    { w with vel = w.vel +! (posn kick 0.)}
  | Char 'h' ->
    { w with pos = origin; vel = origin }
  | Char 'q' ->
    exit 0
  | _ -> w

let () =
  big_bang world
    ~display
    ~tick
    ~key
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.