Commits

Yaron Minsky committed c127c02

fixed many small compilation warnings

Comments (0)

Files changed (11)

 *.cmi
 *.o
 *.gz
+*.native
+*.byte
+_build
 true: syntax(camlp4o)
-true: package(core,sexplib.syntax,bin_prot.syntax,comparelib.syntax,fieldslib.syntax,variantslib.syntax)
+true: package(core,sexplib.syntax,bin_prot.syntax,comparelib.syntax,fieldslib.syntax,variantslib.syntax,labltk,str)
 true: thread,debug,annot
 open StdLabels
 open MoreLabels
 
-module type OrderedType =
-sig
+module type OrderedType = sig
   type t
   val compare: t -> t -> int
 end
 
-module type S =
-sig
+module type S = sig
   type key
   type 'a t
   val empty: 'a t
   val keys: 'a t -> key list
 end
 
-module Make(Ord: OrderedType) : (S with type key = Ord.t) = 
+module Make(Ord: OrderedType) : (S with type key = Ord.t) =
 struct
 
   (* create the underlying map module *)
   let fold = UMap.fold
 
   let has_key key map =
-    try 
+    try
       let _ = find key map in
-	true
+        true
     with
-	Not_found -> false
+        Not_found -> false
 
-  let of_list pairlist = 
-    let rec loop pairlist map = 
+  let of_list pairlist =
+    let rec loop pairlist map =
       match pairlist with
-	  [] -> map
-	| (key,data)::tl -> loop tl (add key data map)
+          [] -> map
+        | (key,data)::tl -> loop tl (add ~key ~data map)
     in
       loop pairlist empty
 
-  let to_list map = 
+  let to_list map =
     fold ~f:(fun ~key ~data list -> (key,data)::list) map ~init:[]
 
