(* Planets: A simple 2-d celestial simulator Copyright (C) 2001-2003 Yaron M. Minsky This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. 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 open Tk open Printf open State open Common open Constants let gap_ms = Options.named_live_value "gap_ms" 30 (* period, in ms, between callbacks. 30ms corresponds to roughly 33 frames/sec *) 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 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 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 _ = 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 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 sqrt (max_r ** 2.0 +. max_g ** 2.0 +. max_b ** 2.0) let test_color r g b = (r >= 0 && r < 256) && (g >= 0 && g < 256) && (b >= 0 && b < 256) let renormalize 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) in assert (test_color r g b); rgb r g b let rand_range () = Random.int 256 let rand_color () = 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 -> () 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 in state.bodies <- changebodies state.bodies; change_trace_color id color let hlcolor = `Yellow let fgcolor = `White let bgcolor = `Black let uw opt = match opt with Some x -> x | None -> failwith "Display.uw: attempt to unwrap null option" (****************************************************) (****************************************************) (****************************************************) let compute_energy () = let p = Physics.penergy state.bodies and k = Physics.kenergy state.bodies in penergy#set (log (abs_float p)); kenergy#set (log k); energy#set (log (abs_float (p +. k))) (****************************************************) (****************************************************) (****************************************************) type ('a,'b,'c,'d) disp_state = { mutable toplevel: Widget.toplevel Widget.widget option; 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; paused: Options.live_toggle; tracing: Options.live_toggle; tracking: Options.live_toggle; } let disp_state = { toplevel = None; frame = None; canvas = None; optionbox = None; dbodies = IntMap.empty; dtraces = IntMap.empty; tracked_ids = IntSet.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 canvas () = uw disp_state.canvas let init_optionbox () = let obox = new Options.optionbox (uw disp_state.toplevel) in obox#set_liveness true; Options.add_option_live obox disp_state.paused (new Options.toggle_option ~text:(Lstrings.get `paused) ~set:disp_state.paused#set ~get:disp_state.paused#get ()); Options.add_option_live obox disp_state.tracing (new Options.toggle_option ~text:(Lstrings.get `tracing) ~set:disp_state.tracing#set ~get:disp_state.tracing#get ()); Options.add_option_live obox truebounce (new Options.toggle_option ~text:(Lstrings.get `true_bounce) ~set:truebounce#set ~get:truebounce#get ()); Options.add_option_live obox transient.bound (new Options.int_scale_option ~text:(Lstrings.get `trace_length) ~set:transient.bound#set ~get:transient.bound#get ~min:3.0 ~max:300.0 ()); Options.add_option_live obox gap_ms (new Options.int_scale_option ~text:(Lstrings.get `disp_period) ~set:gap_ms#set ~get:gap_ms#get ~min:1.0 ~max:100.0 ()); Options.add_option_live obox iterations (new Options.int_scale_option ~text:(Lstrings.get `iter_display) ~set:iterations#set ~get:iterations#get ~min:1.0 ~max:100.0 ()); Options.add_option_live obox state.delta (new Options.float_entry_option ~text:(Lstrings.get `time_step) ~mult:1.05 ~set:state.delta#set ~get:state.delta#get ()); Options.add_option_live obox gconst (new Options.float_entry_option ~text:(Lstrings.get `g) ~mult:1.05 ~set:gconst#set ~get:gconst#get ()); Options.add_option_live obox grav_exp (new Options.float_entry_option ~text:(Lstrings.get `grav_exp) ~mult:1.01 ~set:grav_exp#set ~get:grav_exp#get ()); Options.add_option obox (new Options.void_entry_display ~text:"New random bodies:" ()); Options.add_option_live obox diameter_multiplier (new Options.float_entry_option ~text:(Lstrings.get `diam_mult) ~mult:1.01 ~set:diameter_multiplier#set ~get:diameter_multiplier#get ()); Options.add_option_live obox random_vel_multiplier (new Options.float_entry_option ~text:(Lstrings.get `rand_vel_mult) ~mult:1.01 ~set:random_vel_multiplier#set ~get:random_vel_multiplier#get ()); (* Energy Display *) Options.add_option_live obox kenergy (new Options.float_entry_display ~text:(Lstrings.get `log_k_energy) ~set:kenergy#set ~get:kenergy#get ()); Options.add_option_live obox penergy (new Options.float_entry_display ~text:(Lstrings.get `log_p_energy) ~set:penergy#set ~get:penergy#get ()); Options.add_option_live obox energy (new Options.float_entry_display ~text:(Lstrings.get `log_energy) ~set:energy#set ~get:energy#get ()); Options.add_option_live obox num_bodies (new Options.int_entry_display ~text:(Lstrings.get `num_planets) ~set:num_bodies#set ~get:num_bodies#get ()); disp_state.optionbox <- Some obox let toggle_opt_dialog () = match disp_state.optionbox with None -> failwith "Display.create_dialog: Attempt to display optionbox when none is available" | Some obox -> if obox#mapped then obox#destroy else obox#create_dialog ~geometry:"+0+0" ~transient:(uw disp_state.toplevel) ~clas:app_class () (********************************************************) (** Display Classes ***********************************) (********************************************************) (** Note: just screwing around here. Classes are not yet used. **) class virtual ['a] display_item tag = object (self) val tag = tag val mutable alive = true method destroy = if not alive then failwith "Attempt to destroy same display_item more than once" else (Canvas.delete (canvas ()) [tag]; alive <- false) method draw item = if not alive then failwith "Display.display_item#draw: attempt to draw deleted item." else self#draw_internal item (* Here's where you put the logic for drawing an item*) method virtual draw_internal : 'a -> unit end (************************************************) class dbody body tag = let tag = tag in object (self) inherit [body] display_item tag val id = body.id 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)) in Canvas.configure_oval ~fill:body.color ~outline:fgcolor (canvas ()) tag; Canvas.coords_set (canvas ()) tag ~xys:[ (x1,y1) ; (x2,y2) ] initializer begin Canvas.bind ~events:[`ButtonPress] ~extend:false ~fields:[] ~action:(fun e -> delete_body_by_id id) (* change_body_color_by_id id) *) (canvas ()) tag; self#draw_internal body end end let new_dbody_with_tag body tag = new dbody body tag let new_dbody_from_body body = let tag = Canvas.create_oval ~x1:0 ~y1:0 ~x2:0 ~y2:0 (canvas ()) in new dbody body tag (************************************************) 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)) in let _ = Canvas.configure_line ~smooth:false (canvas ()) tag in object (self) inherit [trace] display_item tag method draw_internal trace = let screen_trace = List.map ~f:pair_to_int (List.map ~f:real_to_screen (trace_to_list trace)) in if List.length screen_trace > 1 then ( Canvas.configure_line ~fill:trace.t_color (canvas ()) tag; Canvas.coords_set (canvas ()) tag ~xys:screen_trace ) end (**********************************************************) (** Classes used in the placement of new planets *******) (**********************************************************) class ['a] new_planet () = let tag = Canvas.create_oval ~x1:0 ~y1:0 ~x2:0 ~y2:0 (canvas ()) in object (self) inherit ['a] display_item tag val mutable radius = 0.0 val mutable pos = (0,0) val mutable color = fgcolor method draw_internal (x,y) = 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) method set_radius _radius = radius <- _radius; self#draw_internal pos method set_color _color = Canvas.configure_oval ~fill:_color (canvas ()) tag; color <- _color method tag = tag method pos = pos method radius = radius method color = color initializer Canvas.configure_oval ~outline:fgcolor (canvas ()) tag end (******) class ['a] new_velocity planet = 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) inherit ['a] display_item tag val mutable vpos = planet#pos method draw_internal _vpos = Canvas.coords_set (canvas ()) tag ~xys:[pos; _vpos]; vpos <- _vpos method vpos = vpos method tag = tag end (*********************************************************) (** Functions for selecting bodies *********************) (*********************************************************) let selected_bodies pos1 pos2 = let (x1,y1) = pair_to_float pos1 and (x2,y2) = pair_to_float pos2 in let x1,x2 = (min x1 x2), (max x1 x2) and y1,y2 = (min y1 y2), (max y1 y2) in List.filter ~f:(fun body -> let (x,y) = real_to_screen body.pos in x1 <= x && x <= x2 && y1 <= y && y <= y2) state.bodies let selected_ids pos1 pos2 = IntSet.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" 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 ()) (***********************************************************) (** Primitives for displaying and deleting display items *) (***********************************************************) 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 -> printf "No dbody with id %d" id; print_newline () 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 -> printf "No dtrace with id: %d" id; print_newline () (***************************************************) (* Lookup functions for dbody/dtrace. * If one is not found, one is created. *) 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 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 (****************) 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 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} ) bodies in 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 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 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_state.tracing#register_callback (fun oldval newval -> if not newval then remove_all_traces ()) let remove_dead () = remove_dead_bodies (); remove_dead_traces () (********************************************************) let redraw_all_basic () = draw_bodies (); if disp_state.tracing#v then draw_traces () let redraw_all () = redraw_all_basic (); remove_dead () (*********************************************************) (*********************************************************) (*********************************************************) let pause () = disp_state.paused#set true let resume () = disp_state.paused#set false let init_body ~color ~pos ~velocity ~radius = let body = { pos = pos; velocity = velocity; radius = radius; color = color; mass = radius ** 3.0; id = Random.bits (); i = None; } in set_undo_point (); state.bodies <- body::state.bodies; set_goback_point (); body let add_new_body ~color ~pos ~vpos ~r = let r = r /. state.zoom#v in init_body ~color ~pos:(screen_to_real pos) ~velocity:((state.zoom#v *. 10.0) <|> (pair_to_float vpos <-> pair_to_float pos)) ~radius:r 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 (* 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 in if tbodies != [] then (Physics.zero_speed_bodies tbodies; Physics.center_bodies tbodies) (*****************************************************) (*****************************************************) let file_join filelist = let rec file_join filelist partial = match filelist with [] -> partial | hd::tl -> file_join tl (Filename.concat partial hd) in 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 is_num c = (int_of_char '0') <= (int_of_char c) && (int_of_char c) <= (int_of_char '9') let to_num c = (int_of_char c) - (int_of_char '0') (* Center weighted random float *) let cw_rand_float level f = let x = Random.float 2.0 in let x = x -. 1.0 in let mult = if x >= 0.0 then (x**level +. 1.0) /. 2.0 else (-.abs_float(x**level) +. 1.0) /. 2.0 in mult *. f let cw_rand_int level i = let f_val = cw_rand_float level (float i) in round f_val let random_velocity size = let screen_vel = ( (Random.float (2.0 *. size)) -. size, (Random.float (2.0 *. size)) -. size ) in random_vel_multiplier#v <*> (state.zoom#v <|> screen_vel) let random_planet () = let screen_radius = planet_radius 3 and screen_pos = (Random.float (float !screen_width), Random.float (float !screen_height)) and velocity = random_velocity 0.9 and color = rand_color () in let pos = screen_to_real_float screen_pos and radius = screen_radius /. state.zoom#v in ignore (init_body ~color ~pos ~velocity ~radius) let mag v = sqrt (dot v v) let tweak_size = 0.1 let rand_tweak size = ((Random.float 2.0) -. 1.) *. size *. tweak_size let rdist ?(n=6) low high = let x = ref 0.0 in for i = 0 to n -1 do x := !x +. Random.float (1.0/. float n) done; low +. (high -. low) *. !x (** adds a planet at what would be a near-orbital velocity if the force induced on the new planet all came from a single planet. *) let orbital_planet dir = let screen_radius = planet_radius (Random.int 3 + 1) in let radius = screen_radius /. state.zoom#v in let color = rand_color () in let screen_pos = (rdist ~n:3 0. (float !screen_width), rdist ~n:3 0. (float !screen_height)) in let pos = screen_to_real_float screen_pos in let ovelocity = Physics.induced_orbital_velocity state.bodies ~pos dir in let speed = mag ovelocity in let velocity = ovelocity +| (rand_tweak speed,rand_tweak speed) in ignore (init_body ~color ~pos ~velocity ~radius) (*******************************************************) (** Callbacks *************************************) (*******************************************************) type key_matcher = | Key of string | KeySym of string | KeyList of string list | Other type key_handler = { key: key_matcher; description: string; handler: eventInfo -> unit; } let rec lookup handlers key = match handlers with | handler::tl -> if handler.key = key then Some handler else lookup tl key | [] -> None let handler_to_string h = let matcher = match h.key with Key s -> s | KeySym s -> s | KeyList slist -> String.concat ", " slist | Other -> "Any other key" in "\t" ^ matcher ^ (if String.length matcher > 8 then "" else "\t") ^ "\t " ^ h.description let hlist_to_string hlist = let slist = List.map ~f:handler_to_string hlist in String.concat "\n" slist (***********************************************************) let rec get_next_key ~f = let handle e = f e.ev_Char; set_normal_key_handler () in bind_class ~events:[`KeyPress] ~extend:false ~fields:[`Char] ~action:handle app_class (***********************************************************) (** UI State Machine ************************************) (***********************************************************) (* Events: Motion, ButtonRelease, ButtonPress, KeyPress A: default_state: def_key_map "a" -> B:create_planet ButtonPress -> D:draw_rectangle Motion -> nothing ButtonRelease -> nothing B: create_planet: Save Pause, pause [0-9] -> change_planet_size Motion -> move planet BottonPress -> place planet, C:set_planet_direction ButtonRelease -> nothing (can't be reached anyway) C: set_planet_direction: [0-9] -> change_planet_size Motion -> move arrow ButtonPress -> set arrow, restore pause state, A:default_state ButtonRelease -> nothing D: draw_rectangle: save pause, pause No keymap ButtonPress -> nothing ButtonRelease -> restore pause A:default_state Motion -> move rectangle *) (***********************************************************) (** Planet Select ****************************************) (***********************************************************) and select_planet_handler e = clear_select_planet_handler (); clear_key_handler (); let pos = (e.ev_MouseX,e.ev_MouseY) in let pos1 = ref pos and pos2 = ref pos in let tag = create_rectangle fgcolor !pos1 !pos2 in let move e = pos2 := (e.ev_MouseX,e.ev_MouseY); Canvas.coords_set (canvas ()) tag ~xys:[!pos1; !pos2] and finish pause_state e = Canvas.delete (canvas ()) [tag]; disp_state.tracked_ids <- selected_ids !pos1 !pos2; disp_state.paused#set pause_state; disp_state.tracking#set true; restore_normal_bindings (); redraw_all () in let old_pause_state = disp_state.paused#v in disp_state.paused#set true; bind ~events:[`Motion] ~extend:false ~fields:[`MouseX;`MouseY] ~action:move (uw disp_state.canvas); bind ~events:[`ButtonRelease] ~extend:false ~fields:[] ~action:(finish old_pause_state) (uw disp_state.canvas) and set_select_planet_handler () = bind ~events:[`ButtonPress] ~extend:false ~fields:[`MouseX; `MouseY] ~action:select_planet_handler (uw disp_state.canvas) and clear_select_planet_handler () = bind ~events:[`ButtonPress] (uw disp_state.canvas) (***********************************************************) (** Add Planet ******************************************) (***********************************************************) and add_planet pos rad_int = let rec move_planet planet e = planet#draw (e.ev_MouseX,e.ev_MouseY) and set_radius planet e = if String.length e.ev_Char > 0 && is_num e.ev_Char.[0] then let rad_int = to_num e.ev_Char.[0] in planet#set_radius (planet_radius rad_int) else if e.ev_KeySymString="Down" then planet#set_radius (planet#radius *. (1.0/.1.1)) else if e.ev_KeySymString="Up" then planet#set_radius (planet#radius *. 1.1) and move_velocity velocity e = velocity#draw (e.ev_MouseX,e.ev_MouseY) and set_place planet pause_state e = planet#draw (e.ev_MouseX,e.ev_MouseY); planet#set_color (rand_color ()); let velocity = new new_velocity planet in bind ~events:[`Motion] ~extend:false ~fields:[ `MouseX; `MouseY] ~action:(move_velocity velocity) (uw disp_state.canvas); bind ~events:[`ButtonPress] ~extend:false ~fields:[] ~action:(finish pause_state planet velocity) (uw disp_state.canvas) and finish pause_state planet velocity e = bind ~events:[`Motion] ~extend:false (uw disp_state.canvas); bind ~events:[`ButtonPress] ~extend:false (uw disp_state.canvas); restore_normal_bindings (); disp_state.paused#set pause_state; velocity#destroy; let body = add_new_body ~color:planet#color ~pos:planet#pos ~vpos:velocity#vpos ~r:planet#radius in add_dbody_from_tag body planet#tag in let old_pause_state = disp_state.paused#v in let planet = new new_planet () in planet#set_radius (planet_radius rad_int); planet#draw pos; disp_state.paused#set true; bind ~events:[`Motion] ~extend:false ~fields:[ `MouseX; `MouseY] ~action:(move_planet planet) (uw disp_state.canvas); bind_class ~events:[`KeyPress] ~extend:false ~fields:[ `Char; `KeySymString ] ~action:(set_radius planet) app_class; bind ~events:[`ButtonPress] ~extend:false ~fields:[`MouseX; `MouseY] ~action:(set_place planet old_pause_state) (uw disp_state.canvas); bind ~events:[`ButtonRelease] ~extend:false ~fields:[] (uw disp_state.canvas) (***********************************************************) (***********************************************************) and keyhandlers = [ { key = Key "H"; description = (Lstrings.get `display_help ); handler = (fun e -> Help.create_window (uw disp_state.toplevel) (hlist_to_string keyhandlers)); }; { key = Key "a"; description = (Lstrings.get `add_planet ); handler = (fun e -> add_planet (e.ev_MouseX,e.ev_MouseY) 3); }; { key = KeyList ["plus";"equal";"KP_Add"]; description = (Lstrings.get `zoom_in ); handler = (fun e -> 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 -> 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;) }; { key = KeyList ["c"; "space"]; description = (Lstrings.get `center); handler = (fun e -> disp_state.tracking#set false; Physics.zero_speed (); Physics.center (); clear_all_traces (); redraw_all_basic ()) }; { key = Key "k"; description = (Lstrings.get `option_dialog); handler = (fun e -> toggle_opt_dialog ()) }; { key = Key "o"; description = (Lstrings.get `change_all_colors); handler = (fun e -> change_all_body_colors (); redraw_all_basic ()); }; { key = KeyList [ "q" ; "Escape"] ; description = (Lstrings.get `quit); handler = (fun e -> exit 0); }; { key = Key "e" ; description = (Lstrings.get `reset); handler = (fun e -> clear_all_traces (); state.bodies <- []; redraw_all ()); }; { key = Key "s"; description = (Lstrings.get `save ); handler = (fun e -> let old_pause_state = disp_state.paused#v in disp_state.paused#set true; get_next_key ~f:(fun key -> clear_all_traces (); SaveState.write_state key; disp_state.paused#set old_pause_state )); }; { key = Key "l"; description = (Lstrings.get `load); handler = (fun e -> let old_pause_state = disp_state.paused#v in disp_state.paused#set true; get_next_key ~f:(fun key -> debug_msg "Starting to load universe"; clear_all_traces (); SaveState.read_state key; debug_msg (sprintf "Done loading: %d planets" (List.length state.bodies)); redraw_all (); debug_msg "Done redrawing"; disp_state.paused#set old_pause_state )); }; { key = Key "u"; description = (Lstrings.get `undo); handler = (fun e -> undo (); clear_all_traces (); redraw_all ()) }; { key = Key "g"; description = (Lstrings.get `goback); handler = (fun e -> goback (); clear_all_traces (); redraw_all ()) }; { key = Key "p"; description = (Lstrings.get `toggle_pause); handler = (fun e -> disp_state.paused#flip) }; { key = Key "t"; description = (Lstrings.get `toggle_trace); handler = (fun e -> disp_state.tracing#flip) }; { key = Key "d"; description = (Lstrings.get `double_trace); handler = (fun e -> transient.bound#set (min 300 (transient.bound#v * 2))); }; { key = Key "h"; description = (Lstrings.get `halve_trace ); handler = (fun e -> transient.bound#set (max 3 (transient.bound#v / 2)) ) }; { key = Key "j"; description = (Lstrings.get `place_random_orbital ); handler = (fun e -> orbital_planet (Random.int 2 = 1) ) }; { key = Key "J"; description = (Lstrings.get `place_random_orbital_uni ); handler = (fun e -> orbital_planet true) }; { key = Key "r"; description = (Lstrings.get `place_random ); handler = (fun e -> random_planet () ) }; { key = Key "x"; description = (Lstrings.get `cancel_com ); handler = (fun e -> disp_state.tracking#flip; ) }; (* Panning Around *) { key = KeySym "Up"; description = (Lstrings.get `pan_up); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic ()); }; { key = KeySym "Down"; description = (Lstrings.get `pan_down); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic () ); }; { key = KeySym "Left"; description = (Lstrings.get `pan_left); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic () ); }; { key = KeySym "Right"; description = (Lstrings.get `pan_right); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic () ); }; ] and kid_keyhandlers = [ { key = KeyList ["KP_Home"; "KP_Up"; "KP_Prior"; "KP_Left"; "KP_Begin"; "KP_Right"; "KP_End"; "KP_Down"; "KP_Next"; "KP_Insert"; "KP_Delete"; "KP_En`ter"; "KP_Add"; "KP_Multiply"; "KP_Divide"; "Num_Lock"; ]; description = (Lstrings.get `place_random ); handler = (fun e -> random_planet () ) }; { key = Key "="; description = (Lstrings.get `zoom_in ); handler = (fun e -> state.zoom#set (state.zoom#v *. 1.1); redraw_all_basic ()); }; { key = Key "-"; description = (Lstrings.get `zoom_out ); handler = (fun e -> state.zoom#set (state.zoom#v *. 0.9); redraw_all_basic ()); }; { key = KeySym "Up"; description = (Lstrings.get `pan_up); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic ()); }; { key = KeySym "Down"; description = (Lstrings.get `pan_down); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic () ); }; { key = KeySym "Left"; description = (Lstrings.get `pan_left); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic () ); }; { key = KeySym "Right"; description = (Lstrings.get `pan_right); handler = (fun e -> 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 state.center#set (x,y); redraw_all_basic () ); }; { key = KeySym "space"; description = (Lstrings.get `center); handler = (fun e -> disp_state.tracking#set false; Physics.zero_speed (); Physics.center (); clear_all_traces (); redraw_all_basic ()) }; { key = KeyList ["q";"w";"e";"a";"s";"d";"z";"x";"c"]; description = (Lstrings.get `change_all_colors); handler = (fun e -> 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 -> disp_state.tracing#flip) }; { key = KeySym "Escape"; description = (Lstrings.get `reset); handler = (fun e -> clear_all_traces (); state.bodies <- []; redraw_all ()); }; { key = Other; description = (Lstrings.get `place_random ); handler = (fun e -> orbital_planet (Random.int 2 = 0) ) }; ] and main_key_handler e = debug_msg "Key handler"; Focus.force (uw disp_state.toplevel); 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 hkeys | Other -> true ) then ( debug_msg handler.description; handler.handler e; ) else loop tl | [] -> debug_msg ("Other Key: " ^ keysym) in if kidmode#v then loop kid_keyhandlers else loop keyhandlers and clear_key_handler () = bind_class ~events:[`KeyPress] app_class and set_normal_key_handler () = bind_class ~events:[`KeyPress] ~extend:false ~fields:[`Char;`MouseX;`MouseY;`KeySymString] ~action:main_key_handler app_class (* sets up all handlers that might be fiddled with *) and restore_normal_bindings () = set_select_planet_handler (); set_normal_key_handler (); bind ~events:[`ButtonRelease] (canvas ()); bind ~events:[`Motion] (canvas ()) (***************) let rec timer_cb () = let compute_timer = MTimer.create () in let full_timer = MTimer.create () in let _ = if not disp_state.paused#v then ( MTimer.start full_timer; update (); MTimer.start compute_timer; Physics.simulate ~bounce:truebounce#v iterations#v; compute_energy (); num_bodies#set (List.length state.bodies); MTimer.stop compute_timer; track_com (); update_traces (); (let old_debugging = !debugging in debugging := false; redraw_all (); debugging := old_debugging); MTimer.stop full_timer; (* let compute_time_ms = MTimer.read_ms compute_timer and full_time_ms = MTimer.read_ms full_timer in debug_msg (sprintf "compute: %f ms, other: %f ms" compute_time_ms (full_time_ms -. compute_time_ms)) *) ) in let time_left_ms = max 0 (int_of_float (float_of_int gap_ms#v -. MTimer.read_ms full_timer )) in let full_time_ms = 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_width := width; screen_height := height (******************************************************************) let grab () = Grab.set ~global:true (uw disp_state.toplevel) let ungrab () = Grab.release (uw disp_state.toplevel) (* Toggle the focus mode. This is the first step towards building a kid-friendly version *) let toggle_kidmode () = (* transient.bounce#set true; *) match Grab.status (uw disp_state.toplevel) with `None -> grab () | `Global | `Local -> ungrab () let _ = kidmode#register_callback (fun oldv newv -> toggle_kidmode ()) let init () = disp_state.toplevel <- Some (openTk ~clas:app_class ()); disp_state.frame <- Some (Frame.create ~width:!screen_width ~height:!screen_height (uw disp_state.toplevel)); disp_state.canvas <- Some (Canvas.create ~width:init_screen_width ~height:init_screen_height (uw disp_state.frame)); screen_center := pair_to_float (init_screen_height / 2, init_screen_width / 2); if SaveState.help_start then Help.create_window (uw disp_state.toplevel) (hlist_to_string keyhandlers); Canvas.configure ~background:bgcolor (canvas ()); Pack.configure ~expand:true ~fill:`Both [uw disp_state.frame]; Pack.configure ~expand:true ~fill:`Both [uw disp_state.canvas]; timer_cb (); restore_normal_bindings (); bind ~events:[`Configure] ~extend:false ~fields:[`Width; `Height] ~action:set_size (canvas ()); bind_class ~events:[`Modified ([`Control; `Shift], `KeyPressDetail "K")] ~extend:true ~action:(fun _ -> kidmode#flip) app_class; appname_set "Planets"; init_optionbox (); mainLoop () let license_notice = sprintf " Planets %s, Copyright (C) 2001-2003 Yaron M. Minsky Planets comes with ABSOLUTELY NO WARRANTY; This is free software, and you are welcome to redistribute it under the terms of the GNU GPL; see the COPYING file for details. " version let main () = print_string license_notice; print_newline (); Random.self_init (); state.delta#set 0.45; state.bodies <- []; init () let _ = if not !Sys.interactive then main ()