File: saveState.ml

package info (click to toggle)
planets 0.1.13-19
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 512 kB
  • sloc: ml: 4,541; makefile: 207; ansic: 38
file content (233 lines) | stat: -rw-r--r-- 8,028 bytes parent folder | download | duplicates (9)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
(*  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
module Unix = UnixLabels

open Printf
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" ;
		       ]

let rec parse_next list = parser
  | [< 'Kwd "zoom"; 'Float x; e = parse_next ((`Zoom x)::list)  >] -> e
  | [< 'Kwd "center"; pair = parse_pair; e = parse_next ((`Center pair)::list) >] -> e
  | [< 'Kwd "delta"; 'Float x; e = parse_next ((`Delta x)::list) >] -> e
  | [< 'Kwd "iterations"; 'Int x; e = parse_next ((`Iter x)::list) >] -> e
  | [< 'Kwd "body"; e1 = parse_body ; e = parse_next (e1::list) >] -> e
  | [< >] -> list
and parse_body = parser
  | [< 'Kwd "["; body = parse_bnext []; 'Kwd "]" >] -> body
  | [< body = parse_bnext [] >] -> body
and parse_pair = parser
    [< 'Kwd "("; 'Float x; 'Kwd ","; 'Float y; 'Kwd ")" >] -> (x,y)
and parse_bnext list = parser
  | [< 'Kwd "pos";         pair = parse_pair;    e = parse_bnext ((`Pos pair)::list)>] -> e
  | [< 'Kwd "velocity";    pair = parse_pair;    e = parse_bnext ((`Velocity pair)::list)>] -> e
  | [< 'Kwd "radius";      'Float x;             e = parse_bnext ((`Radius x)::list)>] -> e
  | [< 'Kwd "color";       'String x;            e = parse_bnext ((`Color 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 *)
exception Wrong_type
exception Missing of string

let all_matches ~f list =
  let rec all_matches ~partial list = match list with
      [] -> partial 
    | hd::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
      with
	  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
      with
	  Wrong_type -> first_match_default ~f ~name ~default tl


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; 
      i = None
    }
  with 
      Missing name ->
	raise (Missing (sprintf "body: %s" name))


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_bodies = List.map ~f:build_body   (all_matches ~f:(function `Body bodies -> bodies | _ -> raise Wrong_type) sdesc);
    }
  with Missing name ->
    failwith (sprintf "Field missing from state description: %s" name)


(********************************************************************)
(********************************************************************)
(********************************************************************)

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)) 
    (string_of_float (snd pair))

let string_of_color color = match color with
    `Color string -> string
  | `Black -> "black"
  | `Blue -> "blue"
  | `Red -> "red"
  | `White -> "white"
  | `Green -> "green"
  | `Yellow -> "yellow"


let write_body out_c body =
  let indent = "   " in
    fprintf out_c "\nbody\n";
    fprintf out_c "%spos      %s\n" indent (string_of_pair body.pos);
    fprintf out_c "%svelocity %s\n" indent (string_of_pair body.velocity);
    fprintf out_c "%sradius   %s\n" indent (string_of_float body.radius);
    fprintf out_c "%smass     %s\n" indent (string_of_float body.mass);
    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 = 
  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);
  List.iter ~f:(write_body out_c) state.bodies;
  close_out out_c


(* Some final details: 
   choosing the save directory and the external interface *)

let is_dir fname = 
  let stats = Unix.stat fname in
    stats.Unix.st_kind = Unix.S_DIR

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 
      (* PROBLEM: is 0x1FF really the right mode? *)
      try Unix.mkdir pdir 0x1FF; pdir 
      with Unix.Unix_error (err,func,arg) -> ""
  with
      Not_found -> ""

(******************************************************************)

let write_state_file filename = write_state (open_out filename)
let read_state_file filename = 
  let dead_state = parse_state (open_in filename) in
  reanimate_dead_state dead_state

let saved_fname key = "uni." ^ key

let write_state key =
  let fname = Filename.concat save_directory (saved_fname key) in
  try
    write_state_file fname
  with
      Sys_error x -> 
	Common.debug_msg (sprintf "%s: failed to load file %s" x fname)

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)
  

(****************************************************************)

let help_fname = Filename.concat save_directory ".nohelp"
let help_start = not (Sys.file_exists help_fname)

let set_help_start x = match x with
    true -> if Sys.file_exists help_fname then Sys.remove help_fname
  | false -> 
      let file = open_out help_fname in
      close_out file