-  (* takes a list with no duplicates, and produces a 
+  (* 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 build_index list =
     let rec loop list map i = match list with
-	[] -> map
+        [] -> 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:[]
+    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)
+    fold ~f:(fun ~key ~data map ->
+               if f ~key ~data
+               then add ~key ~data map
+               else map)
       map
     ~init:empty
 
   initializer
     begin
       Canvas.bind ~events:[`ButtonPress] ~extend:false ~fields:[]
-        ~action:(fun e -> delete_body_by_id id)
-                   (* change_body_color_by_id id)  *)
+        ~action:(fun _ -> delete_body_by_id id)
         (canvas ()) tag;
       self#draw_internal body
     end
     with e -> failwith (sprintf "line drawing failed: %s" (Printexc.to_string e))
   in
   let _ = Canvas.configure_line ~smooth:false (canvas ()) tag in
-object (self)
+object (_self)
   inherit [trace] display_item tag
 
   method draw_internal trace =
   let pos = planet#pos in
   let tag = Canvas.create_line ~xys:[pos; pos] ~arrow:`Last (canvas ()) in
   let _ = Canvas.configure_line ~fill:fgcolor  (canvas ()) tag in
-object (self)
+object (_self)
 
   inherit ['a] display_item tag
 
 
 let _ =
   disp_state.tracing#register_callback
-    (fun oldval newval ->
+    (fun _oldval newval ->
        if not newval then remove_all_traces ())
 
 let remove_dead () =
 
 let rdist ?(n=6) low high =
   let x = ref 0.0 in
-  for i = 0 to n -1 do
+  for _i = 0 to n - 1 do
     x := !x +. Random.float (1.0/. float n)
   done;
   low +. (high -. low) *. !x
   let matcher = match h.key with
       Key s -> s
     | KeySym s -> s
-    | KeyList slist -> String.concat ", " slist
+    | KeyList slist -> String.concat ~sep:", " slist
     | Other -> "Any other key"
   in
   "\t" ^ matcher ^
 
 let hlist_to_string hlist =
   let slist = List.map ~f:handler_to_string hlist in
-  String.concat "\n" slist
+  String.concat ~sep:"\n" slist
 
 (***********************************************************)
 
     pos2 := (e.ev_MouseX,e.ev_MouseY);
     Canvas.coords_set (canvas ()) tag ~xys:[!pos1; !pos2]
 
-  and finish pause_state e =
+  and finish pause_state _ =
     Canvas.delete (canvas ()) [tag];
     disp_state.tracked_ids <- selected_ids !pos1 !pos2;
     disp_state.paused#set pause_state;
       bind ~events:[`ButtonPress] ~extend:false ~fields:[] ~action:(finish pause_state planet velocity)
         (uw disp_state.canvas)
 
-  and finish pause_state planet velocity e =
+  and finish pause_state planet velocity _ =
     bind ~events:[`Motion] ~extend:false (uw disp_state.canvas);
     bind ~events:[`ButtonPress] ~extend:false (uw disp_state.canvas);
     restore_normal_bindings ();
     { key = Key "H";
       description = (Lstrings.get `display_help );
       handler =
-        (fun e ->
-           Help.create_window (uw disp_state.toplevel)
-           (hlist_to_string keyhandlers));
+        (fun _ ->
+          Help.create_window (uw disp_state.toplevel)
+            (hlist_to_string keyhandlers));
     };
 
     { key =  Key "a";
 
     { key = KeyList ["plus";"equal";"KP_Add"];
       description = (Lstrings.get `zoom_in );
-      handler = (fun e ->
+      handler = (fun _ ->
                    state.zoom#set (state.zoom#v *. 1.1);
                    redraw_all_basic ());
     };
     { key = KeyList ["minus";"underscore"; "KP_Subtract"];
       description = (Lstrings.get `zoom_out );
-      handler = (fun e ->
+      handler = (fun _ ->
                    state.zoom#set (state.zoom#v /. 1.1);
                    redraw_all_basic ());
     };
 
     { key = Key "b";
       description = (Lstrings.get `toggle_true_bounce);
-      handler = (fun e -> truebounce#flip;)
+      handler = (fun _ -> truebounce#flip;)
     };
 
     { key = KeyList ["c"; "space"];
       description =  (Lstrings.get `center);
-      handler = (fun e ->
+      handler = (fun _ ->
                    disp_state.tracking#set false;
                    Physics.zero_speed ();
                    Physics.center ();
     };
     { key = Key "k";
       description = (Lstrings.get `option_dialog);
-      handler = (fun e -> toggle_opt_dialog ())
+      handler = (fun _ -> toggle_opt_dialog ())
     };
     { key = Key "o";
       description = (Lstrings.get `change_all_colors);
-      handler = (fun e ->
+      handler = (fun _ ->
                    change_all_body_colors ();
                    redraw_all_basic ());
     };
     { key = KeyList [ "q" ; "Escape"] ;
       description = (Lstrings.get `quit);
-      handler = (fun e -> exit 0);
+      handler = (fun _ -> exit 0);
     };
     { key = Key "e" ;
       description = (Lstrings.get `reset);
-      handler = (fun e ->
+      handler = (fun _ ->
                    clear_all_traces ();
                    state.bodies <- [];
                    redraw_all ());
     };
     { key = Key "s";
       description =  (Lstrings.get `save );
-      handler = (fun e ->
+      handler = (fun _ ->
                    let old_pause_state = disp_state.paused#v in
                      disp_state.paused#set true;
                      get_next_key ~f:(fun key ->
     };
     { key = Key "l";
       description = (Lstrings.get `load);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let old_pause_state = disp_state.paused#v in
                      disp_state.paused#set true;
                      get_next_key ~f:(fun key ->
     };
     { key = Key "u";
       description = (Lstrings.get `undo);
-      handler = (fun e ->
+      handler = (fun _ ->
                    undo ();
                    clear_all_traces ();
                    redraw_all ())
 
     { key = Key "g";
       description = (Lstrings.get `goback);
-      handler = (fun e ->
+      handler = (fun _ ->
                    goback ();
                    clear_all_traces ();
                    redraw_all ())
     };
     { key = Key "p";
       description = (Lstrings.get `toggle_pause);
-      handler = (fun e ->
+      handler = (fun _ ->
                    disp_state.paused#flip)
     };
     { key = Key "t";
       description = (Lstrings.get `toggle_trace);
-      handler = (fun e ->
+      handler = (fun _ ->
                    disp_state.tracing#flip)
     };
 
     { key = Key "d";
       description = (Lstrings.get `double_trace);
-      handler = (fun e ->
+      handler = (fun _ ->
                    transient.bound#set (min 300 (transient.bound#v * 2)));
     };
 
     { key = Key "h";
       description = (Lstrings.get `halve_trace );
-      handler = (fun e ->
+      handler = (fun _ ->
                    transient.bound#set (max 3 (transient.bound#v / 2))
                 )
     };
 
     { key = Key "j";
       description = (Lstrings.get `place_random_orbital );
-      handler = (fun e ->
+      handler = (fun _ ->
                    orbital_planet (Random.int 2 = 1) )
     };
 
     { key = Key "J";
       description = (Lstrings.get `place_random_orbital_uni );
-      handler = (fun e -> orbital_planet true)
+      handler = (fun _ -> orbital_planet true)
     };
 
     { key = Key "r";
       description = (Lstrings.get `place_random );
-      handler = (fun e ->
+      handler = (fun _ ->
                    random_planet () )
     };
 
 
     { key = Key "x";
       description = (Lstrings.get `cancel_com );
-      handler = (fun e ->
+      handler = (fun _ ->
                    disp_state.tracking#flip;
                 )
     };
     (* Panning Around *)
     { key = KeySym "Up";
       description = (Lstrings.get `pan_up);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let y_s = y_s -. (float !screen_height)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
 
     { key = KeySym "Down";
       description = (Lstrings.get `pan_down);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let y_s = y_s +. (float !screen_height)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
     };
     { key = KeySym "Left";
       description = (Lstrings.get `pan_left);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let x_s = x_s -. (float !screen_width)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
     };
     { key = KeySym "Right";
       description = (Lstrings.get `pan_right);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let x_s = x_s +. (float !screen_width)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
                      "KP_Delete"; "KP_En`ter"; "KP_Add"; "KP_Multiply";
                      "KP_Divide"; "Num_Lock"; ];
       description = (Lstrings.get `place_random );
-      handler = (fun e ->
+      handler = (fun _ ->
                    random_planet () )
     };
 
     { key = Key "=";
       description = (Lstrings.get `zoom_in );
-      handler = (fun e ->
+      handler = (fun _ ->
                    state.zoom#set (state.zoom#v *. 1.1);
                    redraw_all_basic ());
     };
     { key = Key "-";
       description = (Lstrings.get `zoom_out );
-      handler = (fun e ->
+      handler = (fun _ ->
                    state.zoom#set (state.zoom#v *. 0.9);
                    redraw_all_basic ());
     };
 
     { key = KeySym "Up";
       description = (Lstrings.get `pan_up);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let y_s = y_s -. (float !screen_height)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
     };
     { key = KeySym "Down";
       description = (Lstrings.get `pan_down);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let y_s = y_s +. (float !screen_height)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
     };
     { key = KeySym "Left";
       description = (Lstrings.get `pan_left);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let x_s = x_s -. (float !screen_width)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
     };
     { key = KeySym "Right";
       description =  (Lstrings.get `pan_right);
-      handler = (fun e ->
+      handler = (fun _ ->
                    let (x_s,y_s) = real_to_screen(state.center#v) in
                    let x_s = x_s +. (float !screen_width)/.30.0 in
                    let (x,y) = screen_to_real( pair_to_int (x_s,y_s) ) in
     };
     { key = KeySym "space";
       description =  (Lstrings.get `center);
-      handler = (fun e ->
+      handler = (fun _ ->
                    disp_state.tracking#set false;
                    Physics.zero_speed ();
                    Physics.center ();
     };
     { key = KeyList ["q";"w";"e";"a";"s";"d";"z";"x";"c"];
       description = (Lstrings.get `change_all_colors);
-      handler = (fun e ->
+      handler = (fun _ ->
                    change_all_body_colors ();
                    redraw_all_basic ());
     };
 
     { key = KeyList ["1";"2";"3";"4";"5";"6";"7";"8";"9"];
       description = (Lstrings.get `toggle_trace);
-      handler = (fun e ->
+      handler = (fun _ ->
                    disp_state.tracing#flip)
     };
 
 
     { key = KeySym "Escape";
       description = (Lstrings.get `reset);
-      handler = (fun e ->
+      handler = (fun _ ->
                    clear_all_traces ();
                    state.bodies <- [];
                    redraw_all ());
 
     { key = Other;
       description = (Lstrings.get `place_random );
-      handler = (fun e -> orbital_planet (Random.int 2 = 0) )
+      handler = (fun _ -> orbital_planet (Random.int 2 = 0) )
     };
   ]
 
         if (match handler.key with
                 Key hkey -> hkey = key
               | KeySym hkeysym -> hkeysym = keysym
-              | KeyList hkeys -> List.mem keysym hkeys
+              | KeyList hkeys -> List.mem keysym ~set:hkeys
               | Other -> true )
         then
           ( debug_msg handler.description;
       `None -> grab ()
     | `Global | `Local -> ungrab ()
 
-let _ = kidmode#register_callback (fun oldv newv -> toggle_kidmode ())
+let _ = kidmode#register_callback (fun _oldv _newv -> toggle_kidmode ())
 
 let init () =
   disp_state.toplevel <- Some (openTk ~clas:app_class ());
     You should have received a copy of the GNU General Public License
     along with this program; if not, write to the Free Software
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
+*)
 
 open StdLabels
 open MoreLabels
 (* Only implements the act_all_on_all function. *)
 (* Another useful thing to implement faster would be collision detection *)
 
-(* all-float record, to let the compiler unbox in a loop *) 
+(* all-float record, to let the compiler unbox in a loop *)
 type fbody = { mutable x_pos: float;
-	       mutable y_pos: float;
-	       mutable x_vel: float;
-	       mutable y_vel: float;
-	       fb_radius: float;
-	       fb_mass: float;
-	     }
+               mutable y_pos: float;
+               mutable x_vel: float;
+               mutable y_vel: float;
+               fb_radius: float;
+               fb_mass: float;
+             }
 
 let cube x = x *. x *. x
 let square x = x *. x
 (* let sqrtcube x = sqrt (x *. x *. x)   (* Faster but less flexible
-implementaqtion of sqrtcube *) *)
+   implementaqtion of sqrtcube *) *)
 
 let body_to_fbody body =
   let (x_pos,y_pos) = body.pos
   and (x_vel,y_vel) = body.velocity
-  (*and (x_accel,y_accel) = 
+  (*and (x_accel,y_accel) =
     match body.i with None -> (0.,0.) | Some accel -> accel *)
   in
-    { x_pos = x_pos;
-      y_pos = y_pos;
-      fb_radius = body.radius;
-      fb_mass = body.mass;
-      x_vel = x_vel;
-      y_vel = y_vel;
-    }
+  { x_pos = x_pos;
+    y_pos = y_pos;
+    fb_radius = body.radius;
+    fb_mass = body.mass;
+    x_vel = x_vel;
+    y_vel = y_vel;
+  }
 
-let build_fbody_array bodies = 
+let build_fbody_array bodies =
   Array.of_list (List.map ~f:body_to_fbody bodies)
 
 (* convert a body and a b to an updated body *)
-let fbody_and_body_to_body body b = 
-  { body with 
-      velocity = (b.x_vel,b.y_vel);
-      pos = (b.x_pos,b.y_pos);
+let fbody_and_body_to_body body b =
+  { body with
+    velocity = (b.x_vel,b.y_vel);
+    pos = (b.x_pos,b.y_pos);
   }
 
 
     [] -> ()
   | hd::tl -> f ~i hd; list_iteri_rec ~f tl (i+1)
 
-let list_iteri ~f list = 
+let list_iteri ~f list =
   list_iteri_rec ~f list 0
 
 (**************************************************)
 
 let array_to_bodies bodies array =
   let b_list = Array.to_list array in
-    List.map2 ~f:fbody_and_body_to_body bodies b_list
+  List.map2 ~f:fbody_and_body_to_body bodies b_list
 
 (**********************************************************************)
 
 let act_all_on_all_rk ~bounce bodies =
   let gexp = grav_exp#v in
   let exp = ((1.0 +. gexp)/.2.0) in
-  let sqrtcube = 
-    if gexp = 2.0 then sqrtcube else (fun x -> x ** exp) in 
-  let const = gconst#v in 
+  let sqrtcube =
+    if gexp = 2.0 then sqrtcube else (fun x -> x ** exp) in
+  let const = gconst#v in
 
   (* t is the time.  This function has no time dependence.
      s is the position is state space
-     dsdt is the array of derivatives 
+     dsdt is the array of derivatives
   *)
-  let deriv t s dsdt = 
+  let deriv _t s dsdt =
     (* initialize derivatives to 0 *)
-    for i = 0 to Array.length dsdt - 1 do dsdt.(i) <- 0. done;  
+    for i = 0 to Array.length dsdt - 1 do dsdt.(i) <- 0. done;
 
     for i = 0 to Array.length bodies - 1 do
       (* x and y pos derivative *)
 
     for i = 0 to Array.length bodies - 1 do
       for j = i+1 to Array.length bodies - 1 do
-	(* compute i's action on j and vice-versa.  That way you only need to
-	 * compute the force once.  It's nearly twice as fast that way. *) 
-	let x_pos_i = s.(i*4) and y_pos_i = s.(i*4 + 1) in
-	let x_pos_j = s.(j*4) and y_pos_j = s.(j*4 + 1) in
+        (* compute i's action on j and vice-versa.  That way you only need to
+         * compute the force once.  It's nearly twice as fast that way. *)
+        let x_pos_i = s.(i*4) and y_pos_i = s.(i*4 + 1) in
+        let x_pos_j = s.(j*4) and y_pos_j = s.(j*4 + 1) in
 
-	let xdiff = x_pos_i -. x_pos_j
-	and ydiff = y_pos_i -. y_pos_j in
+        let xdiff = x_pos_i -. x_pos_j
+        and ydiff = y_pos_i -. y_pos_j in
 
-	let dist_sq = xdiff *. xdiff +. ydiff *. ydiff in
-	let mult = const /. sqrtcube dist_sq in
-	let mult_i = -. mult *. bodies.(j).fb_mass
-	and mult_j = mult *. bodies.(i).fb_mass
-	in
+        let dist_sq = xdiff *. xdiff +. ydiff *. ydiff in
+        let mult = const /. sqrtcube dist_sq in
+        let mult_i = -. mult *. bodies.(j).fb_mass
+        and mult_j = mult *. bodies.(i).fb_mass
+        in
 
-	(* x vel derivative *)
-	dsdt.(i*4 + 2) <- dsdt.(i*4 + 2) +. xdiff *. mult_i;
-	dsdt.(j*4 + 2) <- dsdt.(j*4 + 2) +. xdiff *. mult_j;
+        (* x vel derivative *)
+        dsdt.(i*4 + 2) <- dsdt.(i*4 + 2) +. xdiff *. mult_i;
+        dsdt.(j*4 + 2) <- dsdt.(j*4 + 2) +. xdiff *. mult_j;
 
-	(* y vel derivative *)
-	dsdt.(i*4 + 3) <- dsdt.(i*4 + 3) +. ydiff *. mult_i;
-	dsdt.(j*4 + 3) <- dsdt.(j*4 + 3) +. ydiff *. mult_j;
+        (* y vel derivative *)
+        dsdt.(i*4 + 3) <- dsdt.(i*4 + 3) +. ydiff *. mult_i;
+        dsdt.(j*4 + 3) <- dsdt.(j*4 + 3) +. ydiff *. mult_j;
 
-	
-	if bounce &&
-	  (let total_radius = bodies.(j).fb_radius +. bodies.(i).fb_radius in
-	   dist_sq < total_radius *. total_radius )
-	then (
-	  let total_radius = bodies.(j).fb_radius +. bodies.(i).fb_radius in
 
-	  let mult = -. mult *. bodies.(i).fb_mass *. bodies.(j).fb_mass
-		     *. (total_radius *. total_radius /. dist_sq) in
-	  let mult_i = -. mult /. bodies.(i).fb_mass 
-	  and mult_j = mult /. bodies.(j).fb_mass 
-	  in
+        if bounce &&
+          (let total_radius = bodies.(j).fb_radius +. bodies.(i).fb_radius in
+           dist_sq < total_radius *. total_radius )
+        then (
+          let total_radius = bodies.(j).fb_radius +. bodies.(i).fb_radius in
 
-	  (* x vel derivative *)
-	  dsdt.(i*4 + 2) <- dsdt.(i*4 + 2) +. xdiff *. mult_i;
-	  dsdt.(j*4 + 2) <- dsdt.(j*4 + 2) +. xdiff *. mult_j;
+          let mult = -. mult *. bodies.(i).fb_mass *. bodies.(j).fb_mass
+            *. (total_radius *. total_radius /. dist_sq) in
+          let mult_i = -. mult /. bodies.(i).fb_mass
+          and mult_j = mult /. bodies.(j).fb_mass
+          in
 
-	  (* y vel derivative *)
-	  dsdt.(i*4 + 3) <- dsdt.(i*4 + 3) +. ydiff *. mult_i;
-	  dsdt.(j*4 + 3) <- dsdt.(j*4 + 3) +. ydiff *. mult_j;
-	)
+          (* x vel derivative *)
+          dsdt.(i*4 + 2) <- dsdt.(i*4 + 2) +. xdiff *. mult_i;
+          dsdt.(j*4 + 2) <- dsdt.(j*4 + 2) +. xdiff *. mult_j;
+
+          (* y vel derivative *)
+          dsdt.(i*4 + 3) <- dsdt.(i*4 + 3) +. ydiff *. mult_i;
+          dsdt.(j*4 + 3) <- dsdt.(j*4 + 3) +. ydiff *. mult_j;
+        )
 
       done
     done
   in
 
 
-  let s = 
+  let s =
     Array.init (4 * Array.length bodies)
       ~f:(fun i -> match i mod 4 with
-	    | 0 -> bodies.(i / 4).x_pos
-	    | 1 -> bodies.(i / 4).y_pos
-	    | 2 -> bodies.(i / 4).x_vel
-	    | _ -> bodies.(i / 4).y_vel
-	 )
+      | 0 -> bodies.(i / 4).x_pos
+      | 1 -> bodies.(i / 4).y_pos
+      | 2 -> bodies.(i / 4).x_vel
+      | _ -> bodies.(i / 4).y_vel
+      )
   in
 
   (* dumb_solver s state.delta#v deriv;  *)
-  Rk4.step s 0.0 state.delta#v s deriv;   
-  
+  Rk4.step ~y:s ~x:0.0 ~h:state.delta#v ~yout:s ~derivs:deriv;
+
   for i = 0 to Array.length bodies - 1 do
     bodies.(i).x_pos <- s.(4 * i);
     bodies.(i).y_pos <- s.(4 * i + 1);
   done
 
 
-let act_all_on_all ~bounce bodies = 
+let act_all_on_all ~bounce bodies =
   let array = build_fbody_array bodies in
-    act_all_on_all_rk ~bounce array;
-    array_to_bodies bodies array
+  act_all_on_all_rk ~bounce array;
+  array_to_bodies bodies array
 (* Simple implementation of a polymorphic functional queue *)
 
-(* push and top are O(1).  
+(* 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  
+(* Invariant:
+   if queue is not empty, outlist is not empty
    queue.length = List.length(queue.outlist) + List.length(queue.inlist)*)
 
 exception Empty
 (*****************************************)
 
 (*
-let test_invariants queue = 
-  assert 
-    begin 
+let test_invariants queue =
+  assert
+    begin
       queue.length = (List.length queue.outlist) + (List.length queue.inlist)
     end;
-  assert 
-    begin 
+  assert
+    begin
       (queue.length = 0) || List.length queue.outlist > 0
     end
 *)
 
 let push el queue =
   if queue.outlist = [] then
-    let outlist = List.rev (el::queue.inlist) 
-    in { inlist = []; 
+    let outlist = List.rev (el::queue.inlist)
+    in { inlist = [];
 	 outlist = outlist;
 	 length = queue.length + 1;
        }
 
 (*****************************************)
 
-let top queue = 
+let top queue =
   match queue.outlist with
-      [] -> (if queue.inlist != [] 
-	     then failwith "FQueue.top: BUG. inlist should be empty but isn't"
-	     else raise Empty)
-    | hd::tl -> hd
+  | [] ->
+    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); 
+    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 = [] 
+  | [] ->
+      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; 
+	      | hd::tl -> (hd, { inlist=[];
+				 outlist=tl;
 				 length = queue.length - 1;
 			       }))
 
 (*****************************************)
 
-let remove queue = 
-  let (el,new_q) = pop queue in
-    new_q
-      
+let remove queue =
+  let (_,new_q) = pop queue in
+  new_q
+
 (*****************************************)
 
-let to_list queue = 
+let to_list queue =
   queue.inlist @ (List.rev (queue.outlist))
 
-(*****************************************)    
-  
+(*****************************************)
+
 let length queue = queue.length
 
 
 let prologue = Lstrings.get `prologue
 
-class window toplevel text = 
-object (self)
+class window toplevel text =
+object (_self)
 
   val mutable widget = None
   val on_startup = Textvariable.create ()
 
-  method display ?(title=Lstrings.get `help) ?geometry () = 
+  method display ?(title=Lstrings.get `help) ?geometry () =
     match widget with
-	None ->
-	  debug_msg "Creating help window from scratch";
-	  let topwin = Toplevel.create toplevel in
-	  let frame1 = Frame.create topwin in
-	  let frame2 = Frame.create topwin in
-	  let frame3 = Frame.create topwin in
-	  let textw = Text.create frame1 in
-	  let vscrollbar = Scrollbar.create ~command:(Text.yview textw) 
-			     ~orient:`Vertical frame1 in
-	  let hscrollbar = Scrollbar.create ~command:(Text.xview textw) 
-			     ~orient:`Horizontal frame2 in
-	  let cbutton = 
-	    Checkbutton.create ~text:(Lstrings.get `at_startup)
-	      ~variable:on_startup frame3 
-	      ~command:(fun () -> SaveState.set_help_start 
-			  (Textvariable.get on_startup = "1"))
-	  in
+      None ->
+        debug_msg "Creating help window from scratch";
+        let topwin = Toplevel.create toplevel in
+        let frame1 = Frame.create topwin in
+        let frame2 = Frame.create topwin in
+        let frame3 = Frame.create topwin in
+        let textw = Text.create frame1 in
+        let vscrollbar = Scrollbar.create ~command:(Text.yview textw)
+          ~orient:`Vertical frame1 in
+        let hscrollbar = Scrollbar.create ~command:(Text.xview textw)
+          ~orient:`Horizontal frame2 in
+        let cbutton =
+          Checkbutton.create ~text:(Lstrings.get `at_startup)
+            ~variable:on_startup frame3
+            ~command:(fun () -> SaveState.set_help_start
+              (Textvariable.get on_startup = "1"))
+        in
 
-	  Text.insert ~index:(`Atxy (0,0),[]) ~text:(prologue ^ text) textw; 
-	  Text.configure ~state:`Disabled ~wrap:`None ~width:65
-	    ~yscrollcommand:(Scrollbar.set vscrollbar) 
-	    ~xscrollcommand:(Scrollbar.set hscrollbar) textw;
-	  widget <- Some topwin;
-	  bind ~events:[`Destroy] ~action:(fun ev -> widget <- None) topwin;
-	  Pack.configure [frame1] ~side:`Top ~fill:`Both ~expand:true;
-	  Pack.configure [frame2] ~fill:`X ~side:`Top;
-	  Pack.configure [frame3] ~fill:`X ~side:`Top;
-	  Pack.configure [textw] ~side:`Left ~fill:`Both ~expand:true; 
-	  Pack.configure [vscrollbar] ~side:`Right ~fill:`Y;
-	  Pack.configure [hscrollbar] ~fill:`X;
-	  Pack.configure [cbutton];
-	  Wm.title_set topwin title;
-	  (match geometry with
-	       None -> ()
-	     | Some geometry -> Wm.geometry_set topwin geometry)
+        Text.insert ~index:(`Atxy (0,0),[]) ~text:(prologue ^ text) textw;
+        Text.configure ~state:`Disabled ~wrap:`None ~width:65
+          ~yscrollcommand:(Scrollbar.set vscrollbar)
+          ~xscrollcommand:(Scrollbar.set hscrollbar) textw;
+        widget <- Some topwin;
+        bind ~events:[`Destroy] ~action:(fun _ -> widget <- None) topwin;
+        Pack.configure [frame1] ~side:`Top ~fill:`Both ~expand:true;
+        Pack.configure [frame2] ~fill:`X ~side:`Top;
+        Pack.configure [frame3] ~fill:`X ~side:`Top;
+        Pack.configure [textw] ~side:`Left ~fill:`Both ~expand:true;
+        Pack.configure [vscrollbar] ~side:`Right ~fill:`Y;
+        Pack.configure [hscrollbar] ~fill:`X;
+        Pack.configure [cbutton];
+        Wm.title_set topwin title;
+        (match geometry with
+          None -> ()
+        | Some geometry -> Wm.geometry_set topwin geometry)
 
-      | Some widget -> 
-	  debug_msg "Raising help window";
-	  Tk.raise_window widget
+    | Some widget ->
+      debug_msg "Raising help window";
+      Tk.raise_window widget
 
   initializer
-    if SaveState.help_start 
+    if SaveState.help_start
     then Textvariable.set on_startup "1"
     else Textvariable.set on_startup "0"
 
 end
-    
+
 
 
 let help_window = ref None
 let create_window toplevel text =
-  let window = 
-    (match !help_window with 
-	 None -> 
-	   let win = new window toplevel text in
-	   help_window := Some win;
-	   win
-     | Some win -> win) 
+  let window =
+    match !help_window with
+    | None ->
+      let win = new window toplevel text in
+      help_window := Some win;
+      win
+    | Some win -> win
   in
   window#display ~geometry:"+0+0" ()
 (****************************************************************)
 (**  Utility Functions   ****************************************)
 (****************************************************************)
-  
+
 let random_chr () =
   let rand = Random.int ((Char.code 'z') - (Char.code 'a')) in
   Char.chr ((Char.code 'a') + rand)
 
-let random_name length = 
+let random_name length =
   let str = String.create length in
   for i = 0 to length -1 do
     str.[i] <-  random_chr ()
   str
 
 module StringMap = AugMap.Make(
-  struct 
-    type t = string 
-    let compare = compare 
+  struct
+    type t = string
+    let compare = compare
   end)
 
 (*****************************************************************)
 (**  Live Values  ************************************************)
 (*****************************************************************)
 
-(*  Values that have a list of callbacks that are called whenever the value 
- *  is updated.  This is useful both for keeping the optionbox up to date, 
- *  and for doing whatever needs to be done to accomodate changing options. 
+(*  Values that have a list of callbacks that are called whenever the value
+ *  is updated.  This is useful both for keeping the optionbox up to date,
+ *  and for doing whatever needs to be done to accomodate changing options.
  *)
 
 
-class ['a] live_value (init:'a) = 
-object (self)
+class ['a] live_value (init:'a) =
+object (_self)
   val mutable name = None
   val mutable value = init
   val mutable callback_list = []
 
-  method set newval = 
+  method set newval =
     value <- newval;
-    List.iter 
+    List.iter
       ~f:(fun cb ->
-	    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))))
+        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))))
       callback_list
 
   method set_name newname = name <- Some newname
   method v = value
   method get () = value
-  method register_callback cb = 
+  method register_callback cb =
     callback_list <- cb::callback_list
 end
 
 
 (****************************************************)
 
-class live_toggle init = 
+class live_toggle init =
 object (self)
   inherit [bool] live_value init
 
 
 class virtual ['a,'b] option ?name ~text ~set:(set:'a->unit) ~get () =
   let name = (match name with
-		  None -> random_name 10
-		| Some name -> name ) in
+      None -> random_name 10
+    | Some name -> name ) in
 object (self)
   val mutable widget = None
 
   val name = name
   val text = (text : string)
 
-  method virtual build_widget : live:bool -> 'b 
+  method virtual build_widget : live:bool -> 'b
   method display ~live parent =
     ignore (self#build_widget ~live parent);
-    match widget with 
-	None -> failwith "option#display: widget unexpectedly missing"
-      | Some widget ->
-	  Pack.configure ~anchor:`W [widget]
+    match widget with
+      None -> failwith "option#display: widget unexpectedly missing"
+    | Some widget ->
+      Pack.configure ~anchor:`W [widget]
 
   method virtual get_tk : 'a
   method virtual set_tk : 'a -> unit
 class ['b] toggle_option ?name ~text ~set ~get () =
 object (self)
   inherit [bool,'b] option ?name ~text ~set ~get ()
-    
-  method set_tk bool = 
+
+  method set_tk bool =
     Textvariable.set tk_var (if bool then "true" else "false")
 
-  method get_tk = 
+  method get_tk =
     let string = Textvariable.get tk_var in
     if string = "true"  then true
     else if string = "false" then false
-    else failwith "toggle_option#get_tk: bad string value" 
+    else failwith "toggle_option#get_tk: bad string value"
 
   method build_widget ~live parent =
     let new_widget = Checkbutton.create  ~name ~text
-		       ~onvalue:"true" ~offvalue:"false" parent in
-    (if live then 
-       Checkbutton.configure ~command:(fun () -> self#tk_to_real) 
-	 new_widget);
+      ~onvalue:"true" ~offvalue:"false" parent in
+    (if live then
+        Checkbutton.configure ~command:(fun () -> self#tk_to_real)
+          new_widget);
     widget <- Some new_widget;
     self#real_to_tk;
     new_widget
 
   method min = min
   method max = max
-		 
-  method get_tk = match widget with 
-      None -> failwith ("int_scale_option#get_tk called when " ^
-			"no widget exists")
-    | Some widget -> 
-	if Winfo.exists widget 
-	then int_of_float (Scale.get widget)
-	else failwith ("int_scale_option#get_tk called when " ^
-		       "widget does not exist")
+
+  method get_tk = match widget with
+    None -> failwith ("int_scale_option#get_tk called when " ^
+                         "no widget exists")
+  | Some widget ->
+    if Winfo.exists 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)
+    None -> ()
+  | Some widget ->
+    if Winfo.exists widget
+    then Scale.set widget (float_of_int v)
 
 
-  method build_widget ~live parent = 
-    let new_widget = Scale.create ~name ~label:text 
-		       ~orient:`Horizontal ~min ~max parent in
+  method build_widget ~live parent =
+    let new_widget = Scale.create ~name ~label:text
+      ~orient:`Horizontal ~min ~max parent in
     widget <- Some new_widget;
     self#real_to_tk;
-    (if live then Scale.configure  
-       ~command:(fun value -> self#set_real 
-		   (int_of_float value)) new_widget);
+    (if live then Scale.configure
+        ~command:(fun value -> self#set_real
+          (int_of_float value)) new_widget);
     new_widget
 
 end
 
 (*******************************************************)
 
-class ['b] float_scale_option ?name ~min ~max ?(resolution=1.0) 
-  ~text ~set ~get () = 
+class ['b] float_scale_option ?name ~min ~max ?(resolution=1.0)
+  ~text ~set ~get () =
 object (self)
   inherit [float, 'b] option ?name ~text ~set ~get ()
   val min = min
 
   method min = min
   method max = max
-		 
-  method get_tk = match widget with 
-      None -> failwith ("float_scale_option#get_tk called when " ^
-			"no widget exists")
-    | Some widget -> 
-	if Winfo.exists widget 
-	then Scale.get widget
-	else failwith ("float_scale_option#get_tk called when " ^
-		       "widget does not exist")
+
+  method get_tk = match widget with
+    None -> failwith ("float_scale_option#get_tk called when " ^
+                         "no widget exists")
+  | Some widget ->
+    if Winfo.exists widget
+    then Scale.get widget
+    else failwith ("float_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 v
+    None -> ()
+  | Some widget ->
+    if Winfo.exists widget
+    then Scale.set widget v
 
 
-  method build_widget ~live parent = 
-    let new_widget = Scale.create ~name ~resolution ~label:text 
-		       ~orient:`Horizontal ~min ~max parent in
+  method build_widget ~live parent =
+    let new_widget = Scale.create ~name ~resolution ~label:text
+      ~orient:`Horizontal ~min ~max parent in
     widget <- Some new_widget;
     self#real_to_tk;
-    (if live then Scale.configure  
-       ~command:(fun value -> self#set_real value) new_widget);
+    (if live then Scale.configure
+        ~command:(fun value -> self#set_real value) new_widget);
     new_widget
 end
 
 (*******************************************************)
 
-let string_of_float x = 
+let string_of_float x =
   let string = string_of_float x in
-  if string.[String.length string - 1] = '.' 
+  if string.[String.length string - 1] = '.'
   then string ^ "0"
   else string
 
-class ['b] float_entry_option ?name ?(mult=1.1) 
+class ['b] float_entry_option ?name ?(mult=1.1)
   ~text ~set ~get () =
 object (self)
   inherit [float, 'b] option ?name ~text ~set ~get ()
   val mutable entry = None
 
   method get_tk = match entry with
-      None -> failwith ( "float_entry_option#get_tk called " ^ 
-			 "when no widget exists" )
+    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 = 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;
+    Entry.insert entry ~index:(`Num 0) ~text:string_rep;
+    float
+
+  method set_tk v = match widget with
+  | None -> ()
+  | Some _widget ->
+    match entry with
+      None ->  failwith ("float_entry_option#set_tk" ^
+                            " called when no widget exists")
     | Some entry ->
-	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;
-	Entry.insert entry ~index:(`Num 0) ~text:string_rep;
-	float
-	  
-  method set_tk v = match widget with
-      None -> ()
-    | Some widget ->
-	match entry with
-	    None ->  failwith ("float_entry_option#set_tk" ^ 
-			       " called when no widget exists") 
-	  | Some entry ->
-	      if Winfo.exists entry then (
-		Entry.delete_range ~start:(`Num 0) 
-					    ~stop:`End entry;
-		Entry.insert entry ~index:(`Num 0) 
-		  ~text:(string_of_float v) 
-	      )
+      if Winfo.exists entry then (
+        Entry.delete_range ~start:(`Num 0)
+          ~stop:`End entry;
+        Entry.insert entry ~index:(`Num 0)
+          ~text:(string_of_float v)
+      )
 
   method build_widget ~live parent =
     let frame = Frame.create parent in
     let nentry = Entry.create ~width:6 frame in
     let label = Label.create ~text frame in
-    let action ev = 
+    let action ev =
       if ev.ev_KeySymString = "Return" then
-	self#tk_to_real 
+        self#tk_to_real
       else if ev.ev_KeySymString = "Up" then
-	let newval = (mult *. self#get_tk) in
-	self#set_real newval;
-	self#set_tk newval
+        let newval = (mult *. self#get_tk) in
+        self#set_real newval;
+        self#set_tk newval
       else if ev.ev_KeySymString = "Down" then
-	let newval = (self#get_tk /. mult) in
-	self#set_real newval;
-	self#set_tk newval
+        let newval = (self#get_tk /. mult) in
+        self#set_real newval;
+        self#set_tk newval
     in
-    if live then 
-      begin 
-	bind ~events:[`KeyPress] ~fields:[`KeySymString] 
-	  ~action nentry;
-	bind ~events:[`FocusOut] ~fields:[`KeySymString] 
-	  ~action:(fun ev -> self#tk_to_real) nentry;
+    if live then
+      begin
+        bind ~events:[`KeyPress] ~fields:[`KeySymString]
+          ~action nentry;
+        bind ~events:[`FocusOut] ~fields:[`KeySymString]
+          ~action:(fun _ev -> self#tk_to_real) nentry;
       end;
     Pack.configure ~side:`Left [nentry];
     Pack.configure ~side:`Left [label];
   val mutable display = None
 
   method get_tk = raise Unimplemented
-		    
+
   method set_tk v = match widget with
-      None -> ()
-    | Some widget ->
-	match display with
-	    None -> failwith ("float_entry_display#set_tk" ^ 
-			      " called when no widget exists") 
-	  | Some display ->
-	      if Winfo.exists display
-	      then Label.configure ~text:(sprintf "%8.4f" v) 
-		display
+    None -> ()
+  | Some _widget ->
+    match display with
+      None -> failwith ("float_entry_display#set_tk" ^
+                           " called when no widget exists")
+    | Some display ->
+      if Winfo.exists display
+      then Label.configure ~text:(sprintf "%8.4f" v)
+        display
 
-  method build_widget ~live parent =
+  method build_widget ~live:_ parent =
     let frame = Frame.create parent in
     let label = Label.create ~text frame in
-    let ndisplay = Label.create frame  
+    let ndisplay = Label.create frame
     in
     Pack.configure ~side:`Left [label];
     Pack.configure ~side:`Left [ndisplay];
   val mutable display = None
 
   method get_tk = raise Unimplemented
-		    
+
   method set_tk v = match widget with
-      None -> ()
-    | Some widget ->
-	match display with
-	    None -> failwith ("int_entry_option#set_tk" ^ 
-			      " called when no widget exists") 
-	  | Some display ->
-	      if Winfo.exists display
-	      then Label.configure ~text:(sprintf "%d" v) 
-		display
+    None -> ()
+  | Some _widget ->
+    match display with
+      None -> failwith ("int_entry_option#set_tk" ^
+                           " called when no widget exists")
+    | Some display ->
+      if Winfo.exists display
+      then Label.configure ~text:(sprintf "%d" v)
+        display
 
-  method build_widget ~live parent =
+  method build_widget ~live:_ parent =
     let frame = Frame.create parent in
     let label = Label.create ~text frame in
-    let ndisplay = Label.create frame  
+    let ndisplay = Label.create frame
     in
     Pack.configure ~side:`Left [label];
     Pack.configure ~side:`Left [ndisplay];
 (*******************************************************)
 
 class ['b] void_entry_display ?name ~text () =
-object (self)
-  inherit [unit, 'b] option ?name ~text 
-    ~set:(fun x -> ()) ~get:(fun () -> ())
+object (_self)
+  inherit [unit, 'b] option ?name ~text
+    ~set:(fun _ -> ()) ~get:(fun () -> ())
     ()
 
   method get_tk = raise Unimplemented
-		    
-  method set_tk v = ()
 
-  method build_widget ~live parent =
+  method set_tk _ = ()
+
+  method build_widget ~live:_ parent =
     let frame = Frame.create parent in
     let label = Label.create ~text frame in
     Pack.configure ~side:`Left [label];
  * is that putting them outside allows for a greater degree
  * of polymorphism. *)
 (************************************************************)
-  
+
 
 let add_option optionbox ?register_cb option =
   (match register_cb with
-       None -> ()
-     | Some register ->
-	 register 
-	 (fun oldval newval -> ignore (oldval = newval); 
-	    option#set_tk newval));
+    None -> ()
+  | Some register ->
+    register
+      (fun oldval newval -> ignore (oldval = newval);
+        option#set_tk newval));
   optionbox#add_option option#upcast
 
 let add_option_live optionbox lvalue option =
   val mutable display_map = StringMap.empty
   val mutable display_names = []
 
-				
+
   val mutable mapped = false
 
   val mutable live = true
   method set_liveness bool = live <- bool
-			       
+
   method add_option (option : 'a display_type) =
     if StringMap.has_key option#name display_map then
       raise (Option_exists option#name)
     else
-      ( display_map <- StringMap.add ~key:option#name 
-	  ~data:option display_map;
-	display_names <- option#name::display_names;
+      ( display_map <- StringMap.add ~key:option#name
+          ~data:option display_map;
+        display_names <- option#name::display_names;
       )
 
   (*************************************************************)
   (* private toggle methods *)
 
-  (*  Called when OK button is pressed to commit all toggles.  
+  (*  Called when OK button is pressed to commit all toggles.
       Not useful in live option dialog. *)
   method private read_options =
-    StringMap.iter 
-      ~f:(fun ~key ~data:display -> 
-	    try display#tk_to_real with Unimplemented -> () 
-	 )
+    StringMap.iter
+      ~f:(fun ~key:_ ~data:display ->
+        try display#tk_to_real with Unimplemented -> ()
+      )
       display_map
 
-  method destroy = 
+  method destroy =
     match widget with
-	None -> failwith "Attempt to destroy non-existant widget"
-      | Some widget -> destroy widget
+      None -> failwith "Attempt to destroy non-existant widget"
+    | Some widget -> destroy widget
 
-  method private display frame live = 
-    List.iter 
-      ~f:(fun name -> 
-	    try 
-	      let display = StringMap.find name display_map in
-	      display#display ~live frame;
-	    with
-		Not_found -> failwith ("Options.display_from_map: BUG." ^
-				       " name not found in map."))
+  method private display frame live =
+    List.iter
+      ~f:(fun name ->
+        try
+          let display = StringMap.find name display_map in
+          display#display ~live frame;
+        with
+          Not_found -> failwith ("Options.display_from_map: BUG." ^
+                                    " name not found in map."))
       (List.rev display_names)
 
   method mapped = mapped
 
-  method create_dialog ?(title=Lstrings.get `options) 
-    ?geometry ?(clas="Option") ?(transient:'b) () = 
+  method create_dialog ?(title=Lstrings.get `options)
+    ?geometry ?(clas="Option") ?(transient:'b) () =
     if not mapped then
       begin
-	mapped <- true;
-	let topwin = Toplevel.create ~takefocus:true ~clas ~name:"options" 
-		       toplevel in 
-	let frame = Frame.create ~name:"options" topwin in
-	let buttons = 
-	  if not live then
-	    let cancel_button = Button.create ~text:"Cancel" 
-				  ~command:(fun () -> destroy topwin)
-				  frame
-	    and ok_button = Button.create ~text:"Ok" 
-			      ~command:(fun () -> self#read_options; 
-					  destroy topwin) frame
-	    in
-	    [cancel_button; ok_button]
-	  else
-	    let dismiss_button = Button.create ~text:(Lstrings.get `dismiss)
-				   ~command:(fun () -> self#read_options; 
-					       destroy topwin) frame
-	    in [dismiss_button]
-	in
-	widget <- Some topwin;
-	bind ~events:[`Destroy] ~action:(fun ev -> mapped <- false) frame;
-	Pack.configure [frame];
-	self#display frame live;
-	Pack.configure ~side:`Left buttons;
-	(match transient with 
-	     None -> ()
-	   | Some master -> Wm.transient_set topwin ~master);
-	(match geometry with
-	     None -> ()
-	   | Some geometry -> Wm.geometry_set topwin geometry);
-	Wm.title_set topwin title
+        mapped <- true;
+        let topwin = Toplevel.create ~takefocus:true ~clas ~name:"options"
+          toplevel in
+        let frame = Frame.create ~name:"options" topwin in
+        let buttons =
+          if not live then
+            let cancel_button = Button.create ~text:"Cancel"
+              ~command:(fun () -> destroy topwin)
+              frame
+            and ok_button = Button.create ~text:"Ok"
+              ~command:(fun () -> self#read_options;
+                destroy topwin) frame
+            in
+            [cancel_button; ok_button]
+          else
+            let dismiss_button = Button.create ~text:(Lstrings.get `dismiss)
+              ~command:(fun () -> self#read_options;
+                destroy topwin) frame
+            in [dismiss_button]
+        in
+        widget <- Some topwin;
+        bind ~events:[`Destroy] ~action:(fun _ -> mapped <- false) frame;
+        Pack.configure [frame];
+        self#display frame live;
+        Pack.configure ~side:`Left buttons;
+        (match transient with
+          None -> ()
+        | Some master -> Wm.transient_set topwin ~master);
+        (match geometry with
+          None -> ()
+        | Some geometry -> Wm.geometry_set topwin geometry);
+        Wm.title_set topwin title
       end
     else
       debug_msg "Attempt to map already-mapped option dialog"
 (*******************************************************)
 
 let cube x = x *. x *. x
-let square x = x *. x 
+let square x = x *. x
 
 let magsq (x,y) = x*.x +. y*.y
 let mag (x,y) = sqrt (x*.x +. y*.y)
 let update_pos_bodies bodies =
   List.map ~f:update_pos bodies
 
-let print_body body = 
-  let (x,y) = body.pos 
+let print_body body =
+  let (x,y) = body.pos
   and (x_v,y_v) = body.velocity
-  in 
+  in
     printf "pos: (%3f,%3f), vel: (%3f,%3f) " x y x_v y_v
 
 let print_bodies bodies = List.iter ~f:print_body bodies
 (**  Energy Calculations  **********************)
 (***********************************************)
 
-let rec pairfold ~f list ~init = 
+let rec pairfold ~f list ~init =
   match list with
       [] -> init
-    | hd::tl -> 
-	let init = List.fold_left 
-		     ~f:(fun partial el -> f partial hd el) ~init tl in 
+    | hd::tl ->
+	let init = List.fold_left
+		     ~f:(fun partial el -> f partial hd el) ~init tl in
 	pairfold ~f tl ~init
 
 
-(* How to compute potential:  sum of pair energy for all pairs 
+(* How to compute potential:  sum of pair energy for all pairs
    (don't do pairs twice),
    where pair energy is G m_1 * m_2 / d
-   
+
    Only works with grav_exp = 2.0
 
  *)
 
-let pair_energy b1 b2 = 
+let pair_energy b1 b2 =
   let dist = mag (b1.pos <-> b2.pos) in
   -. gconst#v *. b1.mass *. b2.mass /. dist
 
 (* returns potential energy *)
-let penergy bodies = 
-  pairfold ~f:(fun e b1 b2 -> e +. pair_energy b1 b2) 
+let penergy bodies =
+  pairfold ~f:(fun e b1 b2 -> e +. pair_energy b1 b2)
     ~init:0. bodies
-  
+
 (* returns kinetic energy *)
-let kenergy bodies = 
+let kenergy bodies =
   List.fold_left ~f:(fun e b -> e +. 0.5 *. b.mass *. magsq b.velocity)
     ~init:0. bodies
 
-let energy bodies = 
+let energy bodies =
   (* penergy bodies +.  *)
   kenergy bodies
 
 let center_of_mass bodies = match bodies with
     [] -> (0.0,0.0)
   | _ ->
-      let mpositions = 
-	List.map ~f:(fun body -> body.mass <*> body.pos) bodies 
-      and masses = List.map ~f:(fun body -> body.mass) bodies 
+      let mpositions =
+	List.map ~f:(fun body -> body.mass <*> body.pos) bodies
+      and masses = List.map ~f:(fun body -> body.mass) bodies
       in
 	(sum masses <|> vsum mpositions)
-    
+
 
 let central_velocity bodies = match bodies with
     [] -> (0.0,0.0)
   | _ ->
-      let momenta = List.map 
+      let momenta = List.map
 		    ~f:(fun body -> body.mass <*> body.velocity)
-		      bodies 
-      and masses = List.map ~f:(fun body -> body.mass) bodies 
+		      bodies
+      and masses = List.map ~f:(fun body -> body.mass) bodies
       in
 	(sum masses <|> vsum momenta)
 
 let orbital_velocity bodies ~pos dir =
   (* first compute some global facts about the system *)
   let com = center_of_mass bodies
-  and masses = List.map ~f:(fun body -> body.mass) bodies 
+  and masses = List.map ~f:(fun body -> body.mass) bodies
   and cv = central_velocity bodies in
-  let mass = sum masses 
+  let mass = sum masses
   in
   (* now we compute the orbital speed *)
   let radius_vect = com -| pos in
   (speed *| uvect) +| cv
 
 
-let induced_orbital_velocity bodies ~pos dir = 
-  if List.length bodies = 0 then (0.0,0.0) else 
+let induced_orbital_velocity bodies ~pos dir =
+  if List.length bodies = 0 then (0.0,0.0) else
     let cv = central_velocity bodies in
-    let induced_accel_list = 
-      List.map ~f:(fun body -> 
+    let induced_accel_list =
+      List.map ~f:(fun body ->
 		     let dvect = body.pos -| pos in
 		     let d = mag dvect in
 		     let uvect = d /| dvect in
-		     (body.mass /. (d *. d)) *| uvect 
+		     (body.mass /. (d *. d)) *| uvect
 		  )
 	bodies in
-    let induced_accel = List.fold_left ~f:( +| ) induced_accel_list 
+    let induced_accel = List.fold_left ~f:( +| ) induced_accel_list
 			  ~init:vzero in
     let total_mass = sum (List.map ~f:(fun body -> body.mass) bodies) in
     let implied_dist = sqrt (total_mass /. mag induced_accel) in
     let implied_uvect = mag induced_accel /| induced_accel in
     let speed = sqrt (gconst#v *. total_mass /. implied_dist) in
-    let uvect = (if dir then rotleft implied_uvect 
+    let uvect = (if dir then rotleft implied_uvect
 		 else rotright implied_uvect) in
     (speed *| uvect) +| cv
-  
+
 
 
 (***********************************************)
 let sub_velocity vel body =
   { body with velocity = body.velocity <-> vel; }
 
-let zero_speed_bodies selected_bodies = 
+let zero_speed_bodies selected_bodies =
   let velocity = central_velocity selected_bodies in
     state.bodies <- List.map ~f:(sub_velocity velocity) state.bodies
-      
-let center_bodies selected_bodies = 
+
+let center_bodies selected_bodies =
   let center = center_of_mass selected_bodies in
     state.center#set center
 
 let zero_speed () = zero_speed_bodies state.bodies
 let center () = center_bodies state.bodies
 
-let bodies_from_ids ids = 
-  List.filter ~f:(fun body -> List.mem body.id ids) state.bodies
+let bodies_from_ids ids =
+  List.filter ~f:(fun body -> List.mem body.id ~set:ids) state.bodies
 
 let zero_speeds_ids ids = zero_speed_bodies (bodies_from_ids ids)
 let center_ids ids = center_bodies (bodies_from_ids ids)
 (**  Collision   Detection   ********************************************)
 (************************************************************************)
 
-let touch ~mult b1 b2 = 
+let touch ~mult b1 b2 =
   let mdist = max b1.radius b2.radius in
     distsq b1.pos b2.pos < mdist *. mdist *. mult *. mult
 
-let join_bodies b1 b2 = 
+let join_bodies b1 b2 =
   { pos = center_of_mass [b1; b2];
-    velocity = 
+    velocity =
       (b1.mass +. b2.mass) <|>
       ((b1.mass <*> b1.velocity) <+> (b2.mass <*> b2.velocity));
     radius = ((b1.radius ** 3.0) +. (b2.radius ** 3.0))**(1.0/.3.0);
     color = join_colors b1.color b1.mass b2.color b2.mass;
-    mass = b1.mass +. b2.mass; 
+    mass = b1.mass +. b2.mass;
     id = Random.bits ();
     i = None;
   }
 
-let find_single_collision ~mult b1 bodies = 
+let find_single_collision ~mult b1 bodies =
   let rec loop b1 bodies examined = match bodies with
       [] -> b1::examined
-    | b2::tl -> 
-	if touch ~mult b1 b2 
+    | b2::tl ->
+	if touch ~mult b1 b2
 	then loop (join_bodies b1 b2) tl examined
 	else loop b1 tl (b2::examined)
   in
 let compose3 f g h x = f (g (h x))
 let ident x = x
 
-let rec apply n f x =  match n with 
+let rec apply n f x =  match n with
     0 -> x
   | _ -> apply (n-1) f (f x)
 
-let simulate ?(bounce=false) i = 
-  let action = 
+let simulate ?(bounce=false) i =
+  let action =
     compose
       (Fast_physics.act_all_on_all ~bounce)
       (find_collisions ~mult:(if bounce then 0.5 else 1.0))
 open State
 open Genlex
 
-let major_version = 1
-let minor_version = 0
-
-
 let lexer = make_lexer ["("; ","; ")"; "["; "]";
-			"pos"; "velocity"; "radius"; "color"; "mass"; "id";
-			"zoom"; "center"; "delta"; "body"; "iterations" ;
-		       ]
+                        "pos"; "velocity"; "radius"; "color"; "mass"; "id";
+                        "zoom"; "center"; "delta"; "body"; "iterations" ;
+                       ]
 
 let rec parse_next list = parser
   | [< 'Kwd "zoom"; 'Float x; e = parse_next ((`Zoom x)::list)  >] -> e
   | [< 'Kwd "mass";        'Float x;             e = parse_bnext ((`Mass x)::list)>] -> e
   | [< 'Kwd "id";          'Int x;               e = parse_bnext ((`Id x)::list)>] -> e
   | [< >] -> `Body list
-  
+
 
 
 (* Converting a state description to a state *)
 
 let all_matches ~f list =
   let rec all_matches ~partial list = match list with
-      [] -> partial 
+      [] -> partial
     | hd::tl ->
-	try 
-	  all_matches ~partial:((f hd)::partial) tl
-	with
-	    Wrong_type -> all_matches ~partial tl
+        try
+          all_matches ~partial:((f hd)::partial) tl
+        with
+            Wrong_type -> all_matches ~partial tl
   in
     all_matches ~partial:[] list
 
 (* get first match.  If none available, then raise (Missing name) error *)
 let rec first_match ~f ~name list = match list with
     [] -> raise (Missing name)
-  | hd::tl -> 
-      try 
-	f hd
+  | hd::tl ->
+      try
+        f hd
       with
-	  Wrong_type -> first_match ~f ~name tl
+          Wrong_type -> first_match ~f ~name tl
 
 
 (* get first match.  If no match available, then return default. *)
 let rec first_match_default ~f ~name ~default list = match list with
     [] -> default
-  | hd::tl -> 
-      try 
-	f hd
+  | hd::tl ->
+      try
+        f hd
       with
-	  Wrong_type -> first_match_default ~f ~name ~default tl
+          Wrong_type -> first_match_default ~f ~name ~default tl
 
 
-let build_body bdesc = 
+let build_body bdesc =
   try
-    { pos = first_match      
-	      ~f:(function `Pos pos -> pos | _ -> raise Wrong_type)                       
-	      ~name:"pos" bdesc; 
-      velocity = first_match 
-		   ~f:(function `Velocity velocity -> velocity | _ -> raise Wrong_type)        
-		   ~name:"velocity" bdesc; 
-      radius = first_match   
-		 ~f:(function `Radius radius -> radius | _ -> raise Wrong_type)              
-		 ~name:"radius" bdesc; 
-      color = first_match    
-		~f:(function `Color (color:string) -> `Color color | _ -> raise Wrong_type) 
-		~name:"color" bdesc; 
-      mass = first_match     
-	       ~f:(function `Mass mass -> mass | _ -> raise Wrong_type)                    
-	       ~name:"mass" bdesc; 
-      id = first_match       
-	     ~f:(function `Id id -> id | _ -> raise Wrong_type)                          
-	     ~name:"id" bdesc; 
+    { pos = first_match
+              ~f:(function `Pos pos -> pos | _ -> raise Wrong_type)
+              ~name:"pos" bdesc;
+      velocity = first_match
+                   ~f:(function `Velocity velocity -> velocity | _ -> raise Wrong_type)
+                   ~name:"velocity" bdesc;
+      radius = first_match
+                 ~f:(function `Radius radius -> radius | _ -> raise Wrong_type)
+                 ~name:"radius" bdesc;
+      color = first_match
+                ~f:(function `Color (color:string) -> `Color color | _ -> raise Wrong_type)
+                ~name:"color" bdesc;
+      mass = first_match
+               ~f:(function `Mass mass -> mass | _ -> raise Wrong_type)
+               ~name:"mass" bdesc;
+      id = first_match
+             ~f:(function `Id id -> id | _ -> raise Wrong_type)
+             ~name:"id" bdesc;
       i = None
     }
-  with 
+  with
       Missing name ->
-	raise (Missing (sprintf "body: %s" name))
+        raise (Missing (sprintf "body: %s" name))
 
 
-let build_state sdesc = 
+let build_state sdesc =
   try
-    { 
+    {
       d_zoom = first_match ~f:(function `Zoom zoom -> zoom  | _ -> raise Wrong_type)                              ~name:"zoom" sdesc;
-      d_center = first_match_default ~f:(function `Center center -> center  | _ -> raise Wrong_type) 	          ~name:"center"             ~default:(0.,0.) sdesc;
-      d_delta = first_match ~f:(function `Delta delta -> delta  | _ -> raise Wrong_type) 		          ~name:"delta" sdesc;
+      d_center = first_match_default ~f:(function `Center center -> center  | _ -> raise Wrong_type)              ~name:"center"             ~default:(0.,0.) sdesc;
+      d_delta = first_match ~f:(function `Delta delta -> delta  | _ -> raise Wrong_type)                          ~name:"delta" sdesc;
       d_bodies = List.map ~f:build_body   (all_matches ~f:(function `Body bodies -> bodies | _ -> raise Wrong_type) sdesc);
     }
   with Missing name ->
 (********************************************************************)
 (********************************************************************)
 
-let parse_state in_c = 
+let parse_state in_c =
   let token_stream = lexer (Stream.of_channel in_c) in
     build_state (parse_next [] token_stream)
 
 let string_of_float x = sprintf "%.20e" x
 let string_of_int x = sprintf "%d" x
 
-let string_of_pair pair = 
-  sprintf "(%s, %s)" (string_of_float (fst pair)) 
+let string_of_pair pair =
+  sprintf "(%s, %s)" (string_of_float (fst pair))
     (string_of_float (snd pair))
 
 let string_of_color color = match color with
     fprintf out_c "%scolor    \"%s\"\n" indent (string_of_color body.color);
     fprintf out_c "%sid       %s\n" indent (string_of_int body.id)
 
-let write_state out_c = 
+let write_state out_c =
   fprintf out_c "zoom   %s\n" (string_of_float state.zoom#v);
   fprintf out_c "center %s\n" (string_of_pair state.center#v);
   fprintf out_c "delta  %s\n" (string_of_float state.delta#v);
   close_out out_c
 
 
-(* Some final details: 
+(* Some final details:
    choosing the save directory and the external interface *)
 
-let is_dir fname = 
+let is_dir fname =
   let stats = Unix.stat fname in
     stats.Unix.st_kind = Unix.S_DIR
 
-let save_directory = 
-  try 
+let save_directory =
+  try
     let home = Sys.getenv "HOME" in
     let pdir = Filename.concat home ".planets" in
     if Sys.file_exists pdir & is_dir pdir
     then pdir
-    else 
+    else
       (* PROBLEM: is 0x1FF really the right mode? *)
-      try Unix.mkdir pdir 0x1FF; pdir 
-      with Unix.Unix_error (err,func,arg) -> ""
+      try Unix.mkdir pdir ~perm:0x1FF; pdir
+      with Unix.Unix_error (_,_,_) -> ""
   with
       Not_found -> ""
 
 (******************************************************************)
 
 let write_state_file filename = write_state (open_out filename)
-let read_state_file filename = 
+let read_state_file filename =
   let dead_state = parse_state (open_in filename) in
   reanimate_dead_state dead_state
 
   try
     write_state_file fname
   with
-      Sys_error x -> 
-	Common.debug_msg (sprintf "%s: failed to load file %s" x fname)
+      Sys_error x ->
+        Common.debug_msg (sprintf "%s: failed to load file %s" x fname)
 
-let read_state key = 
+let read_state key =
   let fname = Filename.concat save_directory (saved_fname key) in
   try
     read_state_file fname
-  with 
-      Sys_error x -> 
-	Common.debug_msg (sprintf "%s: failed to load file %s" x fname)
-  
+  with
+      Sys_error x ->
+        Common.debug_msg (sprintf "%s: failed to load file %s" x fname)
+
 
 (****************************************************************)
 
 
 let set_help_start x = match x with
     true -> if Sys.file_exists help_fname then Sys.remove help_fname
-  | false -> 
+  | false ->
       let file = open_out help_fname in
       close_out file
-    
+
     You should have received a copy of the GNU General Public License
     along with this program; if not, write to the Free Software
     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
+*)
 
 open StdLabels
 
 
 (* Basic types *)
 type body = { pos: float * float;
-	      velocity: float * float;
-	      radius: float;
-	      color: color;
-	      mass: float;
-	      id: int;
-	      i: (float * float) option; (* extra integration info.  
-					    Will be used for Runge-Kutta info *)
-	    }
+              velocity: float * float;
+              radius: float;
+              color: color;
+              mass: float;
+              id: int;
+              i: (float * float) option; (* extra integration info.
+                                            Will be used for Runge-Kutta info *)
+            }
 
 type state = { zoom: float Options.live_value;
-	       center: (float * float)  Options.live_value;
-	       delta:  float Options.live_value;
-	       mutable bodies:  body list;
-	     }
+               center: (float * float)  Options.live_value;
+               delta:  float Options.live_value;
+               mutable bodies:  body list;
+             }
 
 type dead_state = { d_zoom: float;
-		    d_center: float * float;
-		    d_delta: float;
-		    d_bodies: body list;
-		  }
+                    d_center: float * float;
+                    d_delta: float;
+                    d_bodies: body list;
+                  }
 
 let state = { zoom = new Options.live_value 1.0;
-	      center = new Options.live_value (0.0, 0.0);
-	      delta = new Options.live_value 5.0;
-	      bodies = [];
-	    }
+              center = new Options.live_value (0.0, 0.0);
+              delta = new Options.live_value 5.0;
+              bodies = [];
+            }
 
 
 (***************************************************************************)
 (* Transient state. *)
 
 type trace_point = { t_pos: float * float;
-		     t_round: int; 
-		   }
+                     t_round: int;
+                   }
 
 type trace = { t_queue: trace_point Fqueue.t;
-	       t_color: color;
-	     }
+               t_color: color;
+             }
 
 
 let empty_trace color = { t_queue = Fqueue.empty;
-			  t_color = color;
-			}
+                          t_color = color;
+                        }
 
 
 
-type transient = { mutable traces: trace IntMap.t; 
-		   mutable trace_round: int;
-		   mutable com_trace: trace;
-		   bound: int Options.live_value;
-		 }
+type transient = { mutable traces: trace IntMap.t;
+                   mutable trace_round: int;
+                   mutable com_trace: trace;
+                   bound: int Options.live_value;
+                 }
 
-let transient =  { traces = IntMap.empty; 
-		   com_trace = empty_trace `Black;
-		   trace_round = 0;
-		   bound = new Options.live_value 20;
-		 }
+let transient =  { traces = IntMap.empty;
+                   com_trace = empty_trace `Black;
+                   trace_round = 0;
+                   bound = new Options.live_value 20;
+                 }
 
 
 (************************************************)
 
 let set_trace_bound = transient.bound#set
 
-let trace_inc () = 
+let trace_inc () =
   transient.trace_round <- transient.trace_round + 1
 
-let trace_push pos trace = 
+let trace_push pos trace =
   { trace with t_queue = Fqueue.push { t_pos = pos;
-				       t_round = transient.trace_round; } 
-			   trace.t_queue
+                                       t_round = transient.trace_round; }
+      trace.t_queue
   }
-  
+
 let trace_to_list trace =
   let trace_queue = Fqueue.to_list trace.t_queue in
   List.map ~f:(fun trace_point -> trace_point.t_pos)
     trace_queue
 
-let rec trace_filt trace = 
+let rec trace_filt trace =
   try
     let oldest = Fqueue.top trace.t_queue in
-      if transient.trace_round - oldest.t_round > transient.bound#v
-      then trace_filt { trace with t_queue = Fqueue.remove trace.t_queue }
-      else trace
-  with 
-      Fqueue.Empty -> trace
+    if transient.trace_round - oldest.t_round > transient.bound#v
+    then trace_filt { trace with t_queue = Fqueue.remove trace.t_queue }
+    else trace
+  with
+    Fqueue.Empty -> trace
 
 (*************************************************)
 (*************************************************)
 
 let add_to_trace body =
-  let trace = 
+  let trace =
     try
       IntMap.find body.id transient.traces
     with
       Not_found -> empty_trace body.color
   in
-    transient.traces <- 
+  transient.traces <-
     IntMap.add ~key:body.id ~data:(trace_push body.pos trace) transient.traces
 
 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
-    
-let update_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
+
+let update_traces () =
   List.iter ~f:add_to_trace state.bodies;
   trace_inc ();
   transient.traces <- IntMap.map ~f:trace_filt transient.traces;
 
 (*************************************************)
 
-let clear_trace body = 
+let clear_trace body =
   transient.traces <- IntMap.remove body.id  transient.traces
 
 (*************************************************)
 
-let remove_traces ids = 
-  transient.traces <- 
-  List.fold_left
-  ~f:(fun map id -> IntMap.remove id map)
-  ~init:transient.traces ids
+let remove_traces ids =
+  transient.traces <-
+    List.fold_left
+    ~f:(fun map id -> IntMap.remove id map)
+    ~init:transient.traces ids
 
 let clear_all_traces () =
-  transient.traces <- (IntMap.map 
-			 ~f:(fun trace -> { trace with t_queue = Fqueue.empty})
-			 transient.traces);
+  transient.traces <- (IntMap.map
+                         ~f:(fun trace -> { trace with t_queue = Fqueue.empty})
+                         transient.traces);
   transient.traces <- remove_empty_traces ()
 
 (***************************************************************************)
 let undo_states = ref []
 
 (* calls to set_undo_point and set_goback_point should always be paired *)
-let set_undo_point () = 
+let set_undo_point () =
   undo_states := (copy_state state)::!undo_states
 
 let set_goback_point () =
   goback_states := (copy_state state)::!goback_states
-  
-let undo () = 
+
+let undo () =
   match !undo_states with
-      [] -> ()
-    | hd::tl -> 
-	reanimate_dead_state hd;
-	undo_states := tl;
-	match !goback_states with
-	    [] -> failwith "State.undo: BUG. laststates should not be empty"
-	  | hd::tl -> goback_states := tl
+    [] -> ()
+  | hd::tl ->
+    reanimate_dead_state hd;
+    undo_states := tl;
+    match !goback_states with
+    | [] -> failwith "State.undo: BUG. laststates should not be empty"
+    | _::tl -> goback_states := tl
 
 let goback () =
   match !goback_states with
-      [] -> ()
-    | s::tl -> 
-	reanimate_dead_state s
+    [] -> ()
+  | s :: _ ->
+    reanimate_dead_state s