Add SVG backend

.gitignore

@@ -1,4 +1,8 @@
 _build
 .vscode
 .DS_Store
-*.png
+*.png
+*.cmi
+*.cmx
+*.cma
+*.o

examples/circle_packing.ml

@@ -32,7 +32,7 @@ let palette =
   ]
 
 (* utility Functions *)
-let rand_nth coll = List.length coll |> random |> List.nth coll
+let rand_nth coll = List.length coll |> Joy.random |> List.nth coll
 let tmap f (a, b) = (f a, f b)
 
 (* Pareto distribution float random for radii *)

examples/dune

@@ -1,6 +1,8 @@
 (executable
  (name axes)
  (modules axes)
+ (modes js)
+ (preprocess (pps js_of_ocaml-ppx))
  (libraries joy))
 
 (executable

lib/backend_cairo.ml

@@ -1,109 +1,18 @@
-type context = {
-  cairo_ctx : Cairo.context;
-  surface : Cairo.Surface.t;
-  size : int * int;
-  background_color : int * int * int * float;
-  axes : bool;
-}
+type context = { dummy: string; size: int * int }
 
-let write ctx filename =
-  Cairo.PNG.write ctx.surface filename;
-  Cairo.Surface.finish ctx.surface
-
-let set_color ctx color =
-  let to_float i = float_of_int i /. 255. in
-  let r, g, b, a = color in
-  let r, g, b = Util.tmap3 to_float (r, g, b) in
-  Cairo.set_source_rgba ctx.cairo_ctx r g b a
-
-let set_background ctx color =
+let string_of_color color =
   let r, g, b, a = color in
-  let to_float i = float_of_int i /. 255. in
-  let r, g, b = Util.tmap3 to_float (r, g, b) in
-  Cairo.set_source_rgba ctx.cairo_ctx r g b a;
-  Cairo.paint ctx.cairo_ctx ~alpha:a;
-  Cairo.fill ctx.cairo_ctx
-
-(** Sets the width of lines for both stroke of shapes and line primitives. 
-    Can be any positive integer, with larger numbers producing thicker lines. *)
-let set_line_width ctx line_width =
-  Cairo.set_line_width ctx.cairo_ctx (float_of_int line_width)
-
-let draw_circle ctx (cx, cy) radius stroke fill =
-  Cairo.arc ctx.cairo_ctx cx (Float.neg cy) ~r:radius ~a1:0. ~a2:(Float.pi *. 2.);
-  set_color ctx stroke;
-  Cairo.stroke_preserve ctx.cairo_ctx;
-  set_color ctx fill;
-  Cairo.fill_preserve ctx.cairo_ctx;
-  Cairo.Path.clear ctx.cairo_ctx
-
-let draw_ellipse ctx (cx, cy) rx ry rotation stroke fill =
-  (* Save the current transformation matrix *)
-  let save_matrix = Cairo.get_matrix ctx.cairo_ctx in
-
-  (* Apply rotation *)
-  let radians = Util.to_radians rotation in
-  Cairo.rotate ctx.cairo_ctx radians;
-
-  (* Translate and scale to create an ellipse from a circle *)
-  Cairo.translate ctx.cairo_ctx cx (Float.neg cy);
-  Cairo.scale ctx.cairo_ctx rx ry;
-
-  (* Arc from 0 to 2pi is a circle *)
-  Cairo.arc ctx.cairo_ctx 0. 0. ~r:1. ~a1:0. ~a2:(2. *. Float.pi);
-
-  (* Restore the original transformation matrix *)
-  Cairo.set_matrix ctx.cairo_ctx save_matrix;
-
-  set_color ctx stroke;
-  Cairo.stroke_preserve ctx.cairo_ctx;
-  set_color ctx fill;
-  Cairo.fill_preserve ctx.cairo_ctx;
+  Printf.sprintf "(%d, %d, %d, %f)" r g b a
 
-  Cairo.Path.clear ctx.cairo_ctx
+let create ~background_color ~size ~line_width ~axes =
+  let s = Printf.sprintf "create: background_color=%s size=(%d, %d) line_width=%d axes=%b\n"
+    (string_of_color background_color) (fst size) (snd size) line_width axes in
+  { dummy = s; size = size }
 
-let draw_line ctx (x1, y1) (x2, y2) stroke =
-  set_color ctx stroke;
-  Cairo.move_to ctx.cairo_ctx x1 (Float.neg y1);
-  Cairo.line_to ctx.cairo_ctx x2 (Float.neg y2);
-  Cairo.stroke ctx.cairo_ctx
+let show _ctx _shapes = ()
 
-let draw_polygon ctx vertices stroke fill =
-  let x, y = List.hd vertices in
-  let t = List.tl vertices in
-  Cairo.move_to ctx.cairo_ctx x (Float.neg y);
-  List.iter (fun (x', y') -> Cairo.line_to ctx.cairo_ctx x' (Float.neg y')) t;
-  Cairo.Path.close ctx.cairo_ctx;
-  set_color ctx stroke;
-  Cairo.stroke_preserve ctx.cairo_ctx;
-  set_color ctx fill;
-  Cairo.fill ctx.cairo_ctx
+let set_line_width _ctx _line_width = ()
 
