add ocaml-canvas version

.ocamlformat

@@ -1,51 +1,34 @@
-version=0.19.0
-align-cases=false
-align-constructors-decl=false
-align-variants-decl=false
+version=0.20.1
 assignment-operator=end-line
-break-before-in=fit-or-vertical
-break-cases=all
-break-collection-expressions=fit-or-vertical
+break-cases=fit
 break-fun-decl=wrap
 break-fun-sig=wrap
 break-infix=wrap
 break-infix-before-func=false
 break-separators=before
 break-sequences=true
-break-string-literals=auto
-break-struct=force
 cases-exp-indent=2
 cases-matching-exp-indent=normal
-disambiguate-non-breaking-match=false
 doc-comments=before
 doc-comments-padding=2
 doc-comments-tag-only=default
 dock-collection-brackets=false
 exp-grouping=preserve
-extension-indent=2
 field-space=loose
-function-indent=2
-function-indent-nested=never
-if-then-else=k-r
-indent-after-in=0
+if-then-else=compact
 indicate-multiline-delimiters=space
 indicate-nested-or-patterns=unsafe-no
 infix-precedence=indent
 leading-nested-match-parens=false
 let-and=sparse
-let-binding-indent=2
 let-binding-spacing=compact
 let-module=compact
 margin=80
-match-indent=0
-match-indent-nested=never
 max-indent=68
 module-item-spacing=sparse
-nested-match=wrap
 ocp-indent-compat=false
 parens-ite=false
 parens-tuple=always
-parens-tuple-patterns=multi-line-only
 parse-docstrings=true
 sequence-blank-line=preserve-one
 sequence-style=terminator
@@ -54,8 +37,6 @@ space-around-arrays=true
 space-around-lists=true
 space-around-records=true
 space-around-variants=true
-stritem-extension-indent=0
 type-decl=sparse
-type-decl-indent=2
 wrap-comments=false
 wrap-fun-args=true

src/dune

@@ -1,3 +1,13 @@
-(executable
+(library
  (name ray)
  (modules ray))
+
+(executable
+ (name ray_ppm)
+ (modules ray_ppm)
+ (libraries ray))
+
+(executable
+ (name ray_canvas)
+ (modules ray_canvas)
+ (libraries ocaml-canvas ray unix))

src/ray.ml

@@ -99,23 +99,17 @@ module R = struct
       (norm *. norm) -. (r *. r)
     in
     let delta = (b *. b) -. (4. *. a *. c) in
-    if delta <= 0. then
-      None
+    if delta <= 0. then None
     else
       let k2 = (~-.b -. sqrt delta) /. 2. in
-      if k2 <= 0. then
-        None
-      else
-        Some k2
+      if k2 <= 0. then None else Some k2
 
   let nearest_intersection objs v d =
     List.fold_left
       (fun (sphere, min_dist) obj ->
         match sphere_intersect obj.center obj.radius v d with
         | Some d when d < min_dist -> (Some obj, d)
-        | None
-        | Some _ ->
-          (sphere, min_dist) )
+        | None | Some _ -> (sphere, min_dist) )
       (None, Float.infinity) objs
 
   let compute_color o v n l =
@@ -152,8 +146,7 @@ module R = struct
             let x_point = V.add camera (V.times dist d) in
             let l = V.normalize (V.sub light x_point) in
             let _obstacle, dist_obst = nearest_intersection objs x_point l in
-            if dist_obst < V.norm (V.sub light x_point) then
-              background_color
+            if dist_obst < V.norm (V.sub light x_point) then background_color
             else
               let n = V.normalize (V.sub x_point obj.center) in
               compute_color obj camera n l
@@ -200,8 +193,7 @@ module R = struct
         while true do
           objs := input_line chan :: !objs
         done
-      with
-      | End_of_file -> ()
+      with End_of_file -> ()
     end;
     let objs = List.rev !objs in
     let objs = List.map (String.split_on_char ';') objs in
@@ -221,16 +213,3 @@ module R = struct
     let objs = List.map mk_obj objs in
     (w, h, xmin, xmax, ymin, ymax, camera, light, objs)
 end
-
-let () =
-  let in_file = Sys.argv.(1) in
-  let out_file = Filename.chop_extension in_file in
-  let out_file = Format.sprintf "%s.ppm" out_file in
-  Format.printf "loading scene...@.";
-  let w, h, xmin, xmax, ymin, ymax, camera, light, objs =
-    R.load_scene in_file
-  in
-  Format.printf "tracing scene...@.";
-  let img = R.trace w h xmin xmax ymin ymax camera light objs in
-  Format.printf "storing scene...@.";
-  I.out_file out_file img

