Anonymous avatar Anonymous committed bc35dca

added parsing of scenes from json, and improved json parsing

Comments (0)

Files changed (3)

 
 module type Json_t =
 sig
-  type json
+  type 'a smap
+  type json = String of string | Int of int | Float of float
+	    | Dict of json smap | Array of json list
+	    | True | False | Null
   val dumps : json -> String.t
   (*val dump : json -> out_channel*)
   val loads : String.t -> json
   val force_string : json -> string
   val force_float : json -> float
   val force_bool : json -> bool
+  val force_array : json -> json list
   exception Lookup_error of string
 end
 
 			      type t = String.t 
 			      let compare = String.compare 
 			    end)
+type 'a smap = 'a StringMap.t
 type json = String of string | Int of int | Float of float
-	    | Dict of json StringMap.t | Array of json list
+	    | Dict of json smap | Array of json list
 	    | True | False | Null
 
 exception Lookup_error of string
   | _ -> raise Json_type_error
 let force_bool = function True -> true | False -> false
   | _ -> raise Json_type_error
+let force_array = function Array a -> a | _ -> raise Json_type_error
 
 let rec mergesort (cmp: 'a -> 'a -> int) (l: 'a list) : 'a list = []
 
     		 
 (* parsing combinators *)
 
-type 'a parse_result = Failure | Success of 'a * (char list)
+type 'a parse_result = Failure of string list | Success of 'a * (char list)
 type 'a parse_fun = char list -> 'a parse_result
 
 (* parsing utils *)
 
 let assert_success (pr:'a parse_result) : unit =
   match pr with
-    | Failure -> assert false
+    | Failure _ -> assert false
     | Success _ -> ()
 
 (* primitive combinators *)
 let parse_pred (fn: char -> bool) : char parse_fun =
   let parse (cs:char list) : char parse_result =
     match cs with
-      | hd::rest -> if fn hd then Success (hd,rest) else Failure
-      | _ -> Failure
+      | hd::rest -> if fn hd then Success (hd,rest) else Failure ["parse_pred"]
+      | _ -> Failure ["parse_pred"]
   in
     parse
 
 let parse_compose (fn: 'a -> 'b) (p: 'a parse_fun) : 'b parse_fun =
   let parse cs =
     match p cs with
-      | Failure -> Failure
+      | Failure stack -> Failure ("parse_compose"::stack)
       | Success (result,rest) -> Success (fn result,rest)
   in
     parse
       | [] -> Success (List.rev ret, rem_cs)
       | p::rest -> (
 	    match p rem_cs with
-	      | Failure -> Failure
+	      | Failure stack -> Failure ("parse_all"::stack)
 	      | Success (result,rest_cs) -> down (result::ret) rest_cs rest)
     in
       down [] cs ps
 let parse_first (ps:'a parse_fun list) : 'a parse_fun =
   let parse (cs:char list) : 'a parse_result =
     let rec down = function
-      | [] -> Failure
+      | [] -> Failure ["parse_first"]
       | p::rest -> (
 	  let result = p cs in
 	  match result with
-	    | Failure -> down rest
+	    | Failure stack -> down rest
 	    | Success _ -> result)
     in
       down ps
 let parse_map (f:'a -> 'b) (p: 'a list parse_fun) : 'b list parse_fun =
   let parse (cs:char list) =
     match p cs with
-      | Failure -> Failure
+      | Failure stack -> Failure ("parse_map"::stack)
       | Success (result,rest) -> Success (List.map f result, rest)
   in
     parse
 let parse_combine (ps: 'a list parse_fun list) : 'a list parse_fun =
   let parse cs =
     match parse_all ps cs with
-      | Failure -> Failure
+      | Failure stack -> Failure ("parse_combine"::stack)
       | Success (results,rest) -> Success (List.flatten results, rest)
   in
     parse
   let parse (cs:char list) : 'a list parse_result =
     let rec down ret rem_cs =
       match p rem_cs with
-	| Failure -> Success (List.rev ret, rem_cs)
+	| Failure _ -> Success (List.rev ret, rem_cs)
 	| Success (result,rest) -> down (result::ret) rest
     in
       down [] cs
   let parse cs =
     let result = p cs in
     match result with
-      | Failure -> Success ([],cs)
+      | Failure _ -> Success ([],cs)
       | Success (result,rest) -> Success ([result],rest)
   in
     parse
   parse_any_char ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9']
 
 let parse_int =
-  parse_compose (compose int_of_string implode) (parse_plus parse_digit)
+  let intify = parse_compose (compose int_of_string implode) in
+  let neg = parse_optional (parse_char '-') in
+    intify (parse_combine [neg; parse_plus parse_digit])
 
 let parse_float =
   let dot = parse_compose listify (parse_char '.') in
+  let neg = parse_optional (parse_char '-') in
+  let parse_whole = parse_plus parse_digit in
   parse_compose (compose float_of_string implode) (
-    parse_combine [parse_plus parse_digit; dot; parse_kleene_star parse_digit])
+    parse_combine [neg; parse_whole; dot; parse_kleene_star parse_digit])
 						     
 let parse_word w = parse_all (List.map parse_char (explode w))
 
+let parse_ignore p =
+  parse_compose (fun x -> []) p
+
 let parse_wc = 
   let wc = parse_any_char (explode " \t\r\n") in
-    parse_compose (fun x -> []) (parse_kleene_star wc)
-
-let parse_ignore p =
-  parse_compose (fun x -> []) p
+    parse_ignore (parse_kleene_star wc)
 
 let parse_json_true = parse_compose (fun x -> True) (parse_word "true")
 let parse_json_false = parse_compose (fun x -> False) (parse_word "false")
       parse_optional p;
       parse_ignore (parse_char last)]
 
-let rec parse_json_list cs = 
+let rec parse_json_array cs = 
   let l = parse_delimited '[' ']' ',' parse_json in
     parse_compose (fun l -> Array l) l cs
-and parse_json_array cs =
+and parse_json_object cs =
   let extract_pair p =
     let k = 
       match List.nth p 0 with
   let parse_pair = 
     parse_compose extract_pair (
       parse_combine [
+	parse_wc;
 	parse_compose listify parse_json_string;
-	parse_ignore parse_wc;
+	parse_wc;
 	parse_ignore (parse_char ':');
-	parse_ignore parse_wc;
+(*	parse_ignore parse_wc;*)
 	parse_compose listify parse_json])
   in
     parse_compose build_dict (parse_delimited '{' '}' ',' parse_pair) cs
-and parse_json cs : json parse_result =
+and parse_json cs : json parse_result = 
   parse_compose (fun x -> List.nth x 0)
     (parse_combine [parse_wc; parse_compose listify (parse_first [
 		   parse_json_true;
 		   parse_json_string;
 		   parse_json_float;
 		   parse_json_int;
-		   parse_json_list;
-		   parse_json_array]); parse_wc]) cs
+		   parse_json_array;
+		   parse_json_object]); parse_wc]) cs
 
 let quick_print (pr:'a parse_result) : unit =
   print_endline (match pr with
-		   | Failure -> "Failure"
+		   | Failure stack -> "Failure: " ^ (String.concat " - " stack)
 		   | Success _ -> "Success")
 
 let parse_test = 
   let string_result = parse_string (explode s) in
   let int_result = parse_int (explode "100") in
     (match string_result with
-      | Failure -> assert false
+      | Failure _ -> assert false
       | Success (result,rest) -> assert (String.compare result "hello" = 0));
     (match int_result with
-       | Failure -> assert false
+       | Failure _ -> assert false
        | Success (result,rest) -> assert (result = 100))
 
 exception Json_parse_error
 
 let loads (s:string) : json =
   match parse_json (explode s) with
-    | Failure -> raise Json_parse_error
+    | Failure stack -> (
+	print_endline ("Parse failure!\n" ^ (String.concat "\n" stack));
+	raise Json_parse_error)
     | Success (result,rest) -> (
 	match rest with
 	  | [] -> result
 (*
 let parse_test =
   let s = 
-    "[true,false,null,\"hello\", 1   , 
-     2.05 ,  {\"abc\":[1,2,[3 ]  ]}]   "
+    "{\"bg\":true, \"arr\":[true,false,null,\"hello\", 1   , 
+     2.05 ,  {\"abc\":[1,2,[3 ]  ]}]   }"
   in
+  (*let s = "{\"abc\":true, \"def\":false}" in*)
     print_endline (dumps (loads s))
 
 let lookup_test = 
 (* ray.ml: a simple raytracer *)
 
+include Json
+
 type vector3 = float * float * float
 type color = int * int * int
 type normal = Normal of vector3
 
 (* parsing objects from JSON *)
 
-(*let parse_sphere_js (js:Json.json) : shape =*)
+let extract_triple (f: Json.json -> 'a) : Json.json -> 'a * 'a * 'a =
+  let lookup (js:Json.json) =
+    let lu i = f (Json.lookup (Json.Int i) js) in
+      (lu 0, lu 1, lu 2)
+  in
+    lookup
+
+let extract_color = extract_triple Json.force_int
+
+let extract_v3 = extract_triple Json.force_float
+
+let str_lookup (js:Json.json) (s:string) : Json.json =
+  Json.lookup (Json.String s) js
+
+let parse_surface_js (js:Json.json) : surface = 
+  let lu = str_lookup js in
+  let surface_color = extract_color (lu "surface_color") in
+  let reflectance = Json.force_float (lu "reflectance") in
+  let albedo = Json.force_float (lu "albedo") in
+    {surface_color=surface_color; reflectance=reflectance; albedo=albedo}
+
+let parse_sphere_js (js:Json.json) : shape =
+  let lu = str_lookup js in
+  let center = extract_v3 (lu "center") in
+  let radius = Json.force_float (lu "radius") in
+  let id = Json.force_int (lu "sph_id") in
+  let surface = parse_surface_js (lu "sph_surf") in
+    Sphere {center=center; radius=radius; sph_surf=surface; sph_id=id}
+
+let parse_plane_js (js:Json.json) : shape = 
+  let lu = str_lookup js in
+  let plane_normal = v3_norm (extract_v3 (lu "plane_normal")) in
+  let offset = Json.force_float (lu "offset") in
+  let plane_surf = parse_surface_js (lu "plane_surf") in
+  let plane_id = Json.force_int (lu "plane_id") in
+    Plane {plane_normal=plane_normal; offset=offset; plane_surf=plane_surf;
+	   plane_id=plane_id}
+
+exception Unknown_shape of string
+
+let parse_shape_js (js:Json.json) : shape =
+  let lu = str_lookup js in 
+  let name = Json.force_string (lu "name") in
+  let fields = lu "fields" in
+    match name with
+      | "sphere" -> parse_sphere_js fields
+      | "plane" -> parse_plane_js fields
+      | _ -> raise (Unknown_shape name)
+
+let parse_light_js (js:Json.json) : light =
+  let lu = str_lookup js in
+  let light_center = extract_v3 (lu "light_center") in
+  let light_color = extract_color (lu "light_color") in
+    {light_center=light_center; light_color=light_color}
+
+let parse_camera_js (js:Json.json) : camera =
+  let lu = str_lookup js in
+  let origin = extract_v3 (lu "origin") in
+  let out = v3_norm (extract_v3 (lu "out")) in
+  let up = v3_norm (extract_v3 (lu "up")) in
+  let width = Json.force_int (lu "width") in
+  let height = Json.force_int (lu "height") in
+  let xangle = Json.force_float (lu "xangle") in
+  let yangle = Json.force_float (lu "yangle") in
+    {origin=origin; out=out; up=up; width=width; height=height;
+     xangle=xangle; yangle=yangle}
+
+let parse_scene (js:Json.json) : (camera * (shape list) * (light list)
+				  * color * float * int) =
+  let lu = str_lookup js in
+  let lights = List.map parse_light_js (Json.force_array (lu "lights")) in
+  let shapes = List.map parse_shape_js (Json.force_array (lu "shapes")) in
+  let camera = parse_camera_js (lu "camera") in
+  let bg = extract_color (lu "bg") in
+  let ambience = Json.force_float (lu "ambience") in
+  let bounces = Json.force_int (lu "bounces") in
+    (camera, shapes, lights, bg, ambience, bounces)
   
 
 let shapes = [Sphere {center=(10.0,0.0,0.0); radius=2.0;
 	      up=v3_norm (0.0,1.0,0.0); width=1024; height=768;
 	      xangle=2.0; yangle=1.5}
 
-let colors = render_scene camera shapes lights rgb_red 0.07 1
-let out = write_bitmap "rendered.bmp" camera colors
+(*let colors = render_scene camera shapes lights rgb_red 0.07 1
+let out = write_bitmap "rendered.bmp" camera colors*)
+
+let load_and_render_scene (fname:string) (out:string) : unit =
+  let npt = open_in fname in
+  let buflen = (in_channel_length npt) in
+  let buf = String.make buflen ' ' in
+  let n_read = input npt buf 0 buflen in
+    assert (n_read = buflen);
+  let js = Json.loads buf in
+  let (camera,shapes,lights,bg,ambience,bounces) = parse_scene js in
+  let colors = render_scene camera shapes lights bg ambience bounces in
+    write_bitmap out camera colors
 
 let dtest =
   assert (fabs ((v3_l2dist (3.0, 0.0, 0.0) (0.0, 4.0, 0.0)) -. 5.0) < 0.00001)
 
+let main = 
+  if Array.length Sys.argv != 3 then (
+    print_endline "wrong number of arguments")
+  else (
+    let fname = Sys.argv.(1) in
+    let out = Sys.argv.(2) in
+      load_and_render_scene fname out)
+{"bg":[255,0,0],
+ "ambience":0.075,
+ "bounces":1,
+ "camera": {
+ 	   "origin":[0,0,0],
+	   "out":[1.0,0,0],
+	   "up":[0.0,1.0,0],
+	   "width":1024,
+	   "height":768,
+	   "xangle":2.0,
+	   "yangle":1.5},
+ "lights": [{"light_color":[255,50,50], "light_center":[4.0,6.0,0.0]},
+            {"light_color":[100,255,100],"light_center":[0.0, 0.0, -3.0]}],
+ "shapes": [{"name":"sphere","fields":{
+		"center":[10.0,1.0,-2.0],
+		"radius":2.5,
+ 	   	"sph_id":1, 
+		"sph_surf":{"surface_color":[25,255,0],
+			    "reflectance":0.0,
+  			    "albedo":1.0}}},
+	    {"name":"sphere","fields":{
+		"center":[6.0,2.25,1.25],
+		"radius":0.75,
+		"sph_id":2,
+		"sph_surf":{"surface_color":[255,255,10],
+			    "reflectance":1.0,
+			    "albedo":0.0}}},
+	    {"name":"plane","fields":{
+		"plane_normal":[-1.0, 0.0, -1.0],
+		"offset":15,
+		"plane_id":3,
+		"plane_surf":{"surface_color":[125,125,255],
+			      "reflectance":0.0,
+			      "albedo":1.0}}},
+	    {"name":"plane","fields":{
+		"plane_normal":[-1.0,0.0,1.0],
+		"offset":15,
+		"plane_id":4,
+		"plane_surf":{"surface_color":[200,200,20],
+			      "reflectance":0.0,
+			      "albedo":0.2}}},
+	   {"name":"sphere","fields":{
+		"center":[9.0,-3.0,-6.0],
+		"radius":0.75,
+		"sph_id":5,
+		"sph_surf":{"surface_color":[255,255,255],
+			    "reflectance":1.0,
+			    "albedo":1.0}}},
+	   {"name":"plane","fields":{
+		"plane_normal":[-0.5,1.0,0.0],
+		"offset":10.0,
+		"plane_id":6,
+		"plane_surf":{"surface_color":[50,50,50],
+			      "reflectance":0.25,
+			      "albedo":1.0}}}]
+}
+	   
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.