-let show ctx shapes =
-  let rec render = function
-    | Shape.Circle circle ->
-        draw_circle ctx (circle.c.x, circle.c.y) circle.radius circle.stroke
-          circle.fill
-    | Shape.Ellipse ellipse ->
-        draw_ellipse ctx (ellipse.c.x, ellipse.c.y) ellipse.rx ellipse.ry
-          ellipse.rotation ellipse.stroke ellipse.fill
-    | Shape.Line line ->
-        draw_line ctx (line.a.x, line.a.y) (line.b.x, line.b.y) line.stroke
-    | Shape.Polygon polygon ->
-        let to_tuple (point : float Shape.point) = (point.x, point.y) in
-        draw_polygon ctx
-          (List.map to_tuple polygon.vertices)
-          polygon.stroke polygon.fill
-    | Shape.Complex complex -> List.iter render complex
-  in
-  List.iter render shapes
+let write _ctx _filename = ()
 
-let create ~background_color ~line_width ~size ~axes =
-  let w, h = size in
-  let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w ~h in
-  let cairo_ctx = Cairo.create surface in
-  Cairo.translate cairo_ctx (w / 2 |> float_of_int) (h / 2 |> float_of_int);
-  let ctx = { cairo_ctx; surface; size = (w, h); background_color; axes } in
-  set_background ctx background_color;
-  set_line_width ctx line_width;
-  ctx
+let clear _ctx = ()

lib/backend_cairo.mli

@@ -1,20 +1,8 @@
-type context = {
-  cairo_ctx : Cairo.context;
-  surface : Cairo.Surface.t;
-  size : int * int;
-  background_color : Color.color;
-  axes : bool;
-}
+type context = { dummy: string; size: int * int }
 
-val set_color : context -> Color.color -> unit
-val set_background : context -> Color.color -> unit
+val create : background_color:int * int * int * float ->
+            size:int*int -> line_width:int -> axes:bool -> context
+val show : context -> Shape.shape list -> unit
 val set_line_width : context -> int -> unit
-val show : context -> Shape.shapes -> unit
 val write : context -> string -> unit
-
-val create :
-  background_color:Color.color ->
-  line_width:int ->
-  size:int * int ->
-  axes:bool ->
-  context
+val clear : context -> unit

lib/backend_lazy.ml

@@ -2,3 +2,4 @@ type context = unit
 
 let show _ctx _shapes = ()
 let create _ = ()
+let clear _ctx = ()

lib/backend_lazy.mli

@@ -2,3 +2,4 @@ type context = unit
 
 val show : context -> Shape.shapes -> unit
 val create : unit -> context
+val clear : context -> unit

lib/backend_svg.ml

