Yaron Minsky avatar Yaron Minsky committed 0582ba1

ported to Core, added ocamlbuild script

Comments (0)

Files changed (8)

augMap.ml

-open StdLabels
-open MoreLabels
-
-module type OrderedType = sig
-  type t
-  val compare: t -> t -> int
-end
-
-module type S = sig
-  type key
-  type 'a t
-  val empty: 'a t
-  val add: key:key -> (data:'a -> ('a t -> 'a t))
-  val find: key -> 'a t -> 'a
-  val remove: key -> 'a t -> 'a t
-  val mem:  key -> 'a t -> bool
-  val has_key: key -> 'a t -> bool
-  val iter: f:(key:key -> (data:'a -> unit)) -> ('a t -> unit)
-  val map: f:('a -> 'b) -> ('a t -> 'b t)
-  val mapi: f:(key -> 'a -> 'b) -> ('a t -> 'b t)
-  val fold: f:(key:key -> (data:'a -> ('b -> 'b))) -> ('a t -> (init:'b -> 'b))
-  val of_list: (key * 'a) list -> 'a t
-  val to_list: 'a t -> (key * 'a) list
-  val build_index: key list -> int t
-  val filter: f:(key:key -> (data:'a -> bool)) -> ('a t -> 'a t)
-  val keys: 'a t -> key list
-end
-
-module Make(Ord: OrderedType) : (S with type key = Ord.t) =
-struct
-
-  (* create the underlying map module *)
-  module UMap = Map.Make(Ord)
-  type key = UMap.key
-  type 'a t = 'a UMap.t
-  let empty = UMap.empty
-  let add = UMap.add
-  let find = UMap.find
-  let remove = UMap.remove
-  let mem = UMap.mem
-  let iter = UMap.iter
-  let map = UMap.map
-  let mapi = UMap.mapi
-  let fold = UMap.fold
-
-  let has_key key map =
-    try
-      let _ = find key map in
-        true
-    with
-        Not_found -> false
-
-  let of_list pairlist =
-    let rec loop pairlist map =
-      match pairlist with
-          [] -> map
-        | (key,data)::tl -> loop tl (add ~key ~data map)
-    in
-      loop pairlist empty
-
-  let to_list map =
-    fold ~f:(fun ~key ~data list -> (key,data)::list) map ~init:[]
-
-  (* takes a list with no duplicates, and produces a
-     map from elements of that list to indices into the list *)
-  let build_index list =
-    let rec loop list map i = match list with
-        [] -> map
-      | hd::tl -> loop tl (add ~key:hd ~data:i map) (i+1)
-    in
-      loop list empty 0
-
-  let keys map =
-    fold ~f:(fun ~key ~data:_ list -> key::list) map ~init:[]
-
-
-  let filter ~f map =
-    fold ~f:(fun ~key ~data map ->
-               if f ~key ~data
-               then add ~key ~data map
-               else map)
-      map
-    ~init:empty
-
-end
-
-

augSet.ml

-(* A painful and boring extension to the Set module.  *)
-(* This is basically a somewhat extended and more efficient 
-    implementation of Set. *)
-(* Extended in that it has of_list, exists and for_all *)
-(* More efficient in that cardinal is now (usually)
-   O(1) instead of O(n) *)
-
-open StdLabels
-open MoreLabels
-
-module type S =
-  sig
-    type elt
-    and t
-    val empty : t
-    val is_empty : t -> bool
-    val mem : elt -> t -> bool
-    val add : elt -> t -> t  
-    val singleton : elt -> t
-    val remove : elt -> t -> t
-    val union : t -> t -> t  
-    val inter : t -> t -> t  
-    val diff : t -> t -> t   
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : f:(elt -> unit) -> (t -> unit)
-    val fold : f:(elt -> 'a -> 'a) -> (t -> (init:'a -> 'a))
-    val cardinal : t -> int  (* more efficient than original *)
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val max_elt : t -> elt
-    val choose : t -> elt
-    (* these are my additions to Set.S *)
-    val of_list : elt list -> t
-    val exists : (elt -> bool) -> t -> bool
-    val for_all : (elt -> bool) -> t -> bool
-  end
-
-
-module MakeFromSet(SomeSet : Set.S ) : (S with type elt = SomeSet.elt) =
-struct 
-  type t = { set: SomeSet.t;
-	     mutable length: int; } 
-      (* a length of (-1) implies the length is currently 
-	 unknown *)
-  type elt = SomeSet.elt
-
-  let unary unary_func s =  unary_func s.set
-  let merge merge_func s t = { set = merge_func s.set t.set; length = -1 }
-  let join join_func s t = join_func s.set t.set
-  let incr v inc = if v >= 0 then v + inc else v
-
-
-  let empty = { set = SomeSet.empty; length = 0 }
-  and is_empty = unary SomeSet.is_empty
-  and mem elt s = SomeSet.mem elt s.set
-  and add elt s = 
-    if SomeSet.mem elt s.set 
-    then s
-    else { set = SomeSet.add elt s.set; length = incr s.length 1 }
-  and singleton elt = { set = SomeSet.singleton elt; length = 1 }
-  and remove elt s = 
-    if SomeSet.mem elt s.set 
-    then { set = SomeSet.remove elt s.set; length = incr s.length (-1) }
-    else s
-
-  let union = merge SomeSet.union
-  and inter = merge SomeSet.inter
-  and diff = merge SomeSet.diff
-
-  and compare = join SomeSet.compare
-  and equal = join SomeSet.equal
-  and subset = join SomeSet.subset
-
-  and iter ~f s = SomeSet.iter ~f s.set
-  and fold ~f s = SomeSet.fold ~f s.set
-  and cardinal s = 
-    (if s.length < 0 
-     then s.length <- SomeSet.cardinal s.set);
-    s.length
-  and elements = unary SomeSet.elements
-  and min_elt = unary SomeSet.min_elt
-  and max_elt = unary SomeSet.max_elt
-  and choose = unary SomeSet.choose
-
-  let of_list list =
-    let add_elem set elem = SomeSet.add elem set in
-    let new_set = List.fold_left ~f:add_elem ~init:SomeSet.empty list
-    in { set = new_set; length = -1 }
-  let exists test s = 
-    SomeSet.fold ~f:(fun elt tval -> tval || (test elt)) s.set ~init:true
-  let for_all test s = 
-    SomeSet.fold ~f:(fun elt tval -> tval && (test elt)) s.set ~init:true
-end
-
-
-module Make = functor (Elt : Set.OrderedType) -> MakeFromSet(Set.Make(Elt))
-
-
-let test () =
-  let module IntSet = Make(struct type t = int let compare = compare end) in
-  let passed = ref true in
-  let test_cond tval fail_str = if not tval then begin Printf.printf "%s\n" fail_str; passed := false end in
-  test_cond ((IntSet.cardinal IntSet.empty) = 0) "Empty set length test failed";
-
-  let set1 = IntSet.union (IntSet.of_list [1;2;3]) (IntSet.of_list [3;4;5])
-  and set2 = IntSet.of_list [1;2;3;4;5] in
-  test_cond (IntSet.equal set1 set2)  "union equality test failed";
-  test_cond ((IntSet.cardinal set1) = (IntSet.cardinal set2)) "union size test failed";
-
-  let set1 = IntSet.inter (IntSet.of_list [1;2;3;4]) (IntSet.of_list [3;4;5;6])
-  and set2 = IntSet.of_list [3;4] in
-  test_cond (IntSet.equal set1 set2)  "inter equality test failed";
-  test_cond ((IntSet.cardinal set1) = (IntSet.cardinal set2)) "inter size test failed";
-
-  let set1 = IntSet.diff (IntSet.of_list [1;2;3;4]) (IntSet.of_list [3;4;5;6])
-  and set2 = IntSet.of_list [1;2] in
-  test_cond (IntSet.equal set1 set2)  "diff equality test failed";
-  test_cond ((IntSet.cardinal set1) = (IntSet.cardinal set2)) "diff size test failed";
-  
-  test_cond ((IntSet.elements (IntSet.of_list [0;1;2;3;4;5])) = [0;1;2;3;4;5]) "of_list/elements test failed";
-  test_cond ((IntSet.max_elt (IntSet.of_list [1;3;0;5;4;2])) = 5) "max_elt test failed";
-  test_cond ((IntSet.min_elt (IntSet.of_list [1;3;0;5;4;2])) = 0) "min_elt test failed";
-
-  test_cond (IntSet.subset (IntSet.of_list [1;4;3;4;4]) (IntSet.of_list [1;2;4;65;3;4;6;4])) "Subset/of_list test failed";
-  test_cond (IntSet.mem 3 (IntSet.of_list [1;2;5;3;5;6;7])) "mem test failed";
-  test_cond ((IntSet.cardinal (IntSet.of_list [1;2;3;1;2;3;3;1]))  = 3) "cardinal test failed";
-  !passed
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  *)
 
-open StdLabels
-open MoreLabels
-
-open Tk
-open Printf
+(* Prevent Tk's Timer module being shadowed by Core's  *)
+module Timer_ = Timer
+open Core.Std
+module Timer = Timer_
 
 open State
 open Common
 open Constants
+open Tk
 
+(* period, in ms, between callbacks.  30ms corresponds to roughly 33
+   frames/sec *)
 let gap_ms = Options.named_live_value "gap_ms" 30
-               (* period, in ms, between callbacks.
-                  30ms corresponds to roughly 33 frames/sec *)
+
+(* # iterations per callback *)
 let iterations = Options.named_live_value "iterations" (gap_ms#v / 15)
-                   (* # iterations per callback *)
+
 let init_screen_width = 500
 let init_screen_height = 500
 
-let diameter_multiplier = Options.named_live_value "diameter_multiplier" 1.0
+let diameter_multiplier   = Options.named_live_value "diameter_multiplier"   1.0
 let random_vel_multiplier = Options.named_live_value "random_vel_multiplier" 1.0
 
-let penergy = Options.named_live_value "penergy" 0.0
-let kenergy = Options.named_live_value "kenergy" 0.0
-let energy = Options.named_live_value "energy" 0.0
+let penergy    = Options.named_live_value "penergy"          0.0
+let kenergy    = Options.named_live_value "kenergy"          0.0
+let energy     = Options.named_live_value "energy"           0.0
 let num_bodies = Options.named_live_value "number of bodies" 0
 
 let truebounce = new Options.live_toggle false
-let kidmode = new Options.live_toggle false
+let kidmode    = new Options.live_toggle false
 let _ =
   truebounce#set_name "truebounce";
   kidmode#set_name "kidmode"
 let app_class = "Planets"
 
 (********************************************************)
-module IntSet =
-  AugSet.Make(struct type t = int
-                     let compare = compare
-              end)
-
-(********************************************************)
 (***  Color Operations  *********************************)
 (********************************************************)
 
-let intensity r g b  = sqrt ((float_of_int r)**2.0 +.
-                              (float_of_int g)**2.0 +.
-                              (float_of_int b)**2.0)
+let intensity r g b  = sqrt ((Float.of_int r)**2.0 +.
+                              (Float.of_int g)**2.0 +.
+                              (Float.of_int b)**2.0)
 
 let max_intensity r g b =
   let maxval = max (max r g) b in
-  let mult = 255.0 /. (float_of_int maxval) in
-  let max_r = (float_of_int r) *. mult
-  and max_g = (float_of_int g) *. mult
-  and max_b = (float_of_int b) *. mult in
+  let mult = 255.0 /. (Float.of_int maxval) in
+  let max_r = (Float.of_int r) *. mult
+  and max_g = (Float.of_int g) *. mult
+  and max_b = (Float.of_int b) *. mult in
     sqrt (max_r ** 2.0 +. max_g ** 2.0 +. max_b ** 2.0)
 
 let test_color r g b =
   let m = max_intensity r g b in
   let i = intensity r g b in
   let new_i = (m +. i) /. 2.0 in
-  let r = int_of_float ((float_of_int r) *. new_i /. i)
-  and g = int_of_float ((float_of_int g) *. new_i /. i)
-  and b = int_of_float ((float_of_int b) *. new_i /. i)
+  let r = Int.of_float ((Float.of_int r) *. new_i /. i)
+  and g = Int.of_float ((Float.of_int g) *. new_i /. i)
+  and b = Int.of_float ((Float.of_int b) *. new_i /. i)
   in
     assert (test_color r g b);
     rgb r g b
   renormalize (rand_range ()) (rand_range ()) (rand_range ())
 
 let change_trace_color id color =
-  try
-    let trace = IntMap.find id transient.traces in
-      transient.traces <-
-      IntMap.add ~key:id ~data:{trace with t_color = color} transient.traces
-  with
-      Not_found -> ()
+  match Map.find transient.traces id with
+  | None -> ()
+  | Some trace ->
+    transient.traces <-
+      Map.add transient.traces ~key:id ~data:{trace with t_color = color}
 
 let change_body_color_by_id id =
   let color = rand_color () in
   let changebodies bodies =
-    List.map ~f:(fun body ->
-                   if body.id = id then
-                     { body with color = color }
-                   else
-                     body)
-      bodies
+    List.map bodies ~f:(fun body ->
+      if body.id = id then { body with color }
+      else body
+    )
+
   in
-    state.bodies <- changebodies state.bodies;
+  state.bodies <- changebodies state.bodies;
     change_trace_color id color
 
 let hlcolor = `Yellow
   let p = Physics.penergy state.bodies
   and k = Physics.kenergy state.bodies
   in
-  penergy#set (log (abs_float p));
+  penergy#set (log (Float.abs p));
   kenergy#set (log k);
-  energy#set (log (abs_float (p +. k)))
+  energy#set (log (Float.abs (p +. k)))
 
 (****************************************************)
 (****************************************************)
       mutable frame:    Widget.frame Widget.widget option;
       mutable canvas:   Widget.canvas Widget.widget option;
       mutable optionbox: ('c,'d) Options.optionbox option;
-      mutable dbodies:  'a IntMap.t;
-      mutable dtraces:  'b IntMap.t;
-      mutable tracked_ids: IntSet.t;
+      mutable dbodies:  'a Int.Map.t;
+      mutable dtraces:  'b Int.Map.t;
+      mutable tracked_ids: Int.Set.t;
       paused:   Options.live_toggle;
       tracing:  Options.live_toggle;
       tracking: Options.live_toggle;
     frame = None;
     canvas = None;
     optionbox = None;
-    dbodies = IntMap.empty;
-    dtraces = IntMap.empty;
-    tracked_ids = IntSet.empty;
+    dbodies = Int.Map.empty;
+    dtraces = Int.Map.empty;
+    tracked_ids = Int.Set.empty;
     paused = new Options.live_toggle false;
     tracing = new Options.live_toggle false;
     tracking = new Options.live_toggle false;
 
 
 
-let get_dbody id = IntMap.find id disp_state.dbodies
+let get_dbody id = Map.find disp_state.dbodies id
 let canvas () = uw disp_state.canvas
 
 let init_optionbox () =
   method draw_internal body =
     let r = body.radius *. state.zoom#v
     and (x,y) = real_to_screen body.pos in
-    let (x1,y1,x2,y2) = (int_of_float (x -. r), int_of_float (y -. r),
-                         int_of_float (x +. r), int_of_float (y +. r))
+    let (x1,y1,x2,y2) = (Int.of_float (x -. r), Int.of_float (y -. r),
+                         Int.of_float (x +. r), Int.of_float (y +. r))
     in
       Canvas.configure_oval ~fill:body.color ~outline:fgcolor (canvas ()) tag;
       Canvas.coords_set (canvas ()) tag ~xys:[ (x1,y1) ; (x2,y2) ]
 class dtrace () =
   let tag =
     try Canvas.create_line ~xys:[(0,0);(0,0)] (canvas ())
-    with e -> failwith (sprintf "line drawing failed: %s" (Printexc.to_string e))
+    with e -> failwithf "line drawing failed: %s" (Exn.to_string e) ()
   in
   let _ = Canvas.configure_line ~smooth:false (canvas ()) tag in
 object (_self)
   val mutable color = fgcolor
 
   method draw_internal (x,y) =
-    let radius = int_of_float radius in
+    let radius = Int.of_float radius in
     let coords = [(x-radius,y-radius);(x+radius,y+radius)] in
       Canvas.coords_set (canvas ()) tag ~xys:coords;
       pos <- (x,y)
 
 
 let selected_ids pos1 pos2 =
-  IntSet.of_list
+  Int.Set.of_list
     (List.map ~f:(fun body -> body.id) (selected_bodies pos1 pos2))
 
 
 
 let recenter_on_selection pos1 pos2 =
   debug_msg "recentering on selection";
-  let bodies = selected_bodies pos1 pos2 in
-    if bodies != [] then
-      begin
-        debug_msg (sprintf "recentering on %d bodies" (List.length bodies));
-        Physics.zero_speed_bodies bodies;
-        Physics.center_bodies bodies
-      end
-    else
-      debug_msg "no bodies selected to recenter on"
+  match selected_bodies pos1 pos2 with
+  | [] -> debug_msg "no bodies selected to recenter on"
+  | bodies ->
+    debug_msg (sprintf "recentering on %d bodies" (List.length bodies));
+    Physics.zero_speed_bodies bodies;
+    Physics.center_bodies bodies
 
 let create_rectangle color pos1 pos2 =
-  let (x1,y1) = pos1
-  and (x2,y2) = pos2
-  in
-    Canvas.create_rectangle ~x1 ~y1 ~x2 ~y2 ~outline:color (canvas ())
+  let (x1,y1) = pos1 in
+  let (x2,y2) = pos2 in
+  Canvas.create_rectangle ~x1 ~y1 ~x2 ~y2 ~outline:color (canvas ())
 
 
 (***********************************************************)
 (***********************************************************)
 
 let delete_dbody_id id =
-  try
-    let dbody = get_dbody id in
-      disp_state.dbodies <- IntMap.remove id disp_state.dbodies;
-      dbody#destroy
-  with Not_found ->
+  match get_dbody id with
+  | None ->
     printf "No dbody with id %d" id;
     print_newline ()
+  | Some dbody ->
+    disp_state.dbodies <- Map.remove disp_state.dbodies id;
+    dbody#destroy
 
 let delete_trace_id id =
-  try
-    let dtrace = IntMap.find id disp_state.dtraces in
-      disp_state.dtraces <- IntMap.remove id disp_state.dtraces;
-      dtrace#destroy
-  with Not_found ->
+  match Map.find disp_state.dtraces id with
+  | Some dtrace ->
+    disp_state.dtraces <- Map.remove disp_state.dtraces id;
+    dtrace#destroy
+  | None ->
     printf "No dtrace with id: %d" id;
     print_newline ()
 
  *)
 
 let get_dbody body =
-  try
-    IntMap.find body.id disp_state.dbodies
-  with
-      Not_found ->
-        let dbody = new_dbody_from_body body in
-          disp_state.dbodies <- IntMap.add ~key:body.id ~data:dbody
-            disp_state.dbodies;
-          dbody
+  match Map.find disp_state.dbodies body.id with
+  | Some x -> x
+  | None ->
+    let dbody = new_dbody_from_body body in
+    disp_state.dbodies <-
+      Map.add disp_state.dbodies ~key:body.id ~data:dbody;
+    dbody
 
 let get_dtrace id =
-  try
-    IntMap.find id disp_state.dtraces
-  with
-      Not_found ->
-        let dtrace = new dtrace () in
-          disp_state.dtraces <- IntMap.add ~key:id ~data:dtrace
-            disp_state.dtraces;
-          dtrace
+  match Map.find disp_state.dtraces id with
+  | Some x -> x
+  | None ->
+    let dtrace = new dtrace () in
+    disp_state.dtraces <-
+      Map.add disp_state.dtraces ~key:id ~data:dtrace;
+    dtrace
 
 (****************)
 
 let draw_body body = (get_dbody body)#draw body
 let draw_trace ~key:id ~data:trace = (get_dtrace id)#draw trace
-let draw_bodies () = List.iter ~f:draw_body state.bodies
-let draw_traces () = IntMap.iter ~f:draw_trace transient.traces
+let draw_bodies () = List.iter state.bodies ~f:draw_body
+let draw_traces () = Map.iter transient.traces ~f:draw_trace
 
 (****************)
 
 let change_all_body_colors () =
   let changebodies bodies =
     List.map ~f:(fun body ->
-                   let color = rand_color () in
-                     change_trace_color body.id color;
-                     { body with color = color} )
+      let color = rand_color () in
+      change_trace_color body.id color;
+      { body with color = color} )
       bodies
   in
-    state.bodies <- changebodies state.bodies
+  state.bodies <- changebodies state.bodies
 
 
 (********************************************************)
 
 let remove_dead_bodies () =
-  let disp_ids = IntSet.of_list (IntMap.keys disp_state.dbodies) in
-  let body_ids = IntSet.of_list (List.map ~f:(fun body -> body.id) state.bodies) in
-  let dead_ids = IntSet.diff disp_ids body_ids in
-    IntSet.iter ~f:delete_dbody_id dead_ids
+  let disp_ids = Int.Set.of_list (Map.keys disp_state.dbodies) in
+  let body_ids = Int.Set.of_list (List.map ~f:(fun body -> body.id) state.bodies) in
+  let dead_ids = Set.diff disp_ids body_ids in
+  Set.iter dead_ids ~f:delete_dbody_id
 
 let remove_dead_traces () =
-  let disp_ids = IntSet.of_list (IntMap.keys disp_state.dtraces) in
-  let trace_ids = IntSet.of_list (IntMap.keys transient.traces) in
-  let dead_ids = IntSet.diff disp_ids trace_ids in
-    IntSet.iter ~f:delete_trace_id dead_ids
-
+  let disp_ids = Int.Set.of_list (Map.keys disp_state.dtraces) in
+  let trace_ids = Int.Set.of_list (Map.keys transient.traces) in
+  let dead_ids = Set.diff disp_ids trace_ids in
+  Set.iter dead_ids ~f:delete_trace_id
 
 let remove_all_traces () =
-  let disp_ids = IntSet.of_list (IntMap.keys disp_state.dtraces) in
-    IntSet.iter ~f:delete_trace_id disp_ids
+  let disp_ids = Int.Set.of_list (Map.keys disp_state.dtraces) in
+  Set.iter disp_ids ~f:delete_trace_id
 
 let _ =
   disp_state.tracing#register_callback
     (fun _oldval newval ->
-       if not newval then remove_all_traces ())
+      if not newval then remove_all_traces ())
 
 let remove_dead () =
   remove_dead_bodies ();
 
 let add_dbody_from_tag body tag =
   let dbody = new_dbody_with_tag body tag in
-    disp_state.dbodies <- IntMap.add ~key:body.id ~data:dbody disp_state.dbodies
+  disp_state.dbodies <- Map.add disp_state.dbodies ~key:body.id ~data:dbody
 
 
 (* track center-of-mass *)
 let track_com () =
   if disp_state.tracking#v then
-    let tbodies = List.filter  ~f:(fun body ->
-                                     IntSet.mem body.id
-                                       disp_state.tracked_ids)
-                    state.bodies
+    let tbodies = List.filter state.bodies
+      ~f:(fun body -> Set.mem disp_state.tracked_ids body.id)
     in
-      if tbodies != [] then
-        (Physics.zero_speed_bodies tbodies;
-         Physics.center_bodies tbodies)
+    if not (List.is_empty tbodies) then
+      (Physics.zero_speed_bodies tbodies;
+       Physics.center_bodies tbodies)
 
 (*****************************************************)
 (*****************************************************)
     file_join filelist ""
 
 (* let toggle b = if b then false else true  *)
-let planet_radius i = (float_of_int i) *. 5.0 *. diameter_multiplier#v
+let planet_radius i = (Float.of_int i) *. 5.0 *. diameter_multiplier#v
 
 let is_num c =
   (int_of_char '0') <= (int_of_char c) &&
   let mult =
     if x >= 0.0
     then (x**level +. 1.0) /. 2.0
-    else (-.abs_float(x**level) +. 1.0) /. 2.0
+    else (-. Float.abs (x**level) +. 1.0) /. 2.0
   in
     mult *. f
 
   let key = e.ev_Char
   and keysym = e.ev_KeySymString in
   let rec loop handlers = match handlers with
-      handler::tl ->
-        if (match handler.key with
-                Key hkey -> hkey = key
-              | KeySym hkeysym -> hkeysym = keysym
-              | KeyList hkeys -> List.mem keysym ~set:hkeys
-              | Other -> true )
-        then
-          ( debug_msg handler.description;
-            handler.handler e; )
-        else
-          loop tl
     | [] -> debug_msg ("Other Key: " ^ keysym)
+    | handler :: tl ->
+      if
+        (match handler.key with
+        | Key hkey -> hkey = key
+        | KeySym hkeysym -> hkeysym = keysym
+        | KeyList hkeys -> List.mem hkeys keysym
+        | Other -> true )
+      then
+        ( debug_msg handler.description;
+          handler.handler e; )
+      else
+        loop tl
   in
   if kidmode#v
   then loop kid_keyhandlers
       )
   in
   let time_left_ms =
-    max 0 (int_of_float (float_of_int gap_ms#v -. MTimer.read_ms full_timer ))
+    max 0 (Int.of_float (Float.of_int gap_ms#v -. MTimer.read_ms full_timer ))
   in
   Timer.set ~ms:time_left_ms ~callback:timer_cb
 
 let set_size e =
   debug_msg "Resizing";
   let width, height = e.ev_Width, e.ev_Height in
-    screen_center := float_of_int (width/2), float_of_int (height/2);
+    screen_center := Float.of_int (width/2), Float.of_int (height/2);
     screen_width := width;
     screen_height := height
 

fqueue.ml

-(* Simple implementation of a polymorphic functional queue *)
-
-(* push and top are O(1).
-   pop and take are O(1) amortized.
-   to_list and length are O(n).
-*)
-
-(* Invariant:
-   if queue is not empty, outlist is not empty
-   queue.length = List.length(queue.outlist) + List.length(queue.inlist)*)
-
-exception Empty
-
-type 'a t = { inlist: 'a list;
-	      outlist: 'a list;
-	      length: int;
-	    }
-
-(*****************************************)
-
-(*
-let test_invariants queue =
-  assert
-    begin
-      queue.length = (List.length queue.outlist) + (List.length queue.inlist)
-    end;
-  assert
-    begin
-      (queue.length = 0) || List.length queue.outlist > 0
-    end
-*)
-
-let empty = { inlist = [];
-	      outlist = [];
-	      length = 0;
-	    }
-
-(*****************************************)
-
-let push el queue =
-  if queue.outlist = [] then
-    let outlist = List.rev (el::queue.inlist)
-    in { inlist = [];
-	 outlist = outlist;
-	 length = queue.length + 1;
-       }
-  else
-    { inlist = el::queue.inlist;
-      outlist = queue.outlist;
-      length = queue.length + 1;
-    }
-
-(*****************************************)
-
-let top queue =
-  match queue.outlist with
-  | [] ->
-    begin match queue.inlist with
-    | [] -> raise Empty
-    | _  -> failwith "FQueue.top: BUG. inlist should be empty but isn't"
-    end
-  | hd :: _ -> hd
-
-(*****************************************)
-
-let pop queue = match queue.outlist with
-    hd::[] -> (hd, { inlist = [];
-		     outlist = (List.rev queue.inlist);
-		     length = queue.length - 1})
-  | hd::tl -> (hd, { inlist = queue.inlist;
-		     outlist = tl;
-		     length = queue.length - 1;})
-  | [] ->
-      if queue.inlist = []
-      then raise Empty
-      else (match List.rev queue.inlist with
-		[] -> failwith "FQueue.top: BUG.  inlist should not be empty here"
-	      | hd::tl -> (hd, { inlist=[];
-				 outlist=tl;
-				 length = queue.length - 1;
-			       }))
-
-(*****************************************)
-
-let remove queue =
-  let (_,new_q) = pop queue in
-  new_q
-
-(*****************************************)
-
-let to_list queue =
-  queue.inlist @ (List.rev (queue.outlist))
-
-(*****************************************)
-
-let length queue = queue.length
-

fqueue.mli

-(* push and top are O(1).  
-   pop and take are O(1) amortized.
-   to_list and length are O(n).
-*)
-
-exception Empty
-type 'a t
-val empty : 'a t
-val push : 'a -> 'a t -> 'a t
-val top : 'a t -> 'a
-val pop : 'a t -> 'a * 'a t
-val remove : 'a t -> 'a t
-val to_list : 'a t -> 'a list
-val length : 'a t -> int 
 type t = { mutable start_time : float;
-	   mutable stop_time : float; 
-	   mutable running : bool;
-	 }
+           mutable stop_time : float;
+           mutable running : bool;
+         }
 
 let create () = { start_time = 0.0;
-		  stop_time = 0.0;
-		  running = false;
-		}
+                  stop_time = 0.0;
+                  running = false;
+                }
 
-let start timer = 
+let start timer =
   if timer.running then failwith "Timer started twice in a row."
   else ( timer.start_time <- Unix.gettimeofday ();
-	 timer.running <- true )
+         timer.running <- true )
 
-let stop timer = 
+let stop timer =
   if not timer.running then failwith "Timer stopped when not running."
   else ( timer.stop_time <- Unix.gettimeofday ();
-	 timer.running <- false )
+         timer.running <- false )
 
-let read timer = 
-  if timer.running 
+let read timer =
+  if timer.running
   then failwith "Timer read at wrong time"
   else timer.stop_time -. timer.start_time
 
 let read_ms timer = 1000.0 *. (read timer)
 let read_us timer = (1000.0 *. 1000.0) *. (read timer)
-  
+
-open StdLabels
-open MoreLabels
-
+open Core.Std
 open Tk
-open Printf
 open Common
 
 exception Unimplemented
 (****************************************************************)
 
 let random_chr () =
-  let rand = Random.int ((Char.code 'z') - (Char.code 'a')) in
-  Char.chr ((Char.code 'a') + rand)
+  let rand = Random.int (Char.to_int 'z' - Char.to_int 'a') in
+  Char.of_int_exn (Char.to_int 'a' + rand)
 
 let random_name length =
   let str = String.create length in
   done;
   str
 
-module StringMap = AugMap.Make(
-  struct
-    type t = string
-    let compare = compare
-  end)
-
 (*****************************************************************)
 (**  Live Values  ************************************************)
 (*****************************************************************)
         try cb value newval
         with exn -> debug_msg
           (match name with
-            None -> (sprintf "live_value#set: Callback failed with exn <%s>" (Printexc.to_string exn))
-          | Some name -> (sprintf "live_value#set %s: Callback failed with exn <%s>" name (Printexc.to_string exn))))
+          | None -> (sprintf "live_value#set: Callback failed with exn <%s>"
+                       (Exn.to_string exn))
+          | Some name -> (sprintf "live_value#set %s: Callback failed with exn <%s>"
+                            name (Exn.to_string exn))))
       callback_list
 
   method set_name newname = name <- Some newname
                          "no widget exists")
   | Some widget ->
     if Winfo.exists widget
-    then int_of_float (Scale.get widget)
+    then Int.of_float (Scale.get widget)
     else failwith ("int_scale_option#get_tk called when " ^
                       "widget does not exist")
   method set_tk v = match widget with
     None -> ()
   | Some widget ->
     if Winfo.exists widget
-    then Scale.set widget (float_of_int v)
+    then Scale.set widget (Float.of_int v)
 
 
   method build_widget ~live parent =
     self#real_to_tk;
     (if live then Scale.configure
         ~command:(fun value -> self#set_real
-          (int_of_float value)) new_widget);
+          (Int.of_float value)) new_widget);
     new_widget
 
 end
 (*******************************************************)
 
 let string_of_float x =
-  let string = string_of_float x in
+  let string = Float.to_string x in
   if string.[String.length string - 1] = '.'
   then string ^ "0"
   else string
     None -> failwith ( "float_entry_option#get_tk called " ^
                          "when no widget exists" )
   | Some entry ->
-    let float = float_of_string (Entry.get entry) in
+    let float = Float.of_string (Entry.get entry) in
     let float = if float <= 0.0 then get () else float in
     let string_rep = string_of_float float in
     Entry.delete_range ~start:(`Num 0) ~stop:`End entry;
 
   val mutable widget = None
 
-  val mutable display_map = StringMap.empty
+  val mutable display_map = String.Map.empty
   val mutable display_names = []
 
 
   method set_liveness bool = live <- bool
 
   method add_option (option : 'a display_type) =
-    if StringMap.has_key option#name display_map then
+    if Map.mem display_map option#name then
       raise (Option_exists option#name)
     else
-      ( display_map <- StringMap.add ~key:option#name
+      ( display_map <- Map.add ~key:option#name
           ~data:option display_map;
         display_names <- option#name::display_names;
       )
   (*  Called when OK button is pressed to commit all toggles.
       Not useful in live option dialog. *)
   method private read_options =
-    StringMap.iter
+    Map.iter
       ~f:(fun ~key:_ ~data:display ->
         try display#tk_to_real with Unimplemented -> ()
       )
     List.iter
       ~f:(fun name ->
         try
-          let display = StringMap.find name display_map in
+          let display = Map.find_exn display_map name in
           display#display ~live frame;
         with
           Not_found -> failwith ("Options.display_from_map: BUG." ^
+open Core.Std
+
 (*  Planets:  A celestial simulator
     Copyright (C) 2001-2003  Yaron M. Minsky
 
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)
 
-open StdLabels
-
-open Printf
+open Core.Std
 open Tk
 
-
-module IntMap = AugMap.Make(struct type t = int let compare = compare end)
-module IntSet = AugSet.Make(struct type t = int let compare = compare end)
-
-let trunc = int_of_float
-
+let trunc = Int.of_float
 
 (* Basic types *)
 type body = { pos: float * float;
 
 
 
-type transient = { mutable traces: trace IntMap.t;
+type transient = { mutable traces: trace Int.Map.t;
                    mutable trace_round: int;
                    mutable com_trace: trace;
                    bound: int Options.live_value;
                  }
 
-let transient =  { traces = IntMap.empty;
+let transient =  { traces = Int.Map.empty;
                    com_trace = empty_trace `Black;
                    trace_round = 0;
                    bound = new Options.live_value 20;
   transient.trace_round <- transient.trace_round + 1
 
 let trace_push pos trace =
-  { trace with t_queue = Fqueue.push { t_pos = pos;
-                                       t_round = transient.trace_round; }
-      trace.t_queue
+  { trace with
+    t_queue =
+      Fqueue.enqueue trace.t_queue
+        { t_pos = pos;
+          t_round = transient.trace_round; }
   }
 
 let trace_to_list trace =
     trace_queue
 
 let rec trace_filt trace =
-  try
-    let oldest = Fqueue.top trace.t_queue in
+  match Fqueue.dequeue trace.t_queue with
+  | None -> trace
+  | Some (oldest,remaining) ->
     if transient.trace_round - oldest.t_round > transient.bound#v
-    then trace_filt { trace with t_queue = Fqueue.remove trace.t_queue }
+    then trace_filt { trace with t_queue = remaining }
     else trace
-  with
-    Fqueue.Empty -> trace
 
 (*************************************************)
 (*************************************************)
 
 let add_to_trace body =
   let trace =
-    try
-      IntMap.find body.id transient.traces
-    with
-      Not_found -> empty_trace body.color
+    match Map.find transient.traces body.id with
+    | Some x -> x
+    | None -> empty_trace body.color
   in
   transient.traces <-
-    IntMap.add ~key:body.id ~data:(trace_push body.pos trace) transient.traces
+    Map.add transient.traces ~key:body.id ~data:(trace_push body.pos trace)
 
 let add_to_com_trace com =
   transient.com_trace <- trace_push com transient.com_trace
 
 let remove_empty_traces () =
-  IntMap.fold ~f:(fun ~key:id ~data:trace map ->
-    if Fqueue.length trace.t_queue = 0 then map
-    else IntMap.add ~key:id ~data:trace map)
-    transient.traces ~init:IntMap.empty
+  Map.fold transient.traces ~init:Int.Map.empty
+    ~f:(fun ~key:id ~data:trace map ->
+      if Fqueue.length trace.t_queue = 0 then map
+      else Map.add map ~key:id ~data:trace)
+
 
 let update_traces () =
   List.iter ~f:add_to_trace state.bodies;
   trace_inc ();
-  transient.traces <- IntMap.map ~f:trace_filt transient.traces;
+  transient.traces <- Map.map ~f:trace_filt transient.traces;
   transient.traces <- remove_empty_traces ()
 
 (*************************************************)
 
 let clear_trace body =
-  transient.traces <- IntMap.remove body.id  transient.traces
+  transient.traces <- Map.remove transient.traces body.id
 
 (*************************************************)
 
 let remove_traces ids =
   transient.traces <-
     List.fold_left
-    ~f:(fun map id -> IntMap.remove id map)
+    ~f:(fun map id -> Map.remove map id)
     ~init:transient.traces ids
 
 let clear_all_traces () =
-  transient.traces <- (IntMap.map
+  transient.traces <- (Map.map
                          ~f:(fun trace -> { trace with t_queue = Fqueue.empty})
                          transient.traces);
   transient.traces <- remove_empty_traces ()
 (***********************************************)
 (***********************************************)
 (***********************************************)
-let pair_to_float (x,y) = (float_of_int x, float_of_int y)
-let pair_to_int (x,y) = (int_of_float x, int_of_float y)
+let pair_to_float (x,y) = (Float.of_int x, Float.of_int y)
+let pair_to_int (x,y) = (Int.of_float x, Int.of_float y)
 
 (* Simple graphics primitves *)
 
 let wavg x1 w1 x2 w2 =
   ((x1 *. w1) +. (x2 *. w2)) /. (w1 +. w2)
 
-let round f = truncate (floor (f +. 0.5))
+let round x = Float.to_int (Float.round_nearest x)
 
 let wavgi x1 w1 x2 w2 =
   round (wavg
-           (float_of_int x1) w1
-           (float_of_int x2) w2)
+           (Float.of_int x1) w1
+           (Float.of_int x2) w2)
 
 let rgb r g b =
   `Color (sprintf "#%02X%02X%02X" r g b)
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.