openCore.Std(* Planets: A 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*)openCore.StdopenTklettrunc=Int.of_float(* Basic types *)typebody={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 *)}typestate={zoom:floatOptions.live_value;center:(float*float)Options.live_value;delta:floatOptions.live_value;mutablebodies:bodylist;}typedead_state={d_zoom:float;d_center:float*float;d_delta:float;d_bodies:bodylist;}letstate={zoom=newOptions.live_value1.0;center=newOptions.live_value(0.0,0.0);delta=newOptions.live_value5.0;bodies=[];}(***************************************************************************)(***************************************************************************)(***************************************************************************)(* Transient state. *)typetrace_point={t_pos:float*float;t_round:int;}typetrace={t_queue:trace_pointFqueue.t;t_color:color;}letempty_tracecolor={t_queue=Fqueue.empty;t_color=color;}typetransient={mutabletraces:traceInt.Map.t;mutabletrace_round:int;mutablecom_trace:trace;bound:intOptions.live_value;}lettransient={traces=Int.Map.empty;com_trace=empty_trace`Black;trace_round=0;bound=newOptions.live_value20;}(************************************************)(** Traces ************************************)(************************************************)letset_trace_bound=transient.bound#setlettrace_inc()=transient.trace_round<-transient.trace_round+1lettrace_pushpostrace={tracewitht_queue=Fqueue.enqueuetrace.t_queue{t_pos=pos;t_round=transient.trace_round;}}lettrace_to_listtrace=lettrace_queue=Fqueue.to_listtrace.t_queueinList.map~f:(funtrace_point->trace_point.t_pos)trace_queueletrectrace_filttrace=matchFqueue.dequeuetrace.t_queuewith|None->trace|Some(oldest,remaining)->iftransient.trace_round-oldest.t_round>transient.bound#vthentrace_filt{tracewitht_queue=remaining}elsetrace(*************************************************)(*************************************************)letadd_to_tracebody=lettrace=matchMap.findtransient.tracesbody.idwith|Somex->x|None->empty_tracebody.colorintransient.traces<-Map.addtransient.traces~key:body.id~data:(trace_pushbody.postrace)letadd_to_com_tracecom=transient.com_trace<-trace_pushcomtransient.com_traceletremove_empty_traces()=Map.foldtransient.traces~init:Int.Map.empty~f:(fun~key:id~data:tracemap->ifFqueue.lengthtrace.t_queue=0thenmapelseMap.addmap~key:id~data:trace)letupdate_traces()=List.iter~f:add_to_tracestate.bodies;trace_inc();transient.traces<-Map.map~f:trace_filttransient.traces;transient.traces<-remove_empty_traces()(*************************************************)letclear_tracebody=transient.traces<-Map.removetransient.tracesbody.id(*************************************************)letremove_tracesids=transient.traces<-List.fold_left~f:(funmapid->Map.removemapid)~init:transient.tracesidsletclear_all_traces()=transient.traces<-(Map.map~f:(funtrace->{tracewitht_queue=Fqueue.empty})transient.traces);transient.traces<-remove_empty_traces()(***************************************************************************)(***************************************************************************)(***************************************************************************)letscreen_center=ref(0.0,0.0)letscreen_width=ref500letscreen_height=ref500(***************************************************************************)(** Undo and Goback support **********************************************)(***************************************************************************)letreanimate_dead_statedstate=state.zoom#setdstate.d_zoom;state.center#setdstate.d_center;state.delta#setdstate.d_delta;state.bodies<-dstate.d_bodiesletcopy_statestate={d_zoom=state.zoom#v;d_center=state.center#v;d_delta=state.delta#v;d_bodies=state.bodies;}(* Two separate quees are kept, one for goback, one for undo *)letgoback_states=ref[]letundo_states=ref[](* calls to set_undo_point and set_goback_point should always be paired *)letset_undo_point()=undo_states:=(copy_statestate)::!undo_statesletset_goback_point()=goback_states:=(copy_statestate)::!goback_statesletundo()=match!undo_stateswith[]->()|hd::tl->reanimate_dead_statehd;undo_states:=tl;match!goback_stateswith|[]->failwith"State.undo: BUG. laststates should not be empty"|_::tl->goback_states:=tlletgoback()=match!goback_stateswith[]->()|s::_->reanimate_dead_states(********************************************************)(********************************************************)(********************************************************)letvzero=(0.,0.)letadd_vect(x1,y1)(x2,y2)=(x1+.x2,y1+.y2)letsub_vect(x1,y1)(x2,y2)=(x1-.x2,y1-.y2)letsc_multscalar(x,y)=(scalar*.x,scalar*.y)letsc_divscalar(x,y)=(x/.scalar,y/.scalar)(* Define the following as infix operators, to make it easier to read *)let(<*>)scalarvect=sc_multscalarvect(* scalar mult *)let(<|>)scalarvect=sc_divscalarvect(* scalar division *)let(<+>)v1v2=add_vectv1v2(* vector addition *)let(<->)v1v2=sub_vectv1v2(* vector addition *)let(<.>)(x1,y1)(x2,y2)=x1*.x2+.y1*.y2(* dot product *)let(*|)scalarvect=sc_multscalarvect(* scalar mult *)let(/|)scalarvect=sc_divscalarvect(* scalar division *)let(+|)v1v2=add_vectv1v2(* vector addition *)let(-|)v1v2=sub_vectv1v2(* vector addition *)letdot(x1,y1)(x2,y2)=x1*.x2+.y1*.y2(* dot product *)letrotright(x1,y1)=(-.y1,x1)letrotleft(x1,y1)=(y1,-.x1)letprint_vect(x,y)=printf"(%3f, %3f)"xyletvsumvectors=letrecloopvectorssum=matchvectorswith[]->sum|v::tl->looptl(sum<+>v)inloopvectors(0.0,0.0)letsumnums=letrecloopnumssum=matchnumswith[]->sum|n::tl->looptl(sum+.n)inloopnums0.0(***********************************************)(***********************************************)(***********************************************)letpair_to_float(x,y)=(Float.of_intx,Float.of_inty)letpair_to_int(x,y)=(Int.of_floatx,Int.of_floaty)(* Simple graphics primitves *)letscreen_to_real_floatpos=state.center#v<+>(state.zoom#v<|>(pos<->!screen_center))letscreen_to_realpos=screen_to_real_float(pair_to_floatpos)letreal_to_screenpos=(state.zoom#v<*>(pos<->state.center#v))<+>!screen_center(****************)letwavgx1w1x2w2=((x1*.w1)+.(x2*.w2))/.(w1+.w2)letroundx=Float.to_int(Float.round_nearestx)letwavgix1w1x2w2=round(wavg(Float.of_intx1)w1(Float.of_intx2)w2)letrgbrgb=`Color(sprintf"#%02X%02X%02X"rgb)letdecompose_cintcint=letr=(0xFF0000landcint)lsr16andg=(0x00FF00landcint)lsr8andb=(0x0000FFlandcint)lsr0in(r,g,b)letdecompose_colorcolor=letcint=matchcolorwith`Colorcstr->int_of_string("0x"^(String.subcstr~pos:1~len:6))|`Black->0x00000|`White->0xFFFFFF|`Red->0xFF0000|`Green->0x00FF00|`Blue->0x0000FF|`Yellow->0xFFFF00indecompose_cintcintletjoin_colorsc1w1c2w2=let(r1,g1,b1)=decompose_colorc1and(r2,g2,b2)=decompose_colorc2inlet(r,g,b)=(wavgir1w1r2w2,wavgig1w1g2w2,wavgib1w1b2w2)inrgbrgb(*********************************************************************)letdelete_body_by_idid=set_undo_point();state.bodies<-List.filter~f:(funbody->body.id<>id)state.bodies;set_goback_point()(*********************************************************************)letprint_bodybody=print_string"pos: ";print_vectbody.pos;print_string" ";print_string"vel: ";print_vectbody.velocity;print_string"rad: ";printf"%5f"body.radius;print_newline()letrmult()=Random.float2.0-.1.0