src/ray_canvas.ml

@@ -0,0 +1,206 @@
+open Ray
+open OcamlCanvas
+
+module I = struct
+  type t =
+    { bytes : Bytes.t
+    ; w : Int.t
+    ; h : Int.t
+    }
+
+  type color = float * float * float
+
+  let mk width height =
+    Canvas.createFramed ~title:"Ray" ~x:100 ~y:100 ~width ~height
+
+  let set c x y (r, g, b) =
+    let r = int_of_float @@ (255. *. r) in
+    let g = int_of_float @@ (255. *. g) in
+    let b = int_of_float @@ (255. *. b) in
+    let color = Color.of_rgb r g b in
+    Canvas.setFillColor c color;
+    Canvas.setPixel c ~x ~y color
+end
+
+type o =
+  { center : V.t
+  ; radius : Float.t
+  ; ambiant : V.t
+  ; diffuse : V.t
+  ; specular : V.t
+  ; shininess : Float.t
+  ; reflection : Float.t
+  }
+
+module R = struct
+  let pixel_to_point w h xmin xmax ymin ymax px py =
+    ((px *. (xmax -. xmin) /. w) +. xmin, (py *. (ymax -. ymin) /. h) +. ymin)
+
+  let sphere_intersect c r o d =
+    let a = 1. in
+    let k = V.sub o c in
+    let b = 2. *. V.dot d k in
+    let c =
+      let norm = V.norm k in
+      (norm *. norm) -. (r *. r)
+    in
+    let delta = (b *. b) -. (4. *. a *. c) in
+    if delta <= 0. then None
+    else
+      let k2 = (~-.b -. sqrt delta) /. 2. in
+      if k2 <= 0. then None else Some k2
+
+  let nearest_intersection objs v d =
+    List.fold_left
+      (fun (sphere, min_dist) obj ->
+        match sphere_intersect obj.center obj.radius v d with
+        | Some d when d < min_dist -> (Some obj, d)
+        | None | Some _ -> (sphere, min_dist) )
+      (None, Float.infinity) objs
+
+  let compute_color o v n l =
+    V.add o.ambiant
+      (V.add
+         (V.times (V.dot l n) o.diffuse)
+         (V.times
+            (Float.pow (V.dot n (V.normalize (V.add l v))) (o.shininess /. 4.))
+            o.specular ) )
+
+  let trace img w h xmin xmax ymin ymax camera light objs =
+    let background_color = V.mk 0. 0. 0. in
+    for py = 0 to h - 1 do
+      let py = float_of_int py in
+      let h = float_of_int h in
+      for px = 0 to w - 1 do
+        let w = float_of_int w in
+        let px = float_of_int px in
+        let x, y = pixel_to_point w h xmin xmax ymin ymax px py in
+        let p = V.mk x y 0. in
+        let vp = V.sub p camera in
+        let d = V.normalize vp in
+
+        let obj, dist = nearest_intersection objs camera d in
+
+        let couleur =
+          match obj with
+          | None -> background_color
+          | Some obj ->
+            let x_point = V.add camera (V.times dist d) in
+            let l = V.normalize (V.sub light x_point) in
+            let _obstacle, dist_obst = nearest_intersection objs x_point l in
+            if dist_obst < V.norm (V.sub light x_point) then background_color
+            else
+              let n = V.normalize (V.sub x_point obj.center) in
+              compute_color obj camera n l
+        in
+
+        I.set img (int_of_float px)
+          (int_of_float @@ (h -. py -. 1.))
+          (couleur.x, couleur.y, couleur.z)
+      done
+    done
+
+  let read_vector s =
+    let fields = String.split_on_char ',' s in
+    if List.length fields <> 3 then
+      failwith @@ Format.sprintf "error while loading `%s`" s;
+    let fields = List.map String.trim fields in
+    match List.map float_of_string fields with
+    | [ x; y; z ] -> V.mk x y z
+    | _whatever -> failwith "read_vector"
+
+  let read_float s =
+    let s = String.trim s in
+    float_of_string s
+
+  let read_int s =
+    let s = String.trim s in
+    int_of_string s
+
+  let load_scene path =
+    let chan = open_in path in
+    let w = read_int @@ input_line chan in
+    let h = read_int @@ input_line chan in
+    let xmin = read_float @@ input_line chan in
+    let xmax = read_float @@ input_line chan in
+    let ymin = read_float @@ input_line chan in
+    let ymax = read_float @@ input_line chan in
+    let camera = read_vector @@ input_line chan in
+    let light = read_vector @@ input_line chan in
+    let _names = input_line chan in
+    let objs = ref [] in
+    begin
+      try
+        while true do
+          objs := input_line chan :: !objs
+        done
+      with End_of_file -> ()
+    end;
+    let objs = List.rev !objs in
+    let objs = List.map (String.split_on_char ';') objs in
+    let mk_obj = function
+      | [ center; radius; ambiant; diffuse; specular; shininess; reflection ] ->
+        let center = read_vector center in
+        let radius = read_float radius in
+        let ambiant = read_vector ambiant in
+        let diffuse = read_vector diffuse in
+        let specular = read_vector specular in
+        let shininess = min 100. (max 0. (read_float shininess)) in
+        let reflection = min 1. (max 0. (read_float reflection)) in
+        { center; radius; ambiant; diffuse; specular; shininess; reflection }
+      | _whatever -> failwith "mk_obj"
+    in
+
+    let objs = List.map mk_obj objs in
+    (w, h, xmin, xmax, ymin, ymax, camera, light, objs)
+end
+
+let () =
+  if Array.length Sys.argv <> 2 then begin
+    Format.eprintf "usage: %s <scene file>" Sys.argv.(0);
+    exit 1
+  end;
+  let in_file = Sys.argv.(1) in
+  Format.printf "loading scene...@\n";
+  let width, height, xmin, xmax, ymin, ymax, camera, light, objs =
+    R.load_scene in_file
+  in
+  Format.printf "initializing canvas...@\n";
+  Backend.(init default_options);
+  let img = I.mk width height in
+  Canvas.show img;
+
+  Format.printf "tracing scene...@\n";
+  let objs = ref objs in
+
+  Backend.run
+    (function
+      | KeyAction (_c, _time, key, _char, _flags, Down) ->
+        if key = Event.KeyEscape then Backend.stop ();
+        true
+      | Frame (_c, _time) ->
+        let objs' = !objs in
+        R.trace img width height xmin xmax ymin ymax camera light objs';
+        let objs' =
+          List.map
+            (fun o ->
+              { o with
+                center =
+                  V.add o.center
+                    (V.mk
+                       (Random.float 0.2 -. 0.1)
+                       (Random.float 0.2 -. 0.1)
+                       (Random.float 0.2 -. 0.1) )
+              ; ambiant =
+                  V.add o.ambiant
+                    (V.mk
+                       (Random.float 0.1 -. 0.05)
+                       (Random.float 0.1 -. 0.05)
+                       (Random.float 0.1 -. 0.05) )
+              } )
+            objs'
+        in
+        objs := objs';
+        true
+      | _ -> true )
+    (function () -> Printf.printf "Goodbye !\n")

