Commits

Anonymous committed 3a89de9

proper dumping of a subset of json

Comments (0)

Files changed (2)

+(* a JSON parser using parsing combinators *)
+
+module StringMap = Map.Make(struct 
+			      type t = String.t 
+			      let compare = String.compare 
+			    end)
+type json = String of string | Int of int | Float of float
+	    | Dict of json StringMap.t | Array of json list
+	    | True | False | Null
+	    
+and jsonmap = (json * json) list
+
+let rec mergesort (cmp: 'a -> 'a -> int) (l: 'a list) : 'a list = []
+
+let rec json_compare (js1:json) (js2:json) : int =
+  let compare_maps = StringMap.compare json_compare in
+  let rec compare_lists l1 l2 =
+    match (l1,l2) with
+      | (hd1::rest1,hd2::rest2) -> (
+	  let cmp_result = json_compare hd1 hd2 in
+	    if cmp_result = 0 then compare_lists rest1 rest2 else cmp_result)
+      | ([],[]) -> 0
+      | _ -> (List.length l1) - (List.length l2)
+  in
+  let rank = function
+    | String _ -> 0
+    | Int _ -> 1
+    | Float _ -> 2
+    | Dict _ -> 3
+    | Array _ -> 4
+    | True _ -> 5
+    | False _ -> 6
+    | Null _ -> 7
+  in
+  match (js1,js2) with
+    | (String s1, String s2) -> String.compare s1 s2
+    | (Int i1, Int i2) -> i1 - i2
+    | (Float f1, Float f2) -> (
+	if f1 > f2 then 
+	  1
+	else (
+	  if f1 = f2 then 0 else -1))
+    | (Dict d1, Dict d2) -> compare_maps d1 d2
+    | (Array l1, Array l2) -> compare_lists l1 l2
+    | _ -> (rank js1) - (rank js2)
+
+let json_sort = mergesort json_compare
+
+exception Lookup_error of string
+
+let lookup (key:json) (value:json) =
+  match (key,value) with
+    | (Int i, Array l) -> List.nth l i
+    | (String s, Dict d) -> StringMap.find s d
+    | _ -> raise (Lookup_error "Invalid lookup type")
+
+let build_dict (pairs: (String.t * json) list) : json =
+  let add acc (k,v) = StringMap.add k v acc in
+    Dict (List.fold_left add StringMap.empty pairs)
+
+let dump (json:json) =
+  let rec down ret = function
+    | True -> "true"::ret
+    | False -> "false"::ret
+    | Null -> "null"::ret
+    | String s -> ("\"" ^ s ^ "\"")::ret
+    | Int i -> (string_of_int i)::ret
+    | Float f -> (string_of_float f)::ret
+    | Array l -> (
+	let rec loop ret = function
+	  | hd::[] -> "]"::(down ret hd)
+	  | hd::rest -> loop (", "::(down ret hd)) rest
+	  | [] -> ["]"]
+	in
+	  loop ("["::ret) l)
+    | Dict d -> (
+	let aggregate k v acc = (k,v)::acc in
+	let pairs = StringMap.fold aggregate d [] in
+	let rec loop ret = function
+	  | (k,v)::[] -> "}"::(down (": "::k::ret) v)
+	  | (k,v)::rest -> loop (", "::(down (": "::k::ret) v)) rest
+	  | [] -> ["}"]
+	in
+	  loop ("{"::ret) pairs)
+  in
+  let strs = down [] json in
+    String.concat "" (List.rev strs)
+    		 
+let lookup_test = 
+  let pairs = [("red",Int 0); ("green",Int 1);
+	       ("blue",Array [String "hello"; String "goodbye"])] in
+  let js = build_dict pairs in
+  let query = String "green" in
+  let result = lookup query js in
+    assert ((json_compare result (Int 1)) = 0);
+    print_endline (dump js)
+
 
 (* some convenient surfaces *)
 
-let surf_shiny_green = {surface_color=rgb_green; reflectance=0.5; albedo=1.0}
+let surf_shiny_green = {surface_color=rgb_green; reflectance=0.0; albedo=1.0}
 let surf_shiny_red = {surface_color=rgb_red; reflectance=0.5; albedo=0.5}
 let surf_shiny_blue = {surface_color=rgb_blue; reflectance=0.1; albedo=0.5}
 let surf_shiny_yellow = {surface_color=rgb_yellow;reflectance=0.9; albedo=0.5}
 	      (List.fold_left handle_light rgb_black lights))
 	  
 let render_scene (camera:camera) (shapes:shape list) (lights:light list)
-    (bg:color) (ambience:float) : color list =
+    (bg:color) (ambience:float) (max_depth:int) : color list =
   let rays = build_rays camera in
-  let f = render_ray 0 1 camera.origin shapes lights bg ambience in
+  let f = render_ray 0 max_depth camera.origin shapes lights bg ambience in
   let rec loop ret rem =
     match rem with
       | [] -> List.rev ret
 	      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
+let colors = render_scene camera shapes lights rgb_red 0.07 1
 let out = write_bitmap "rendered.bmp" camera colors
 
 let dtest =