From e80b4a3fabdf0a9f3b2654259b74f06cd434f1b1 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Wed, 7 Feb 2024 11:47:13 -0500 Subject: [PATCH 1/5] canvas backend and module system in place - testing needed --- .ocamlformat | 2 +- examples/axes.ml | 4 +- examples/circle.ml | 4 +- examples/circle_packing.ml | 4 +- examples/circle_row_joy.ml | 2 +- examples/complex.ml | 2 +- examples/concentric_circles.ml | 4 +- examples/donut_with_scale.ml | 2 +- examples/ellipse.ml | 4 +- examples/higher_transforms.ml | 4 +- examples/line.ml | 2 +- examples/polygon.ml | 4 +- examples/rectangle.ml | 4 +- examples/rectangle_canvas.ml | 2 +- examples/repeat.ml | 4 +- examples/rotate.ml | 2 +- examples/square.ml | 5 +- examples/star.ml | 4 +- examples/translate_circle.ml | 2 +- examples/translate_ellipse.ml | 2 +- examples/translate_rectangle.ml | 2 +- examples/triangle.ml | 4 +- lib/canvas.ml | 217 ++++++++++++++++++++++++++++++++ lib/canvas.mli | 1 + lib/context.ml | 67 ---------- lib/context.mli | 20 --- lib/dune | 4 +- lib/joy.ml | 38 +----- lib/joy.mli | 26 ---- lib/modules.ml | 62 +++++++++ lib/render.ml | 117 ----------------- lib/render.mli | 8 -- lib/svg.ml | 185 +++++++++++++++++++++++++++ lib/svg.mli | 1 + lib/transform.ml | 2 +- lib/transform.mli | 2 +- test/test_circle.ml | 2 +- test/test_ellipse.ml | 2 +- test/test_rectangle.ml | 2 +- test/test_scale_shape.ml | 2 +- 40 files changed, 511 insertions(+), 316 deletions(-) create mode 100644 lib/canvas.ml create mode 100644 lib/canvas.mli delete mode 100644 lib/context.ml delete mode 100644 lib/context.mli delete mode 100644 lib/joy.mli create mode 100644 lib/modules.ml delete mode 100644 lib/render.ml delete mode 100644 lib/render.mli create mode 100644 lib/svg.ml create mode 100644 lib/svg.mli diff --git a/.ocamlformat b/.ocamlformat index 7df62da..0b240ee 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,2 +1,2 @@ profile = default -version = 0.26.1 \ No newline at end of file +version = 0.26.0 \ No newline at end of file diff --git a/examples/axes.ml b/examples/axes.ml index b59f718..2f7c461 100644 --- a/examples/axes.ml +++ b/examples/axes.ml @@ -1,6 +1,6 @@ (* simple example demonstrating drawing x and y axes for debugging or plots *) -open Joy +open Joy.Svg let _ = (* intialize rendering context with the axes flag set to true *) @@ -9,6 +9,6 @@ let _ = background (255, 255, 255, 255); let c = circle 50 in set_color (0, 0, 0); - render c; + show [c]; (* Write to PNG! *) write ~filename:"axes.png" () diff --git a/examples/circle.ml b/examples/circle.ml index adb20e3..dfd69ba 100644 --- a/examples/circle.ml +++ b/examples/circle.ml @@ -1,9 +1,9 @@ -open Joy +open Joy.Svg let () = init (); background (255, 255, 255, 255); let c = circle 50 in set_color (0, 0, 0); - render c; + show [ c ]; write ~filename:"circle.png" () diff --git a/examples/circle_packing.ml b/examples/circle_packing.ml index 5deff7a..b2aca53 100644 --- a/examples/circle_packing.ml +++ b/examples/circle_packing.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg (* global constants // RNG initialization *) let w, h = (900., 900.) @@ -79,7 +79,7 @@ let pack_circles () = let draw_with_color circle = let idx = Stdlib.Random.full_int (List.length palette - 1) in set_color (List.nth palette idx); - render circle + show [ circle ] (* turns a circle into a list of concentric circles *) let make_concentric circle = diff --git a/examples/circle_row_joy.ml b/examples/circle_row_joy.ml index 891037c..de00290 100644 --- a/examples/circle_row_joy.ml +++ b/examples/circle_row_joy.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init (); diff --git a/examples/complex.ml b/examples/complex.ml index 1e26925..52914ee 100644 --- a/examples/complex.ml +++ b/examples/complex.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg (* Complex shapes can also be created from lists of shapes. diff --git a/examples/concentric_circles.ml b/examples/concentric_circles.ml index fda373c..052eeb2 100644 --- a/examples/concentric_circles.ml +++ b/examples/concentric_circles.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init (); @@ -15,5 +15,5 @@ let () = in let circles = complex (make_concentric [] 21) in set_color (0, 0, 0); - render circles; + show [ circles ]; write ~filename:"concentric_circles.png" () diff --git a/examples/donut_with_scale.ml b/examples/donut_with_scale.ml index 3cc0f03..5ce4ae4 100644 --- a/examples/donut_with_scale.ml +++ b/examples/donut_with_scale.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init (); diff --git a/examples/ellipse.ml b/examples/ellipse.ml index de47d44..7683b7b 100644 --- a/examples/ellipse.ml +++ b/examples/ellipse.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init (); @@ -7,5 +7,5 @@ let () = let e = ellipse 100 75 in (* render it *) set_color (0, 0, 0); - render e; + show [ e ]; write ~filename:"ellipse.png" () diff --git a/examples/higher_transforms.ml b/examples/higher_transforms.ml index 4e7e3a2..9e9b551 100644 --- a/examples/higher_transforms.ml +++ b/examples/higher_transforms.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg (* Higher order transformations can be composed with `comp`, which applies its function args right-to-left. @@ -12,5 +12,5 @@ let () = let initial = rectangle ~c:(point (-250) (-250)) 100 100 in let shapes = repeat 32 transform initial in set_color (0, 0, 0); - render shapes; + show [ shapes ]; write ~filename:"higher_transforms.png" () diff --git a/examples/line.ml b/examples/line.ml index 40a0d57..8434271 100644 --- a/examples/line.ml +++ b/examples/line.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let size = 800 let interval = 16 diff --git a/examples/polygon.ml b/examples/polygon.ml index 4edf65f..1dbec91 100644 --- a/examples/polygon.ml +++ b/examples/polygon.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let size = 100. @@ -10,5 +10,5 @@ let () = [ { x = -.size; y = 0. }; { x = 0.; y = size }; { x = size; y = 0. } ] in set_color (0, 0, 0); - render poly; + show [ poly ]; write ~filename:"polygon.png" () diff --git a/examples/rectangle.ml b/examples/rectangle.ml index 282a2b4..e44e8d3 100644 --- a/examples/rectangle.ml +++ b/examples/rectangle.ml @@ -1,9 +1,9 @@ -open Joy +open Joy.Svg let () = init (); background (255, 255, 255, 255); set_color (0, 0, 0); let r = rectangle 100 200 in - show [r]; + show [ r ]; write ~filename:"rectangle.png" () diff --git a/examples/rectangle_canvas.ml b/examples/rectangle_canvas.ml index e9ad105..12da3f6 100644 --- a/examples/rectangle_canvas.ml +++ b/examples/rectangle_canvas.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init ~size:(500, 300) (); diff --git a/examples/repeat.ml b/examples/repeat.ml index 074a52f..d3634a5 100644 --- a/examples/repeat.ml +++ b/examples/repeat.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg (* demonstration of the repeat function @@ -14,5 +14,5 @@ let () = let circle = circle ~c:(point (-100) 0) 50 in let shapes = repeat 10 (translate 10 0) circle in set_color (0, 0, 0); - render shapes; + show [ shapes ]; write ~filename:"repeat.png" () diff --git a/examples/rotate.ml b/examples/rotate.ml index 81e68fc..305f27f 100644 --- a/examples/rotate.ml +++ b/examples/rotate.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let max = 32. let rec range a b = if a > b then [] else a :: range (a +. 1.) b diff --git a/examples/square.ml b/examples/square.ml index d367be0..974bd64 100644 --- a/examples/square.ml +++ b/examples/square.ml @@ -1,10 +1,9 @@ -open Joy +open Joy.Svg let () = init (); background (255, 255, 255, 255); let square = rectangle 100 100 in set_color (0, 0, 0); - show [square]; + show [ square ]; write ~filename:"square.png" () - diff --git a/examples/star.ml b/examples/star.ml index a58b92d..5a8e14c 100644 --- a/examples/star.ml +++ b/examples/star.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let outer_radius = 200. let inner_radius = 80. @@ -20,5 +20,5 @@ let () = set_line_width 3; let star = List.init points star_section |> List.flatten |> polygon in set_color (0, 0, 0); - render star; + show [ star ]; write ~filename:"star.png" () diff --git a/examples/translate_circle.ml b/examples/translate_circle.ml index e1faaa1..6fc5d3d 100644 --- a/examples/translate_circle.ml +++ b/examples/translate_circle.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init (); diff --git a/examples/translate_ellipse.ml b/examples/translate_ellipse.ml index 7c9c738..212071f 100644 --- a/examples/translate_ellipse.ml +++ b/examples/translate_ellipse.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init (); diff --git a/examples/translate_rectangle.ml b/examples/translate_rectangle.ml index 4d0bc42..cf05ffc 100644 --- a/examples/translate_rectangle.ml +++ b/examples/translate_rectangle.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let () = init (); diff --git a/examples/triangle.ml b/examples/triangle.ml index 91d7e26..2e1da4d 100644 --- a/examples/triangle.ml +++ b/examples/triangle.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let size = 100. @@ -11,5 +11,5 @@ let () = [ { x = -.size; y = 0. }; { x = 0.; y = size }; { x = size; y = 0. } ] in set_color (0, 0, 0); - render triangle; + show [ triangle ]; write ~filename:"triangle.png" () diff --git a/lib/canvas.ml b/lib/canvas.ml new file mode 100644 index 0000000..8225376 --- /dev/null +++ b/lib/canvas.ml @@ -0,0 +1,217 @@ +module Html = Js_of_ocaml.Dom_html +module Dom = Js_of_ocaml.Dom +module Js = Js_of_ocaml.Js + +(* JS type conversion helpers *) +let str = Js.string +let bl = Js.bool + +(* aliases for globals *) +let doc = Html.document + +(* Needed for 'write'/image save*) +let _window = Html.window + +module Canvas : Modules.Backend = struct + type context = { + context : Html.canvasRenderingContext2D Js.t; + size : int * int; + axes : bool; + } + + let context : context option ref = ref None + + exception Context of string + + (* Not working, could use help fixing *) + let () = + Printexc.register_printer (fun e -> + match e with Context err -> Some ("Context: " ^ err) | _ -> None) + + let fail () = raise (Context "not initialized") + + let create_canvas size = + let w, h = size in + let canvas = Html.createCanvas doc in + canvas##.width := w; + canvas##.height := h; + canvas + + let init_context line_width size axes = + let canvas = create_canvas size in + if Option.is_some !context then + raise (Context "cannot iniitialize context twice") + else ( + Dom.appendChild doc##.body canvas; + let ctx = canvas##getContext Html._2d_ in + ctx##.lineWidth := line_width; + context := Some { context = ctx; axes; size }) + + (* Sets global color *) + let set_color color = + match !context with + | Some { context; _ } -> + let r, g, b = color in + let color_string = Printf.sprintf "rgb(%d, %d, %d)" r g b |> str in + context##.fillStyle := color_string; + context##.strokeStyle := color_string + | None -> fail () + + let begin_path ctx = ctx##beginPath + let close_path ctx = ctx##closePath + + (* sets background color *) + let background color = + let rgba (r, g, b, a) = + str (Printf.sprintf "rgba(%d, %d, %d, %d)" r g b a) + in + match !context with + | Some ({ context; _ } as ctx) -> + let col = rgba color in + let w, h = ctx.size in + begin_path context; + context##.fillStyle := col; + context##fillRect 0. 0. (float_of_int w) (float_of_int h) + | None -> fail () + + (* Accessor functions for 'context' *) + + (** Returns 'axes' field of context *) + let axes ctx = ctx.axes + + (** Returns 'size' field of context *) + let resolution () = + match !context with Some ctx -> ctx.size | None -> fail () + + let set_line_width lw = + match !context with + | Some { context = ctx; _ } -> ctx##.lineWidth := float_of_int lw /. 1000. + | None -> fail () + + (** TODO: writ this fn, blob API + coercion in JSOO is tough, not sure where + all the methods etc I need are *) + let write _ctx _filename = + let _save_image _filename _blob = + (* Create anchor element, bind download fn to anchor, + and then programmatically click anchor to download png *) + () + in + (* Coerce canvas to blob, bind callback *) + () + + let save () = + match !context with + | Some { context = ctx; _ } -> ctx##save + | None -> fail () + + let restore () = + match !context with + | Some { context = ctx; _ } -> ctx##restore + | None -> fail () + + open Shape + + let draw_circle ctx { c; radius } = + let { x; y } = c in + begin_path ctx; + ctx##arc x y radius 0. (2. *. Float.pi) (bl false); + ctx##stroke; + close_path ctx + + let draw_line ctx { a = { x = x1; y = y1 }; b = { x = x2; y = y2 } } = + begin_path ctx; + ctx##moveTo x1 y1; + ctx##lineTo x2 y2; + ctx##stroke; + ctx##moveTo 0. 0.; + close_path ctx + + type curve = float * float * float * float * float * float + + let create_control_points { c; rx; ry } : float point * curve * curve = + let { x; y } = c in + let half_height = ry /. 2. in + let width_two_thirds = rx *. (2. /. 3.) in + ( { x; y = y -. half_height }, + ( x +. width_two_thirds, + y -. half_height, + x +. width_two_thirds, + y +. half_height, + x, + y +. half_height ), + ( x -. width_two_thirds, + y +. half_height, + x -. width_two_thirds, + y -. half_height, + x, + y -. half_height ) ) + + let draw_ellipse ctx ellipse = + begin_path ctx; + let start, curve_one, curve_two = create_control_points ellipse in + ctx##moveTo start.x start.y; + let x1, y1, x2, y2, x3, y3 = curve_one in + ctx##bezierCurveTo x1 y1 x2 y2 x3 y3; + let x1, y1, x2, y2, x3, y3 = curve_two in + ctx##bezierCurveTo x1 y1 x2 y2 x3 y3; + ctx##stroke; + ctx##moveTo 0. 0.; + close_path ctx + + let rec split_at n lst = + match (n, lst) with + | 0, _ -> ([], lst) + | _, [] -> ([], []) + | n, x :: xs -> + let taken, rest = split_at (n - 1) xs in + (x :: taken, rest) + + let rec partition n ?(step = 0) lst = + match lst with + | [] -> [] + | lst -> + let taken, _ = split_at n lst in + if List.length taken = n then taken :: partition n ~step (List.tl lst) + else [] + + let draw_polygon ctx polygon = + let points = partition 2 ~step:1 (polygon @ [ List.hd polygon ]) in + begin_path ctx; + List.iter + (fun pair -> + let Shape.{ x = x1; y = y1 }, Shape.{ x = x2; y = y2 } = + (List.nth pair 0, List.nth pair 1) + in + ctx##moveTo x1 y1; + ctx##lineTo x2 y2) + points; + ctx##stroke; + close_path ctx + + let render_axes () = + let tmap f (a, b) = (f a, f b) in + let render_axes' { context = ctx; size; _ } = + let fsize = tmap float_of_int size in + let hw, hh = tmap (fun n -> n /. 2.) fsize in + let w, h = fsize in + ctx##beginPath; + ctx##moveTo 0. hh; + ctx##lineTo w hh; + ctx##moveTo hw 0.; + ctx##lineTo hw h; + ctx##closePath + in + match !context with Some ctx -> render_axes' ctx | None -> fail () + + let show shapes = + let rec render' context = function + | Shape.Circle circle' -> draw_circle context circle' + | Shape.Ellipse ellipse' -> draw_ellipse context ellipse' + | Shape.Line line' -> draw_line context line' + | Shape.Polygon polygon' -> draw_polygon context polygon' + | Shape.Complex complex' -> List.iter (render' context) complex' + in + match !context with + | Some ctx -> List.iter (render' ctx.context) shapes + | None -> fail () +end diff --git a/lib/canvas.mli b/lib/canvas.mli new file mode 100644 index 0000000..2456494 --- /dev/null +++ b/lib/canvas.mli @@ -0,0 +1 @@ +module Canvas : Modules.Backend diff --git a/lib/context.ml b/lib/context.ml deleted file mode 100644 index 0266e1d..0000000 --- a/lib/context.ml +++ /dev/null @@ -1,67 +0,0 @@ -(* Global rendering context singleton definition and instantiation *) -type context = { - ctx : Cairo.context; - surface : Cairo.Surface.t; - size : int * int; - axes : bool; -} - -(* Renders context to PNG *) -let write ctx filename = Cairo.PNG.write ctx.surface filename -let context = ref None - -exception Context of string - -(* Not working, could use help fixing *) -let () = - Printexc.register_printer (fun e -> - match e with Context err -> Some ("Context: " ^ err) | _ -> None) - -let fail () = raise (Context "not initialized") - -let init_context line_width (w, h) axes = - (* Fail if context has already been instantiated *) - if Option.is_some !context then - raise (Context "Cannot initialize context twice"); - - let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w ~h in - let ctx = Cairo.create surface in - Cairo.scale ctx (float_of_int w) (float_of_int h); - Cairo.set_line_width ctx line_width; - context := Some { ctx; surface; size = (w, h); axes } - -let resolution () = match !context with Some ctx -> ctx.size | None -> fail () -let tmap3 f (a, b, c) = (f a, f b, f c) -let tmap4 f (a, b, c, d) = (f a, f b, f c, f d) -let ( >> ) f g x = g (f x) -let scale_color_channel x = x /. 256. - -let set_color color = - match !context with - | Some ctx -> - let r, g, b = tmap3 (float_of_int >> scale_color_channel) color in - Cairo.set_source_rgba ctx.ctx r g b 1. - | None -> fail () - -(* sets background color *) -let background color = - match !context with - | Some ctx -> - let r, g, b, a = tmap4 (float_of_int >> scale_color_channel) color in - Cairo.set_source_rgba ctx.ctx r g b a; - Cairo.paint ctx.ctx - | None -> fail () - -(** Sets the width of lines for both stroke of shapes and line primitives. - Can be any positive integer, with larger numbers producing thicker lines. - default is 2 *) -let set_line_width line_width = - match !context with - | Some ctx -> Cairo.set_line_width ctx.ctx (float_of_int line_width /. 1000.) - | None -> fail () - -let save () = - match !context with Some ctx -> Cairo.save ctx.ctx | None -> fail () - -let restore () = - match !context with Some ctx -> Cairo.restore ctx.ctx | None -> fail () diff --git a/lib/context.mli b/lib/context.mli deleted file mode 100644 index 07e5ab4..0000000 --- a/lib/context.mli +++ /dev/null @@ -1,20 +0,0 @@ -type context = { - ctx : Cairo.context; - surface : Cairo.Surface.t; - size : int * int; - axes : bool; -} - -val context : context option ref -val fail : unit -> unit - -exception Context of string - -val init_context : float -> int * int -> bool -> unit -val resolution : unit -> int * int -val set_color : int * int * int -> unit -val background : int * int * int * int -> unit -val set_line_width : int -> unit -val write : context -> string -> unit -val save : unit -> unit -val restore : unit -> unit diff --git a/lib/dune b/lib/dune index 5feb774..5cf1b27 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,7 @@ (library (name joy) (public_name joy) - (libraries cairo2) + (libraries cairo2 js_of_ocaml) + (preprocess + (pps js_of_ocaml-ppx)) (wrapped false)) diff --git a/lib/joy.ml b/lib/joy.ml index 6c38900..aced32c 100644 --- a/lib/joy.ml +++ b/lib/joy.ml @@ -1,36 +1,2 @@ -let context = Context.context - -type 'a point = 'a Shape.point -type shape = Shape.shape -type shapes = Shape.shapes - -type transformation = Transform.transformation - -let point = Shape.point -let circle = Shape.circle -let rectangle = Shape.rectangle -let polygon = Shape.polygon -let ellipse = Shape.ellipse -let line = Shape.line -let complex = Shape.complex -let rotate = Transform.rotate -let scale = Transform.scale -let translate = Transform.translate -let compose = Transform.compose -let repeat = Transform.repeat -let set_color = Context.set_color -let background = Context.background -let set_line_width = Context.set_line_width - -let init ?(line_width = 2) ?(size = (800, 800)) ?(axes = false) () = - Context.init_context (float_of_int line_width /. 1000.) size axes - -let write ?(filename = "joy.png") () = - match !Context.context with - | Some ctx -> - if ctx.axes then Render.render_axes (); - Context.write ctx filename - | None -> Context.fail () - -let render shape = Render.render shape -let show shapes = Render.show shapes +module Canvas = Modules.Joy (Canvas.Canvas) +module Svg = Modules.Joy (Svg.Svg) diff --git a/lib/joy.mli b/lib/joy.mli deleted file mode 100644 index d7b39f4..0000000 --- a/lib/joy.mli +++ /dev/null @@ -1,26 +0,0 @@ -type 'a point = 'a Shape.point -type shape = Shape.shape -type shapes = Shape.shapes - -type transformation = Transform.transformation - -val point : int -> int -> float point -val circle : ?c:float point -> int -> shape -val rectangle : ?c:float point -> int -> int -> shape -val ellipse : ?c:float point -> int -> int -> shape -val line : ?a:float point -> float point -> shape -val polygon : float point list -> shape -val complex : shapes -> shape -val rotate : int -> transformation -val translate : int -> int -> transformation -val scale : float -> transformation -val compose : transformation -> transformation -> transformation -val repeat : int -> transformation -> transformation -val context : Context.context option ref -val set_color : int * int * int -> unit -val background : int * int * int * int -> unit -val set_line_width : int -> unit -val init : ?line_width:int -> ?size:int * int -> ?axes:bool -> unit -> unit -val render : shape -> unit -val show : shapes -> unit -val write : ?filename:string -> unit -> unit diff --git a/lib/modules.ml b/lib/modules.ml new file mode 100644 index 0000000..d645204 --- /dev/null +++ b/lib/modules.ml @@ -0,0 +1,62 @@ +module type Backend = sig + type context + + val context : context option ref + + exception Context of string + + val fail : unit -> unit + val init_context : float -> int * int -> bool -> unit + + (* Getters *) + val axes : context -> bool + val resolution : unit -> int * int + + (* Setters *) + val set_color : int * int * int -> unit + val background : int * int * int * int -> unit + val set_line_width : int -> unit + val render_axes : unit -> unit + val save : unit -> unit + val restore : unit -> unit + val write : context -> string -> unit + val show : Shape.shapes -> unit +end + +module Joy (B : Backend) = struct + let context = B.context + + type 'a point = 'a Shape.point + type shape = Shape.shape + type shapes = Shape.shapes + type transformation = Transform.transformation + + let point = Shape.point + let circle = Shape.circle + let rectangle = Shape.rectangle + let polygon = Shape.polygon + let ellipse = Shape.ellipse + let line = Shape.line + let complex = Shape.complex + let rotate = Transform.rotate + let scale = Transform.scale + let translate = Transform.translate + let compose = Transform.compose + let repeat = Transform.repeat + let set_color = B.set_color + let background = B.background + let set_line_width = B.set_line_width + let resolution = B.resolution + + let init ?(line_width = 2) ?(size = (800, 800)) ?(axes = false) () = + B.init_context (float_of_int line_width /. 1000.) size axes + + let write ?(filename = "joy.png") () = + match !B.context with + | Some ctx -> + if B.axes ctx then B.render_axes (); + B.write ctx filename + | None -> B.fail () + + let show shapes = B.show shapes +end diff --git a/lib/render.ml b/lib/render.ml deleted file mode 100644 index eb61e95..0000000 --- a/lib/render.ml +++ /dev/null @@ -1,117 +0,0 @@ -open Shape -open Context - -let tmap f (x, y) = (f x, f y) - -let denormalize point = - let x, y = Context.resolution () |> tmap float_of_int in - let canvas_mid = { x; y } /! 2. in - ((point.x +. canvas_mid.x) /. x, (point.y +. canvas_mid.y) /. y) - -let euclid_norm (x, y) = sqrt (Float.pow x 2. +. Float.pow y 2.) /. 2. - -let draw_circle ctx ({ c; radius } : circle) = - let size = tmap float_of_int ctx.size in - let x, y = denormalize c in - let radius = radius /. euclid_norm size in - Cairo.arc ctx.ctx x y ~r:radius ~a1:0. ~a2:(Float.pi *. 2.); - Cairo.stroke ctx.ctx - -let create_control_points { c; rx; ry } = - let size = resolution () |> tmap float_of_int in - let x, y = denormalize c in - let half_height = ry /. snd size in - let width_two_thirds = rx /. fst size *. (2. /. 3.) *. 2. in - ( { x; y = y -. half_height }, - ( x +. width_two_thirds, - y -. half_height, - x +. width_two_thirds, - y +. half_height, - x, - y +. half_height ), - ( x -. width_two_thirds, - y +. half_height, - x -. width_two_thirds, - y -. half_height, - x, - y -. half_height ) ) - -let draw_ellipse ctx ellipse = - let start, curve_one, curve_two = create_control_points ellipse in - Cairo.save ctx.ctx; - Cairo.move_to ctx.ctx start.x start.y; - let x1, y1, x2, y2, x3, y3 = curve_one in - Cairo.curve_to ctx.ctx x1 y1 x2 y2 x3 y3; - let x1, y1, x2, y2, x3, y3 = curve_two in - Cairo.curve_to ctx.ctx x1 y1 x2 y2 x3 y3; - Cairo.stroke ctx.ctx; - Cairo.restore ctx.ctx - -let draw_line ctx line = - save (); - let x1, y1 = denormalize line.a in - let x2, y2 = denormalize line.b in - Cairo.move_to ctx.ctx x1 y1; - Cairo.line_to ctx.ctx x2 y2; - Cairo.stroke ctx.ctx; - restore () - -let rec take n lst = - match (n, lst) with - | 0, _ -> ([], lst) - | _, [] -> ([], []) - | n, x :: xs -> - let taken, rest = take (n - 1) xs in - (x :: taken, rest) - -let rec partition n ?step lst = - match lst with - | [] -> [] - | _ -> - let taken, _ = take n lst in - if List.length taken = n then - taken - :: - (match step with - | Some s -> partition n ~step:s (List.tl lst) - | None -> partition n ~step:0 (List.tl lst)) - else [] - -let draw_polygon ctx polygon = - let points = partition 2 ~step:1 (polygon @ [ List.hd polygon ]) in - List.iter - (fun pair -> - let pair = List.map denormalize pair in - let (x1, y1), (x2, y2) = (List.nth pair 0, List.nth pair 1) in - Cairo.move_to ctx.ctx x1 y1; - Cairo.line_to ctx.ctx x2 y2) - points; - Cairo.move_to ctx.ctx 0. 0.; - Cairo.stroke ctx.ctx - -let rec render_shape ctx = function - | Circle circle -> draw_circle ctx circle - | Ellipse ellipse -> draw_ellipse ctx ellipse - | Line line -> draw_line ctx line - | Polygon polygon -> draw_polygon ctx polygon - | Complex complex -> List.iter (render_shape ctx) complex - -(* Validates context before rendering *) -let render shape = - match !context with Some ctx -> render_shape ctx shape | None -> fail () - -let show shapes = - match !context with - | Some ctx -> List.iter (render_shape ctx) shapes - | None -> fail () - -let render_axes () = - print_endline "rendering axes!"; - save (); - let x, y = Context.resolution () |> tmap float_of_int in - let half_x, half_y = (x /. 2., y /. 2.) in - let x_axis = line ~a:{ x = 0.; y = -.half_y } { x = 0.; y = half_y } in - let y_axis = line ~a:{ x = -.half_x; y = 0. } { x = half_x; y = 0. } in - set_color (0, 0, 0); - show [ x_axis; y_axis ]; - restore () diff --git a/lib/render.mli b/lib/render.mli deleted file mode 100644 index c4c7e03..0000000 --- a/lib/render.mli +++ /dev/null @@ -1,8 +0,0 @@ -val draw_circle : Context.context -> Shape.circle -> unit -val draw_ellipse : Context.context -> Shape.ellipse -> unit -val draw_line : Context.context -> Shape.line -> unit -val draw_polygon : Context.context -> Shape.polygon -> unit -val render_axes : unit -> unit -val render_shape : Context.context -> Shape.shape -> unit -val render : Shape.shape -> unit -val show : Shape.shape list -> unit diff --git a/lib/svg.ml b/lib/svg.ml new file mode 100644 index 0000000..a7754b7 --- /dev/null +++ b/lib/svg.ml @@ -0,0 +1,185 @@ +module Svg : Modules.Backend = struct + (* Global rendering context singleton definition and instantiation *) + type context = { + ctx : Cairo.context; + surface : Cairo.Surface.t; + size : int * int; + axes : bool; + } + + (* Renders context to PNG *) + let write ctx filename = Cairo.PNG.write ctx.surface filename + let context = ref None + + exception Context of string + + (* Not working, could use help fixing *) + let () = + Printexc.register_printer (fun e -> + match e with Context err -> Some ("Context: " ^ err) | _ -> None) + + let fail () = raise (Context "not initialized") + + let init_context line_width (w, h) axes = + (* Fail if context has already been instantiated *) + if Option.is_some !context then + raise (Context "Cannot initialize context twice"); + + let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w ~h in + let ctx = Cairo.create surface in + Cairo.scale ctx (float_of_int w) (float_of_int h); + Cairo.set_line_width ctx line_width; + context := Some { ctx; surface; size = (w, h); axes } + + let axes ctx = ctx.axes + + let resolution () = + match !context with Some ctx -> ctx.size | None -> fail () + + let tmap3 f (a, b, c) = (f a, f b, f c) + let tmap4 f (a, b, c, d) = (f a, f b, f c, f d) + let ( >> ) f g x = g (f x) + let scale_color_channel x = x /. 256. + + let set_color color = + match !context with + | Some ctx -> + let r, g, b = tmap3 (float_of_int >> scale_color_channel) color in + Cairo.set_source_rgba ctx.ctx r g b 1. + | None -> fail () + + (* sets background color *) + let background color = + match !context with + | Some ctx -> + let r, g, b, a = tmap4 (float_of_int >> scale_color_channel) color in + Cairo.set_source_rgba ctx.ctx r g b a; + Cairo.paint ctx.ctx + | None -> fail () + + (** Sets the width of lines for both stroke of shapes and line primitives. + Can be any positive integer, with larger numbers producing thicker lines. + default is 2 *) + let set_line_width line_width = + match !context with + | Some ctx -> Cairo.set_line_width ctx.ctx (float_of_int line_width /. 1000.) + | None -> fail () + + let save () = + match !context with Some ctx -> Cairo.save ctx.ctx | None -> fail () + + let restore () = + match !context with Some ctx -> Cairo.restore ctx.ctx | None -> fail () + + open Shape + + let tmap f (x, y) = (f x, f y) + + let denormalize point = + let x, y = resolution () |> tmap float_of_int in + let canvas_mid = { x; y } /! 2. in + ((point.x +. canvas_mid.x) /. x, (point.y +. canvas_mid.y) /. y) + + let euclid_norm (x, y) = sqrt (Float.pow x 2. +. Float.pow y 2.) /. 2. + + let draw_circle ctx ({ c; radius } : circle) = + let size = tmap float_of_int ctx.size in + let x, y = denormalize c in + let radius = radius /. euclid_norm size in + Cairo.arc ctx.ctx x y ~r:radius ~a1:0. ~a2:(Float.pi *. 2.); + Cairo.stroke ctx.ctx + + let create_control_points { c; rx; ry } = + let size = resolution () |> tmap float_of_int in + let x, y = denormalize c in + let half_height = ry /. snd size in + let width_two_thirds = rx /. fst size *. (2. /. 3.) *. 2. in + ( { x; y = y -. half_height }, + ( x +. width_two_thirds, + y -. half_height, + x +. width_two_thirds, + y +. half_height, + x, + y +. half_height ), + ( x -. width_two_thirds, + y +. half_height, + x -. width_two_thirds, + y -. half_height, + x, + y -. half_height ) ) + + let draw_ellipse ctx ellipse = + let start, curve_one, curve_two = create_control_points ellipse in + Cairo.save ctx.ctx; + Cairo.move_to ctx.ctx start.x start.y; + let x1, y1, x2, y2, x3, y3 = curve_one in + Cairo.curve_to ctx.ctx x1 y1 x2 y2 x3 y3; + let x1, y1, x2, y2, x3, y3 = curve_two in + Cairo.curve_to ctx.ctx x1 y1 x2 y2 x3 y3; + Cairo.stroke ctx.ctx; + Cairo.restore ctx.ctx + + let draw_line ctx line = + save (); + let x1, y1 = denormalize line.a in + let x2, y2 = denormalize line.b in + Cairo.move_to ctx.ctx x1 y1; + Cairo.line_to ctx.ctx x2 y2; + Cairo.stroke ctx.ctx; + restore () + + let rec take n lst = + match (n, lst) with + | 0, _ -> ([], lst) + | _, [] -> ([], []) + | n, x :: xs -> + let taken, rest = take (n - 1) xs in + (x :: taken, rest) + + let rec partition n ?step lst = + match lst with + | [] -> [] + | _ -> + let taken, _ = take n lst in + if List.length taken = n then + taken + :: + (match step with + | Some s -> partition n ~step:s (List.tl lst) + | None -> partition n ~step:0 (List.tl lst)) + else [] + + let draw_polygon ctx polygon = + let points = partition 2 ~step:1 (polygon @ [ List.hd polygon ]) in + List.iter + (fun pair -> + let pair = List.map denormalize pair in + let (x1, y1), (x2, y2) = (List.nth pair 0, List.nth pair 1) in + Cairo.move_to ctx.ctx x1 y1; + Cairo.line_to ctx.ctx x2 y2) + points; + Cairo.move_to ctx.ctx 0. 0.; + Cairo.stroke ctx.ctx + + let show shapes = + let rec render ctx = function + | Circle circle -> draw_circle ctx circle + | Ellipse ellipse -> draw_ellipse ctx ellipse + | Line line -> draw_line ctx line + | Polygon polygon -> draw_polygon ctx polygon + | Complex complex -> List.iter (render ctx) complex + in + match !context with + | Some ctx -> List.iter (render ctx) shapes + | None -> fail () + + let render_axes () = + save (); + let x, y = resolution () |> tmap float_of_int in + let half_x, half_y = (x /. 2., y /. 2.) in + let x_axis = line ~a:{ x = 0.; y = -.half_y } { x = 0.; y = half_y } in + let y_axis = line ~a:{ x = -.half_x; y = 0. } { x = half_x; y = 0. } in + set_color (0, 0, 0); + show [ x_axis; y_axis ]; + restore () +end diff --git a/lib/svg.mli b/lib/svg.mli new file mode 100644 index 0000000..2d77e4f --- /dev/null +++ b/lib/svg.mli @@ -0,0 +1 @@ +module Svg : Modules.Backend diff --git a/lib/transform.ml b/lib/transform.ml index 29cd29b..ce0b2c4 100644 --- a/lib/transform.ml +++ b/lib/transform.ml @@ -1,6 +1,6 @@ open Shape -type transformation = (shape -> shape) +type transformation = shape -> shape let rec translate dx dy shape = match shape with diff --git a/lib/transform.mli b/lib/transform.mli index 6fa2fa1..0e707ae 100644 --- a/lib/transform.mli +++ b/lib/transform.mli @@ -1,4 +1,4 @@ -type transformation = (Shape.shape -> Shape.shape) +type transformation = Shape.shape -> Shape.shape val translate : int -> int -> transformation val scale : float -> transformation diff --git a/test/test_circle.ml b/test/test_circle.ml index 6153bfd..a699cd0 100644 --- a/test/test_circle.ml +++ b/test/test_circle.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let run () = init (); diff --git a/test/test_ellipse.ml b/test/test_ellipse.ml index df8600c..78d626e 100644 --- a/test/test_ellipse.ml +++ b/test/test_ellipse.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let run () = init (); diff --git a/test/test_rectangle.ml b/test/test_rectangle.ml index 73734e5..7e8d12d 100644 --- a/test/test_rectangle.ml +++ b/test/test_rectangle.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let run () = init (); diff --git a/test/test_scale_shape.ml b/test/test_scale_shape.ml index 3b3f0df..a8b4451 100644 --- a/test/test_scale_shape.ml +++ b/test/test_scale_shape.ml @@ -1,4 +1,4 @@ -open Joy +open Joy.Svg let run () = init (); From 0fafbb04ab1c13007a6ff4d4d7ae6c6707f99437 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Wed, 7 Feb 2024 13:02:18 -0500 Subject: [PATCH 2/5] fmt, cleanup, index.html, failing example --- .ocamlformat | 2 +- examples/axes.ml | 2 +- examples/canvas.ml | 8 ++++++++ examples/dune | 6 ++++++ index.html | 12 ++++++++++++ lib/canvas.ml | 14 +++++++------- 6 files changed, 35 insertions(+), 9 deletions(-) create mode 100644 examples/canvas.ml create mode 100644 index.html diff --git a/.ocamlformat b/.ocamlformat index 0b240ee..7df62da 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,2 +1,2 @@ profile = default -version = 0.26.0 \ No newline at end of file +version = 0.26.1 \ No newline at end of file diff --git a/examples/axes.ml b/examples/axes.ml index 2f7c461..5f97ae3 100644 --- a/examples/axes.ml +++ b/examples/axes.ml @@ -9,6 +9,6 @@ let _ = background (255, 255, 255, 255); let c = circle 50 in set_color (0, 0, 0); - show [c]; + show [ c ]; (* Write to PNG! *) write ~filename:"axes.png" () diff --git a/examples/canvas.ml b/examples/canvas.ml new file mode 100644 index 0000000..d604e03 --- /dev/null +++ b/examples/canvas.ml @@ -0,0 +1,8 @@ +open Joy.Canvas + +let () = + init (); + background (255, 255, 255, 255); + let c = circle 100 in + set_color (0, 0, 0); + show [ c ] diff --git a/examples/dune b/examples/dune index 1c42610..072dd87 100644 --- a/examples/dune +++ b/examples/dune @@ -102,3 +102,9 @@ (name donut_with_scale) (modules donut_with_scale) (libraries joy)) + +(executable + (name canvas) + (modes js) + (modules canvas) + (libraries joy)) diff --git a/index.html b/index.html new file mode 100644 index 0000000..4e39f14 --- /dev/null +++ b/index.html @@ -0,0 +1,12 @@ + + + + + + Joy + + +
+ + + diff --git a/lib/canvas.ml b/lib/canvas.ml index 8225376..4432ef3 100644 --- a/lib/canvas.ml +++ b/lib/canvas.ml @@ -19,7 +19,7 @@ module Canvas : Modules.Backend = struct axes : bool; } - let context : context option ref = ref None + let context = ref None exception Context of string @@ -179,7 +179,7 @@ module Canvas : Modules.Backend = struct begin_path ctx; List.iter (fun pair -> - let Shape.{ x = x1; y = y1 }, Shape.{ x = x2; y = y2 } = + let { x = x1; y = y1 }, { x = x2; y = y2 } = (List.nth pair 0, List.nth pair 1) in ctx##moveTo x1 y1; @@ -205,11 +205,11 @@ module Canvas : Modules.Backend = struct let show shapes = let rec render' context = function - | Shape.Circle circle' -> draw_circle context circle' - | Shape.Ellipse ellipse' -> draw_ellipse context ellipse' - | Shape.Line line' -> draw_line context line' - | Shape.Polygon polygon' -> draw_polygon context polygon' - | Shape.Complex complex' -> List.iter (render' context) complex' + | Circle circle' -> draw_circle context circle' + | Ellipse ellipse' -> draw_ellipse context ellipse' + | Line line' -> draw_line context line' + | Polygon polygon' -> draw_polygon context polygon' + | Complex complex' -> List.iter (render' context) complex' in match !context with | Some ctx -> List.iter (render' ctx.context) shapes From 1c28ee0cee828d307e8265ce03101188feee9d36 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Wed, 7 Feb 2024 14:10:12 -0500 Subject: [PATCH 3/5] removing tailwind classses accidentally included in index.html --- index.html | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/index.html b/index.html index 4e39f14..3561cc1 100644 --- a/index.html +++ b/index.html @@ -5,8 +5,7 @@ Joy - -
+ From 09b76c249abb551bbd1d6ebe3fa6ad21107be4ee Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Thu, 8 Feb 2024 19:57:47 -0500 Subject: [PATCH 4/5] fixed linking and line width issue: working as expected --- examples/canvas.ml | 8 +++++--- lib/canvas.ml | 17 ++++++++++------ lib/canvas.mli | 39 +++++++++++++++++++++++++++++++++++- lib/joy.ml | 4 ++-- lib/joy.mli | 2 ++ lib/modules.ml | 4 ++-- lib/modules.mli | 50 ++++++++++++++++++++++++++++++++++++++++++++++ lib/svg.ml | 6 ++++-- lib/svg.mli | 32 ++++++++++++++++++++++++++++- 9 files changed, 145 insertions(+), 17 deletions(-) create mode 100644 lib/joy.mli create mode 100644 lib/modules.mli diff --git a/examples/canvas.ml b/examples/canvas.ml index d604e03..7334dec 100644 --- a/examples/canvas.ml +++ b/examples/canvas.ml @@ -1,8 +1,10 @@ open Joy.Canvas let () = - init (); + print_endline "TEST"; + init ~size:(400, 400) (); background (255, 255, 255, 255); let c = circle 100 in - set_color (0, 0, 0); - show [ c ] + let r = rectangle 200 150 in + set_color (255, 0, 0); + show [ c; r ] diff --git a/lib/canvas.ml b/lib/canvas.ml index 4432ef3..7889c7d 100644 --- a/lib/canvas.ml +++ b/lib/canvas.ml @@ -12,7 +12,7 @@ let doc = Html.document (* Needed for 'write'/image save*) let _window = Html.window -module Canvas : Modules.Backend = struct +module C : Modules.Backend = struct type context = { context : Html.canvasRenderingContext2D Js.t; size : int * int; @@ -40,11 +40,13 @@ module Canvas : Modules.Backend = struct let init_context line_width size axes = let canvas = create_canvas size in if Option.is_some !context then - raise (Context "cannot iniitialize context twice") + raise (Context "context already initialized") else ( Dom.appendChild doc##.body canvas; let ctx = canvas##getContext Html._2d_ in + ctx##translate (fst size / 2 |> float_of_int) (snd size / 2 |> float_of_int); ctx##.lineWidth := line_width; + context := Some { context = ctx; axes; size }) (* Sets global color *) @@ -71,7 +73,8 @@ module Canvas : Modules.Backend = struct let w, h = ctx.size in begin_path context; context##.fillStyle := col; - context##fillRect 0. 0. (float_of_int w) (float_of_int h) + context##fillRect 0. 0. (float_of_int w) (float_of_int h); + close_path context | None -> fail () (* Accessor functions for 'context' *) @@ -85,7 +88,7 @@ module Canvas : Modules.Backend = struct let set_line_width lw = match !context with - | Some { context = ctx; _ } -> ctx##.lineWidth := float_of_int lw /. 1000. + | Some { context; _ } -> context##.lineWidth := float_of_int lw | None -> fail () (** TODO: writ this fn, blob API + coercion in JSOO is tough, not sure where @@ -101,12 +104,12 @@ module Canvas : Modules.Backend = struct let save () = match !context with - | Some { context = ctx; _ } -> ctx##save + | Some { context; _ } -> context##save | None -> fail () let restore () = match !context with - | Some { context = ctx; _ } -> ctx##restore + | Some { context; _ } -> context##restore | None -> fail () open Shape @@ -215,3 +218,5 @@ module Canvas : Modules.Backend = struct | Some ctx -> List.iter (render' ctx.context) shapes | None -> fail () end + +module Backend = Modules.Make(C) diff --git a/lib/canvas.mli b/lib/canvas.mli index 2456494..3ceb819 100644 --- a/lib/canvas.mli +++ b/lib/canvas.mli @@ -1 +1,38 @@ -module Canvas : Modules.Backend +module Html = Js_of_ocaml.Dom_html +module Dom = Js_of_ocaml.Dom +module Js = Js_of_ocaml.Js +val str : string -> Js.js_string Js.t +val bl : bool -> bool Js.t +val doc : Html.document Js_of_ocaml.Js.t +val _window : Html.window Js_of_ocaml.Js.t +module C : Modules.Backend +module Backend : + sig + val context : C.context option ref + type 'a point = 'a Shape.point + type shape = Shape.shape + type shapes = Shape.shapes + type transformation = Transform.transformation + val point : int -> int -> float Shape.point + val circle : ?c:float Shape.point -> int -> Shape.shape + val rectangle : ?c:float Shape.point -> int -> int -> Shape.shape + val polygon : float Shape.point list -> Shape.shape + val ellipse : ?c:float Shape.point -> int -> int -> Shape.shape + val line : ?a:float Shape.point -> float Shape.point -> Shape.shape + val complex : Shape.shape list -> Shape.shape + val rotate : int -> Transform.transformation + val scale : float -> Transform.transformation + val translate : int -> int -> Transform.transformation + val compose : + Transform.transformation -> + Transform.transformation -> Transform.transformation + val repeat : int -> Transform.transformation -> Transform.transformation + val set_color : int * int * int -> unit + val background : int * int * int * int -> unit + val set_line_width : int -> unit + val resolution : unit -> int * int + val init : + ?line_width:int -> ?size:int * int -> ?axes:bool -> unit -> unit + val write : ?filename:string -> unit -> unit + val show : Shape.shapes -> unit + end diff --git a/lib/joy.ml b/lib/joy.ml index aced32c..148efb5 100644 --- a/lib/joy.ml +++ b/lib/joy.ml @@ -1,2 +1,2 @@ -module Canvas = Modules.Joy (Canvas.Canvas) -module Svg = Modules.Joy (Svg.Svg) +module Svg = Svg.Backend +module Canvas = Canvas.Backend diff --git a/lib/joy.mli b/lib/joy.mli new file mode 100644 index 0000000..fdd5a8b --- /dev/null +++ b/lib/joy.mli @@ -0,0 +1,2 @@ +module Svg = Svg.Backend +module Canvas = Canvas.Backend diff --git a/lib/modules.ml b/lib/modules.ml index d645204..63998eb 100644 --- a/lib/modules.ml +++ b/lib/modules.ml @@ -23,7 +23,7 @@ module type Backend = sig val show : Shape.shapes -> unit end -module Joy (B : Backend) = struct +module Make (B : Backend) = struct let context = B.context type 'a point = 'a Shape.point @@ -49,7 +49,7 @@ module Joy (B : Backend) = struct let resolution = B.resolution let init ?(line_width = 2) ?(size = (800, 800)) ?(axes = false) () = - B.init_context (float_of_int line_width /. 1000.) size axes + B.init_context (float_of_int line_width) size axes let write ?(filename = "joy.png") () = match !B.context with diff --git a/lib/modules.mli b/lib/modules.mli new file mode 100644 index 0000000..7c6e24f --- /dev/null +++ b/lib/modules.mli @@ -0,0 +1,50 @@ +module type Backend = + sig + type context + val context : context option ref + exception Context of string + val fail : unit -> unit + val init_context : float -> int * int -> bool -> unit + val axes : context -> bool + val resolution : unit -> int * int + val set_color : int * int * int -> unit + val background : int * int * int * int -> unit + val set_line_width : int -> unit + val render_axes : unit -> unit + val save : unit -> unit + val restore : unit -> unit + val write : context -> string -> unit + val show : Shape.shapes -> unit + end +module Make : + functor (B : Backend) -> + sig + val context : B.context option ref + type 'a point = 'a Shape.point + type shape = Shape.shape + type shapes = Shape.shapes + type transformation = Transform.transformation + val point : int -> int -> float Shape.point + val circle : ?c:float Shape.point -> int -> Shape.shape + val rectangle : ?c:float Shape.point -> int -> int -> Shape.shape + val polygon : float Shape.point list -> Shape.shape + val ellipse : ?c:float Shape.point -> int -> int -> Shape.shape + val line : ?a:float Shape.point -> float Shape.point -> Shape.shape + val complex : Shape.shape list -> Shape.shape + val rotate : int -> Transform.transformation + val scale : float -> Transform.transformation + val translate : int -> int -> Transform.transformation + val compose : + Transform.transformation -> + Transform.transformation -> Transform.transformation + val repeat : + int -> Transform.transformation -> Transform.transformation + val set_color : int * int * int -> unit + val background : int * int * int * int -> unit + val set_line_width : int -> unit + val resolution : unit -> int * int + val init : + ?line_width:int -> ?size:int * int -> ?axes:bool -> unit -> unit + val write : ?filename:string -> unit -> unit + val show : Shape.shapes -> unit + end diff --git a/lib/svg.ml b/lib/svg.ml index a7754b7..b7cde82 100644 --- a/lib/svg.ml +++ b/lib/svg.ml @@ -1,4 +1,4 @@ -module Svg : Modules.Backend = struct +module S : Modules.Backend = struct (* Global rendering context singleton definition and instantiation *) type context = { ctx : Cairo.context; @@ -28,7 +28,7 @@ module Svg : Modules.Backend = struct let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w ~h in let ctx = Cairo.create surface in Cairo.scale ctx (float_of_int w) (float_of_int h); - Cairo.set_line_width ctx line_width; + Cairo.set_line_width ctx (line_width /. 1000.); context := Some { ctx; surface; size = (w, h); axes } let axes ctx = ctx.axes @@ -183,3 +183,5 @@ module Svg : Modules.Backend = struct show [ x_axis; y_axis ]; restore () end + +module Backend = Modules.Make(S) \ No newline at end of file diff --git a/lib/svg.mli b/lib/svg.mli index 2d77e4f..be80653 100644 --- a/lib/svg.mli +++ b/lib/svg.mli @@ -1 +1,31 @@ -module Svg : Modules.Backend +module S : Modules.Backend +module Backend : + sig + val context : S.context option ref + type 'a point = 'a Shape.point + type shape = Shape.shape + type shapes = Shape.shapes + type transformation = Transform.transformation + val point : int -> int -> float Shape.point + val circle : ?c:float Shape.point -> int -> Shape.shape + val rectangle : ?c:float Shape.point -> int -> int -> Shape.shape + val polygon : float Shape.point list -> Shape.shape + val ellipse : ?c:float Shape.point -> int -> int -> Shape.shape + val line : ?a:float Shape.point -> float Shape.point -> Shape.shape + val complex : Shape.shape list -> Shape.shape + val rotate : int -> Transform.transformation + val scale : float -> Transform.transformation + val translate : int -> int -> Transform.transformation + val compose : + Transform.transformation -> + Transform.transformation -> Transform.transformation + val repeat : int -> Transform.transformation -> Transform.transformation + val set_color : int * int * int -> unit + val background : int * int * int * int -> unit + val set_line_width : int -> unit + val resolution : unit -> int * int + val init : + ?line_width:int -> ?size:int * int -> ?axes:bool -> unit -> unit + val write : ?filename:string -> unit -> unit + val show : Shape.shapes -> unit + end From 50f001261273bc6b52ea6306581ce1d79ed61f2a Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Tue, 27 Feb 2024 17:51:45 -0500 Subject: [PATCH 5/5] fmt --- lib/canvas.mli | 3 +-- lib/modules.ml | 19 ++++++++++--------- lib/modules.mli | 12 ++++++------ lib/svg.mli | 1 - 4 files changed, 17 insertions(+), 18 deletions(-) diff --git a/lib/canvas.mli b/lib/canvas.mli index 7192d1c..a402467 100644 --- a/lib/canvas.mli +++ b/lib/canvas.mli @@ -8,5 +8,4 @@ val doc : Html.document Js_of_ocaml.Js.t val _window : Html.window Js_of_ocaml.Js.t module C : Modules.Impl - -module Backend : Modules.Backend \ No newline at end of file +module Backend : Modules.Backend diff --git a/lib/modules.ml b/lib/modules.ml index 9069737..442f22c 100644 --- a/lib/modules.ml +++ b/lib/modules.ml @@ -23,6 +23,7 @@ end module type Backend = sig type context + val context : context option ref type 'a point = 'a Shape.point @@ -45,12 +46,11 @@ module type Backend = sig val with_fill : color -> shape -> shape val map_stroke : (color -> color) -> shape -> shape val map_fill : (color -> color) -> shape -> shape - - val white : color - val black : color - val red : color - val blue : color - val green : color + val white : color + val black : color + val red : color + val blue : color + val green : color val yellow : color val compose : @@ -76,11 +76,12 @@ end module Make (B : Impl) : Backend with type context = B.context = struct type context = B.context + let context = B.context - include Shape - include Transform - include Color + include Shape + include Transform + include Color let set_line_width = B.set_line_width let resolution = B.resolution diff --git a/lib/modules.mli b/lib/modules.mli index 4b310e6..a060285 100644 --- a/lib/modules.mli +++ b/lib/modules.mli @@ -19,6 +19,7 @@ end module type Backend = sig type context + val context : context option ref type 'a point = 'a Shape.point @@ -41,12 +42,11 @@ module type Backend = sig val with_fill : color -> shape -> shape val map_stroke : (color -> color) -> shape -> shape val map_fill : (color -> color) -> shape -> shape - - val white : color - val black : color - val red : color - val blue : color - val green : color + val white : color + val black : color + val red : color + val blue : color + val green : color val yellow : color val compose : diff --git a/lib/svg.mli b/lib/svg.mli index 4f0b9d1..b13a2fd 100644 --- a/lib/svg.mli +++ b/lib/svg.mli @@ -1,3 +1,2 @@ module S : Modules.Impl - module Backend : Modules.Backend