@@ -1,4 +1,102 @@
-type context = unit
+open Js_of_ocaml
+
+type context = {
+  shapes: Shape.shape list ref;
+  size: int * int;
+  axes: bool;
+  elt: Dom_html.divElement Js.t;
+}
+
+let create ~size ~axes ~eltId =
+  let elt =
+    Js.Opt.get
+      (Js.Opt.bind
+        (Dom_html.document##getElementById (Js.string eltId))
+        Dom_html.CoerceTo.div)
+      (fun _ -> failwith "Could not find element with id")
+  in
+  {
+    shapes = ref [];
+    size;
+    axes;
+    elt;
+  }
+
+let string_of_color (r, g, b, a) =
+  Printf.sprintf "rgba(%d, %d, %d, %f)" r g b a
+
+let svg_coords_of_point (w, h) ({ x; y }: float Shape.point) =
+  ( x +. (float_of_int w) /. 2.0, (float_of_int h) /. 2.0 -. y )
+
+(* Helper function to convert color to SVG attribute *)
+let svg_color_attribute name color =
+  Printf.sprintf "%s=\"%s\"" name (string_of_color color)
+
+(* Helper function to convert point to a string *)
+let string_of_svg_coords (x, y) =
+  Printf.sprintf "%f,%f" x y
+
+(* Function to render a circle *)
+let render_circle ctx ({ c; radius; stroke; fill }: Shape.circle) =
+  let cx, cy = svg_coords_of_point ctx.size c in
+  Printf.sprintf "<circle cx=\"%f\" cy=\"%f\" r=\"%f\" %s %s />"
+    cx cy radius
+    (svg_color_attribute "stroke" stroke)
+    (svg_color_attribute "fill" fill)
+
+(* Function to render an ellipse *)
+let render_ellipse ctx ({ c; rx; ry; rotation; stroke; fill }: Shape.ellipse) =
+  let cx, cy = svg_coords_of_point ctx.size c in
+  Printf.sprintf "<ellipse cx=\"%f\" cy=\"%f\" rx=\"%f\" ry=\"%f\" transform=\"rotate(%d)\" %s %s />"
+    cx cy rx ry rotation
+    (svg_color_attribute "stroke" stroke)
+    (svg_color_attribute "fill" fill)
+
+(* Function to render a polygon *)
+let render_polygon ctx ({ vertices; stroke; fill }: Shape.polygon) =
+  let string_of_point ({ x; y }: float Shape.point) =
+    string_of_svg_coords (svg_coords_of_point ctx.size { x; y })
+  in
+  let points = String.concat " " (List.map string_of_point vertices) in
+  Printf.sprintf "<polygon points=\"%s\" %s %s />"
+    points
+    (svg_color_attribute "stroke" stroke)
+    (svg_color_attribute "fill" fill)
+
+(* Function to render a line *)
+let render_line ctx ({ a; b; stroke }: Shape.line) =
+  let ax, ay = svg_coords_of_point ctx.size a in
+  let bx, by = svg_coords_of_point ctx.size b in
+  Printf.sprintf "<line x1=\"%f\" y1=\"%f\" x2=\"%f\" y2=\"%f\" %s />"
+    ax ay bx by
+    (svg_color_attribute "stroke" stroke)
+
+(* Recursive function to render shapes *)
+let rec render_shape ctx s =
+  match s with
+  | Shape.Circle c -> render_circle ctx c
+  | Shape.Ellipse e -> render_ellipse ctx e
+  | Shape.Line l -> render_line ctx l
+  | Shape.Polygon p -> render_polygon ctx p
+  | Shape.Complex shapes -> String.concat "" (List.map (render_shape ctx) shapes)
+
+let make_svg ctx =
+  let shapes = !(ctx.shapes) in
+  let svg = String.concat "" (List.map (render_shape ctx) shapes) in
+  let (width, height) = ctx.size in
+  let svg = Printf.sprintf "<svg width=\"%d\" height=\"%d\" xmlns=\"http://www.w3.org/2000/svg\">%s</svg>" width height svg in
+  svg
+
+let write ctx =
+  let svg = make_svg ctx in
+  let elt = ctx.elt in
+  elt##.innerHTML := Js.string svg
+
+let show ctx shapes =
+  ctx.shapes := !(ctx.shapes) @ shapes;
+  write ctx
+
+let clear ctx =
+  ctx.shapes := [];
+  write ctx
 
-let show _ctx _shapes = ()
-let create _ = ()

lib/backend_svg.mli

@@ -1,4 +1,12 @@
-type context = unit
+type context = {
+  shapes: Shape.shape list ref;
+  size: int * int;
+  axes: bool;
+  elt: Js_of_ocaml.Dom_html.element Js_of_ocaml.Js.t;
+}
 
-val show : context -> Shape.shapes -> unit
-val create : unit -> context
+val show : context -> Shape.shape list -> unit
+val create : size:int * int -> axes:bool -> eltId:string -> context
+val make_svg : context -> string
+val write : context -> unit
+val clear : context -> unit

lib/context.ml

@@ -10,13 +10,20 @@ let default = ref (LazyContext (Backend_lazy.create ()))
 let get_default _ = !default
 let set_default ctx = default := ctx
 
-let show ?ctx shapes =
+let show ?ctx (shapes: Shape.shape list) =
   let ctx = match ctx with Some ctx -> ctx | None -> get_default () in
   match ctx with
   | CairoContext ctx -> Backend_cairo.show ctx shapes
   | SVGContext ctx -> Backend_svg.show ctx shapes
   | LazyContext ctx -> Backend_lazy.show ctx shapes
 
+let clear ?ctx _ =
+  let ctx = match ctx with Some ctx -> ctx | None -> get_default () in
+  match ctx with
+  | CairoContext ctx -> Backend_cairo.clear ctx
+  | SVGContext ctx -> Backend_svg.clear ctx
+  | LazyContext ctx -> Backend_lazy.clear ctx
+
 let set_line_width ?ctx int =
   let ctx = match ctx with Some ctx -> ctx | None -> get_default () in
   match ctx with
@@ -32,10 +39,18 @@ let writePNG ?ctx filename =
       raise (Unsupported_output_format "SVG context cannot render to PNG")
   | LazyContext _ -> failwith "Lazy.writePNG ctx filename"
 
-let writeSVG ?ctx =
+(* let writeSVG ?ctx _ =
+  let ctx = match ctx with Some ctx -> ctx | None -> get_default () in
+  match ctx with
+  | CairoContext _ ->
+      raise (Unsupported_output_format "Cairo context cannot render to SVG")
+  | SVGContext ctx -> Backend_svg.write ctx
+  | LazyContext _ -> failwith "Lazy.writeSVG ctx" *)
+
+let makeSVG ?ctx _ =
   let ctx = match ctx with Some ctx -> ctx | None -> get_default () in
   match ctx with
   | CairoContext _ ->
       raise (Unsupported_output_format "Cairo context cannot render to SVG")
-  | SVGContext _ -> failwith "SVG.writeSVG ctx"
-  | LazyContext _ -> failwith "Lazy.writeSVG ctx"
+  | SVGContext ctx -> Backend_svg.make_svg ctx
+  | LazyContext _ -> failwith "Lazy.makeSVG ctx"

lib/context.mli

@@ -8,7 +8,9 @@ exception Unsupported_output_format of string
 
 val get_default : unit -> context
 val set_default : context -> unit
-val show : ?ctx:context -> Shape.shapes -> unit
+val show : ?ctx:context -> Shape.shape list -> unit
+val clear : ?ctx:context -> unit -> unit
 val set_line_width : ?ctx:context -> int -> unit
-val writeSVG : ?ctx:context -> string
+
+val makeSVG : ?ctx:context -> unit -> string
 val writePNG : ?ctx:context -> string -> unit

lib/dune

@@ -1,4 +1,5 @@
 (library
  (name joy)
  (public_name joy)
- (libraries cairo2))
+ (preprocess (pps js_of_ocaml-ppx))
+ (libraries js_of_ocaml))