src/ray_ppm.ml

@@ -0,0 +1,183 @@
+open Ray
+
+module I = struct
+  type t =
+    { bytes : Bytes.t
+    ; w : Int.t
+    ; h : Int.t
+    }
+
+  type color = float * float * float
+
+  let mk w h = { bytes = Bytes.create (3 * w * h); w; h }
+
+  let set img x y (r, g, b) =
+    List.iteri
+      (fun i c ->
+        Bytes.set img.bytes
+          ((3 * ((img.w * y) + x)) + i)
+          (Char.chr @@ int_of_float (255. *. min 1. (max 0. c))) )
+      [ r; g; b ]
+
+  let pp fmt img =
+    Format.fprintf fmt "P6@.%i %i %i@.%s" img.w img.h 255
+      (Bytes.to_string img.bytes)
+
+  let out_file f img =
+    let chan = open_out f in
+    let fmt = Format.formatter_of_out_channel chan in
+    pp fmt img;
+    Format.pp_print_flush fmt ();
+    close_out chan
+end
+
+module R = struct
+  type o =
+    { center : V.t
+    ; radius : Float.t
+    ; ambiant : V.t
+    ; diffuse : V.t
+    ; specular : V.t
+    ; shininess : Float.t
+    ; reflection : Float.t
+    }
+
+  let pixel_to_point w h xmin xmax ymin ymax px py =
+    ((px *. (xmax -. xmin) /. w) +. xmin, (py *. (ymax -. ymin) /. h) +. ymin)
+
+  let sphere_intersect c r o d =
+    let a = 1. in
+    let k = V.sub o c in
+    let b = 2. *. V.dot d k in
+    let c =
+      let norm = V.norm k in
+      (norm *. norm) -. (r *. r)
+    in
+    let delta = (b *. b) -. (4. *. a *. c) in
+    if delta <= 0. then None
+    else
+      let k2 = (~-.b -. sqrt delta) /. 2. in
+      if k2 <= 0. then None else Some k2
+
+  let nearest_intersection objs v d =
+    List.fold_left
+      (fun (sphere, min_dist) obj ->
+        match sphere_intersect obj.center obj.radius v d with
+        | Some d when d < min_dist -> (Some obj, d)
+        | None | Some _ -> (sphere, min_dist) )
+      (None, Float.infinity) objs
+
+  let compute_color o v n l =
+    V.add o.ambiant
+      (V.add
+         (V.times (V.dot l n) o.diffuse)
+         (V.times
+            (Float.pow
+               ((* TODO: abs ?*)
+                V.dot n (V.normalize (V.add l v)) )
+               (o.shininess /. 4.) )
+            o.specular ) )
+
+  let trace w h xmin xmax ymin ymax camera light objs =
+    let background_color = V.mk 0. 0. 0. in
+    let img = I.mk w h in
+    for py = 0 to h - 1 do
+      let py = float_of_int py in
+      let h = float_of_int h in
+      for px = 0 to w - 1 do
+        let w = float_of_int w in
+        let px = float_of_int px in
+        let x, y = pixel_to_point w h xmin xmax ymin ymax px py in
+        let p = V.mk x y 0. in
+        let vp = V.sub p camera in
+        let d = V.normalize vp in
+
+        let obj, dist = nearest_intersection objs camera d in
+
+        let couleur =
+          match obj with
+          | None -> background_color
+          | Some obj ->
+            let x_point = V.add camera (V.times dist d) in
+            let l = V.normalize (V.sub light x_point) in
+            let _obstacle, dist_obst = nearest_intersection objs x_point l in
+            if dist_obst < V.norm (V.sub light x_point) then background_color
+            else
+              let n = V.normalize (V.sub x_point obj.center) in
+              compute_color obj camera n l
+        in
+
+        I.set img (int_of_float px)
+          (int_of_float @@ (h -. py -. 1.))
+          (couleur.x, couleur.y, couleur.z)
+      done
+    done;
+    img
+
+  let read_vector s =
+    let fields = String.split_on_char ',' s in
+    if List.length fields <> 3 then
+      failwith @@ Format.sprintf "error while loading `%s`" s;
+    let fields = List.map String.trim fields in
+    match List.map float_of_string fields with
+    | [ x; y; z ] -> V.mk x y z
+    | _whatever -> failwith "read_vector"
+
+  let read_float s =
+    let s = String.trim s in
+    float_of_string s
+
+  let read_int s =
+    let s = String.trim s in
+    int_of_string s
+
+  let load_scene path =
+    let chan = open_in path in
+    let w = read_int @@ input_line chan in
+    let h = read_int @@ input_line chan in
+    let xmin = read_float @@ input_line chan in
+    let xmax = read_float @@ input_line chan in
+    let ymin = read_float @@ input_line chan in
+    let ymax = read_float @@ input_line chan in
+    let camera = read_vector @@ input_line chan in
+    let light = read_vector @@ input_line chan in
+    let _names = input_line chan in
+    let objs = ref [] in
+    begin
+      try
+        while true do
+          objs := input_line chan :: !objs
+        done
+      with End_of_file -> ()
+    end;
+    let objs = List.rev !objs in
+    let objs = List.map (String.split_on_char ';') objs in
+    let mk_obj = function
+      | [ center; radius; ambiant; diffuse; specular; shininess; reflection ] ->
+        let center = read_vector center in
+        let radius = read_float radius in
+        let ambiant = read_vector ambiant in
+        let diffuse = read_vector diffuse in
+        let specular = read_vector specular in
+        let shininess = min 100. (max 0. (read_float shininess)) in
+        let reflection = min 1. (max 0. (read_float reflection)) in
+        { center; radius; ambiant; diffuse; specular; shininess; reflection }
+      | _whatever -> failwith "mk_obj"
+    in
+
+    let objs = List.map mk_obj objs in
+    (w, h, xmin, xmax, ymin, ymax, camera, light, objs)
+end
+
+let () =
+  let in_file = Sys.argv.(1) in
+  let out_file = Filename.chop_extension in_file in
+  let out_file = Format.sprintf "%s.ppm" out_file in
+  Format.printf "loading scene...@.";
+  let w, h, xmin, xmax, ymin, ymax, camera, light, objs =
+    R.load_scene in_file
+  in
+  Format.printf "tracing scene...@.";
+  let img = R.trace w h xmin xmax ymin ymax camera light objs in
+  Format.printf "storing scene...@.";
+  I.out_file out_file img