From bf4b1bec6c3e5819fb949d9b076495b239ae7860 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 11:07:44 +0530 Subject: [PATCH 1/9] Refactor and rename: backends, cairo, contexts --- examples/axes.ml | 2 - examples/circle_packing.ml | 14 ++--- examples/fill_rect.ml | 3 +- examples/flowfield.ml | 3 +- examples/quadtree.ml | 4 +- examples/square.ml | 2 +- lib/backend_cairo.ml | 104 ++++++++++++++++++++++++++++++ lib/backend_cairo.mli | 15 +++++ lib/backend_lazy.ml | 5 ++ lib/backend_lazy.mli | 4 ++ lib/backend_svg.ml | 4 ++ lib/backend_svg.mli | 4 ++ lib/color.ml | 28 ++++----- lib/color.mli | 7 ++- lib/context.ml | 125 ++++++++++++++++--------------------- lib/context.mli | 31 +++++---- lib/joy.ml | 28 ++++++--- lib/joy.mli | 40 ++++++------ lib/render.ml | 89 -------------------------- lib/render.mli | 6 -- lib/shape.ml | 57 ++++++----------- lib/shape.mli | 14 ++--- lib/transform.ml | 12 ++-- 23 files changed, 308 insertions(+), 293 deletions(-) create mode 100644 lib/backend_cairo.ml create mode 100644 lib/backend_cairo.mli create mode 100644 lib/backend_lazy.ml create mode 100644 lib/backend_lazy.mli create mode 100644 lib/backend_svg.ml create mode 100644 lib/backend_svg.mli delete mode 100644 lib/render.ml delete mode 100644 lib/render.mli diff --git a/examples/axes.ml b/examples/axes.ml index aa8c2ef..c12bbc5 100644 --- a/examples/axes.ml +++ b/examples/axes.ml @@ -2,9 +2,7 @@ open Joy let _ = - (* intialize rendering context with the axes flag set to true *) init ~axes:true (); - (* set background to opaque white *) let c = circle 50 in show [ c ]; (* Write to PNG! *) diff --git a/examples/circle_packing.ml b/examples/circle_packing.ml index a954639..fc3670b 100644 --- a/examples/circle_packing.ml +++ b/examples/circle_packing.ml @@ -16,19 +16,19 @@ let max_attempts = 100_000 let palette = [ (* purple *) - (107, 108, 163); + rgb 107 108 163; (* light blue *) - (135, 188, 189); + rgb 135 188 189; (* green *) - (111, 153, 84); + rgb 111 153 84; (* light purple *) - (150, 155, 199); + rgb 150 155 199; (* light green *) - (137, 171, 124); + rgb 137 171 124; (* dark purple *) - (67, 68, 117); + rgb 67 68 117; (* darker purple *) - (44, 45, 84); + rgb 44 45 84; ] (* utility Functions *) diff --git a/examples/fill_rect.ml b/examples/fill_rect.ml index 18d5b28..5ca19b3 100644 --- a/examples/fill_rect.ml +++ b/examples/fill_rect.ml @@ -2,6 +2,7 @@ open Joy let () = init (); - let r = rectangle 200 200 |> with_fill (255, 0, 0) in + let r = rectangle 200 200 |> with_fill (rgb 255 0 0) in show [ r ]; write ~filename:"fill-rect.png" () + diff --git a/examples/flowfield.ml b/examples/flowfield.ml index e857ca3..4b05d0a 100644 --- a/examples/flowfield.ml +++ b/examples/flowfield.ml @@ -91,7 +91,8 @@ let add_color flowfield line (x, y) = |> ( *. ) (float_of_int (List.length palette)) |> int_of_float |> List.nth palette in - line |> Joy.with_stroke color + let r, g, b = color in + line |> Joy.with_stroke (Joy.rgb r g b) let () = let open Joy in diff --git a/examples/quadtree.ml b/examples/quadtree.ml index 59936a0..f0c2d54 100644 --- a/examples/quadtree.ml +++ b/examples/quadtree.ml @@ -6,8 +6,8 @@ let half_size = size /. 2. let max_leaf_points = 4 let clusters = 32 let point_size = 1 -let box_color = (0, 0, 0) -let point_color = (255, 1, 1) +let box_color = Joy.rgb 0 0 0 +let point_color = Joy.rgb 255 1 1 (* Point utils *) let splat n : point = { x = n; y = n } diff --git a/examples/square.ml b/examples/square.ml index 542788c..9c68a08 100644 --- a/examples/square.ml +++ b/examples/square.ml @@ -1,7 +1,7 @@ open Joy let () = - init (); + init ~axes:true (); let square = rectangle 100 100 in show [ square ]; write ~filename:"square.png" () diff --git a/lib/backend_cairo.ml b/lib/backend_cairo.ml new file mode 100644 index 0000000..336feac --- /dev/null +++ b/lib/backend_cairo.ml @@ -0,0 +1,104 @@ +type context = { + cairo_ctx : Cairo.context; + surface : Cairo.Surface.t; + size : int * int; + background_color: int * int * int * float; + axes: bool; +} + +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 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. + default is 2 *) +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 = + (* TODO: stroke and fill MUST have a value before coming to the renderer *) + 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 stroke fill = + (* Save the current transformation matrix *) + let save_matrix = Cairo.get_matrix ctx.cairo_ctx in + + (* 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; + 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; + + Cairo.Path.clear ctx.cairo_ctx + +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 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 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.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 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 + diff --git a/lib/backend_cairo.mli b/lib/backend_cairo.mli new file mode 100644 index 0000000..3a67e8f --- /dev/null +++ b/lib/backend_cairo.mli @@ -0,0 +1,15 @@ +type context = { + cairo_ctx : Cairo.context; + surface : Cairo.Surface.t; + size : int * int; + background_color: Color.color; + axes: bool; +} + +val set_color : context -> Color.color -> unit +val set_background : context -> Color.color -> 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 diff --git a/lib/backend_lazy.ml b/lib/backend_lazy.ml new file mode 100644 index 0000000..e2d719e --- /dev/null +++ b/lib/backend_lazy.ml @@ -0,0 +1,5 @@ +type context = unit + +let show _ctx _shapes = () +let create _ = () + diff --git a/lib/backend_lazy.mli b/lib/backend_lazy.mli new file mode 100644 index 0000000..d7ff084 --- /dev/null +++ b/lib/backend_lazy.mli @@ -0,0 +1,4 @@ +type context = unit + +val show : context -> Shape.shapes -> unit +val create : unit -> context diff --git a/lib/backend_svg.ml b/lib/backend_svg.ml new file mode 100644 index 0000000..e0c304c --- /dev/null +++ b/lib/backend_svg.ml @@ -0,0 +1,4 @@ +type context = unit + +let show _ctx _shapes = () +let create _ = () diff --git a/lib/backend_svg.mli b/lib/backend_svg.mli new file mode 100644 index 0000000..d7ff084 --- /dev/null +++ b/lib/backend_svg.mli @@ -0,0 +1,4 @@ +type context = unit + +val show : context -> Shape.shapes -> unit +val create : unit -> context diff --git a/lib/color.ml b/lib/color.ml index 18a8caa..0b5838b 100644 --- a/lib/color.ml +++ b/lib/color.ml @@ -1,26 +1,26 @@ -type color = int * int * int +type color = int * int * int * float + +(** RGBA constant to set transparent background *) +let transparent = (0, 0, 0, 0.0) + +(** Converts RGB color into opaque RGBA color. + For use w/ `Context.background` *) +let rgb r g b = (r, g, b, 1.0) (** RGB code for black *) -let black = (0, 0, 0) +let black = rgb 0 0 0 (** RGB code for white *) -let white = (255, 255, 255) +let white = rgb 255 255 255 (** RGB code for red *) -let red = (255, 1, 1) +let red = rgb 255 1 1 (** RGB code for green *) -let green = (1, 255, 1) +let green = rgb 1 255 1 (** RGB code for blue *) -let blue = (1, 1, 255) +let blue = rgb 1 1 255 (** RGB code for yellow *) -let yellow = (255, 255, 1) - -(** RGBA constant to set transparent background *) -let transparent = (0, 0, 0, 0) - -(** Converts RGB color into opaque RGBA color. - For use w/ `Context.background` *) -let opaque (r, g, b) = (r, g, b, 255) +let yellow = rgb 255 255 255 diff --git a/lib/color.mli b/lib/color.mli index 7ac3165..0e0496b 100644 --- a/lib/color.mli +++ b/lib/color.mli @@ -1,4 +1,6 @@ -type color = int * int * int +type color = int * int * int * float + +val rgb : int -> int -> int -> color val black : color val white : color @@ -6,5 +8,4 @@ val red : color val green : color val blue : color val yellow : color -val transparent : int * int * int * int -val opaque : color -> int * int * int * int +val transparent : color diff --git a/lib/context.ml b/lib/context.ml index f380448..6fcc83d 100644 --- a/lib/context.ml +++ b/lib/context.ml @@ -1,71 +1,56 @@ -open Util +type context = + CairoContext of Backend_cairo.context + | SVGContext of Backend_svg.context + | LazyContext of Backend_lazy.context + +exception No_context +exception Unsupported_output_format of string + +let default = ref (LazyContext (Backend_lazy.create ())) + +let get_default _ = + !default + +let set_default ctx = + default := ctx + +let show ?ctx shapes = + 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 set_line_width ?ctx int = + let ctx = match ctx with + | Some ctx -> ctx + | None -> get_default () + in + match ctx with + | CairoContext ctx -> Backend_cairo.set_line_width ctx int + | SVGContext _ -> failwith "SVG.set_line_width ctx int" + | LazyContext _ -> failwith "Backend_lazy.set_line_width ctx int" + +let writePNG ?ctx filename = + let ctx = match ctx with + | Some ctx -> ctx + | None -> get_default () + in + match ctx with + | CairoContext ctx -> Backend_cairo.write ctx filename + | SVGContext _ -> raise (Unsupported_output_format "SVG context cannot render to PNG") + | LazyContext _ -> failwith "Lazy.writePNG ctx filename" + +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 _ -> failwith "SVG.writeSVG ctx" + | LazyContext _ -> failwith "Lazy.writeSVG ctx" -(* 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; - Cairo.Surface.finish ctx.surface - -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 resolution () = match !context with Some ctx -> ctx.size | None -> fail () -let scale_channel n = n /. 255. -let scale_color_channel = float_of_int >> scale_channel - -let set_color color = - match !context with - | Some ctx -> - let r, g, b = tmap3 scale_color_channel color in - Cairo.set_source_rgb ctx.ctx r g b - | None -> fail () - -(* sets background color *) -let background color = - match !context with - | Some { ctx; _ } -> - let r, g, b, alpha = tmap4 scale_color_channel color in - Cairo.set_source_rgb ctx r g b; - Cairo.paint ctx ~alpha; - Cairo.fill 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) - | 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 () - -let init_context background_color 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.set_line_width ctx line_width; - Cairo.translate ctx (w / 2 |> float_of_int) (h / 2 |> float_of_int); - context := Some { ctx; surface; size = (w, h); axes }; - background background_color diff --git a/lib/context.mli b/lib/context.mli index d9f36a9..01b57ec 100644 --- a/lib/context.mli +++ b/lib/context.mli @@ -1,20 +1,17 @@ -type context = { - ctx : Cairo.context; - surface : Cairo.Surface.t; - size : int * int; - axes : bool; -} +type context = + CairoContext of Backend_cairo.context + | SVGContext of Backend_svg.context + | LazyContext of Backend_lazy.context -val context : context option ref -val fail : unit -> unit +exception No_context +exception Unsupported_output_format of string -exception Context of string +val get_default : unit -> context +val set_default : context -> unit + +val show : ?ctx:context -> Shape.shapes -> unit +val set_line_width : ?ctx:context -> int -> unit + +val writeSVG : ?ctx:context -> string +val writePNG : ?ctx:context -> string -> unit -val init_context : int * int * int * int -> 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/joy.ml b/lib/joy.ml index 56ada20..0798b5f 100644 --- a/lib/joy.ml +++ b/lib/joy.ml @@ -3,19 +3,29 @@ include Shape include Transform include Color -let context = Context.context +module Backend_cairo = Backend_cairo +module Backend_svg = Backend_svg +module Backend_lazy = Backend_lazy + +type context = Context.context +let show = Context.show let set_line_width = Context.set_line_width -let init ?(background = Color.white) ?(line_width = 2) ?(size = (500, 500)) +(* let init ?(background = Color.white) ?(line_width = 2) ?(size = (500, 500)) ?(axes = false) () = Context.init_context (Color.opaque background) (float_of_int line_width) size - axes + axes *) + +let init ?(size = (500, 500)) ?(line_width = 2) ?(axes = false) _ = + let ctx = Backend_cairo.create ~background_color:Color.white ~size ~line_width ~axes in + let ctx_container = Context.CairoContext ctx in + Context.set_default ctx_container; + if axes then + let half_w, half_h = ctx.size |> Util.tmap float_of_int |> Util.tmap ((/.) 2.) in + let x_axis = line ~a:{x = -.half_w; y = 0.} {x = half_w; y = 0.} in + let y_axis = line ~a:{x = 0.; y = -.half_h} {x = 0.; y = half_h} in + show ~ctx:ctx_container [x_axis; y_axis] 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 () + Context.writePNG filename -let show shapes = Render.show shapes diff --git a/lib/joy.mli b/lib/joy.mli index fee45c5..8f36576 100644 --- a/lib/joy.mli +++ b/lib/joy.mli @@ -1,3 +1,8 @@ +module Backend_cairo = Backend_cairo +module Backend_svg = Backend_svg +module Backend_lazy = Backend_lazy + +type context = Context.context type 'a point = 'a Shape.point type shape = Shape.shape type shapes = Shape.shapes @@ -11,39 +16,34 @@ 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 with_stroke : color -> shape -> shape -val with_fill : color -> shape -> shape -val no_stroke : shape -> shape -val no_fill : shape -> 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 map_stroke : (color -> color) -> shape -> shape -val map_fill : (color -> color) -> shape -> shape + val random : ?min:int -> int -> int val frandom : ?min:float -> float -> float val noise : float list -> float val fractal_noise : ?octaves:int -> float list -> float -val context : Context.context option ref -val set_line_width : int -> unit + +val with_stroke : color -> transformation +val with_fill : color -> transformation +val map_stroke : (color -> color) -> transformation +val map_fill : (color -> color) -> transformation + val black : color val white : color val red : color val green : color val blue : color val yellow : color -val transparent : int * int * int * int -val opaque : color -> int * int * int * int - -val init : - ?background:color -> - ?line_width:int -> - ?size:int * int -> - ?axes:bool -> - unit -> - unit - -val show : shapes -> unit +val transparent : color +val rgb : int -> int -> int -> color + +val init : ?size:(int * int) -> ?line_width:int -> ?axes:bool -> unit -> unit val write : ?filename:string -> unit -> unit + +val show : ?ctx:context -> shapes -> unit +val set_line_width : ?ctx:context -> int -> unit diff --git a/lib/render.ml b/lib/render.ml deleted file mode 100644 index 42a7cbc..0000000 --- a/lib/render.ml +++ /dev/null @@ -1,89 +0,0 @@ -open Shape -open Context -open Util - -let draw_circle ctx ({ c; radius; stroke; fill } : circle) = - let stroke_circle stroke = - set_color stroke; - Cairo.stroke_preserve ctx.ctx - in - let fill_circle fill = - set_color fill; - Cairo.fill_preserve ctx.ctx - in - Cairo.arc ctx.ctx c.x (Float.neg c.y) ~r:radius ~a1:0. ~a2:(Float.pi *. 2.); - Option.iter stroke_circle stroke; - Option.iter fill_circle fill; - Cairo.Path.clear ctx.ctx - -let draw_ellipse ctx { c; rx; ry; stroke; fill } = - let stroke_ellipse stroke = - set_color stroke; - Cairo.stroke_preserve ctx.ctx - in - let fill_ellipse fill = - set_color fill; - Cairo.fill_preserve ctx.ctx - in - - (* Save the current transformation matrix *) - let save_matrix = Cairo.get_matrix ctx.ctx in - - (* Translate and scale to create an ellipse from a circle *) - Cairo.translate ctx.ctx c.x (Float.neg c.y); - Cairo.scale ctx.ctx rx ry; - Cairo.arc ctx.ctx 0. 0. ~r:1. ~a1:0. ~a2:(2. *. Float.pi); - - (* Restore the original transformation matrix *) - Cairo.set_matrix ctx.ctx save_matrix; - - Option.iter stroke_ellipse stroke; - Option.iter fill_ellipse fill; - Cairo.Path.clear ctx.ctx - -let draw_line ctx { a; b; stroke } = - set_color stroke; - let { x; y } = a in - Cairo.move_to ctx.ctx x (Float.neg y); - let { x; y } = b in - Cairo.line_to ctx.ctx x (Float.neg y); - Cairo.stroke ctx.ctx - -let draw_polygon ctx { vertices; stroke; fill } = - let stroke_rect stroke = - set_color stroke; - Cairo.stroke_preserve ctx.ctx - in - let fill_rect fill = - set_color fill; - Cairo.fill_preserve ctx.ctx - in - let { x; y }, t = (List.hd vertices, List.tl vertices) in - Cairo.move_to ctx.ctx x (Float.neg y); - List.iter - (fun { x = x'; y = y' } -> Cairo.line_to ctx.ctx x' (Float.neg y')) - t; - Cairo.Path.close ctx.ctx; - Option.iter stroke_rect stroke; - Option.iter fill_rect fill; - Cairo.Path.clear ctx.ctx - -(* Validates context before rendering *) -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 () = - 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 - show [ x_axis; y_axis ] diff --git a/lib/render.mli b/lib/render.mli deleted file mode 100644 index 87f72dd..0000000 --- a/lib/render.mli +++ /dev/null @@ -1,6 +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 show : Shape.shape list -> unit diff --git a/lib/shape.ml b/lib/shape.ml index d46f947..93a588b 100644 --- a/lib/shape.ml +++ b/lib/shape.ml @@ -5,22 +5,22 @@ type line = { a : float point; b : float point; stroke : color } type circle = { c : float point; radius : float; - stroke : color option; - fill : color option; + stroke : color; + fill : color; } type ellipse = { c : float point; rx : float; ry : float; - stroke : color option; - fill : color option; + stroke : color; + fill : color; } type polygon = { vertices : float point list; - stroke : color option; - fill : color option; + stroke : color; + fill : color; } type shape = @@ -36,15 +36,15 @@ let point x y = let x, y = (float_of_int x, float_of_int y) in { x; y } -let center = { x = 0.; y = 0. } +let origin = { x = 0.; y = 0. } -let circle ?(c = center) r = - Circle { c; radius = float_of_int r; stroke = Some Color.black; fill = None } +let circle ?(c = origin) r = + Circle { c; radius = float_of_int r; stroke = Color.black; fill = Color.transparent } let polygon vertices = - Polygon { vertices; stroke = Some Color.black; fill = None } + Polygon { vertices; stroke = Color.black; fill = Color.transparent } -let rectangle ?(c = center) width height = +let rectangle ?(c = origin) width height = let w, h = (float_of_int width, float_of_int height) in let x = c.x -. (w /. 2.) in let y = c.y -. (h /. 2.) in @@ -53,45 +53,28 @@ let rectangle ?(c = center) width height = { x; y }; { x; y = y +. h }; { x = x +. w; y = y +. h }; { x = x +. w; y }; ] -let ellipse ?(c = center) rx ry = +let ellipse ?(c = origin) rx ry = let rx, ry = (float_of_int rx, float_of_int ry) in - Ellipse { c; rx; ry; stroke = Some Color.black; fill = None } + Ellipse { c; rx; ry; stroke = Color.black; fill = Color.transparent } -let line ?(a = center) b = Line { a; b; stroke = Color.black } +let line ?(a = origin) b = Line { a; b; stroke = Color.black } let complex shapes = match shapes with _ :: _ -> Complex shapes | [] -> Complex [] let rec with_stroke stroke = function - | Circle circle' -> Circle { circle' with stroke = Some stroke } - | Ellipse ellipse' -> Ellipse { ellipse' with stroke = Some stroke } + | Circle circle' -> Circle { circle' with stroke = stroke } + | Ellipse ellipse' -> Ellipse { ellipse' with stroke = stroke } | Line line' -> Line { line' with stroke } - | Polygon polygon' -> Polygon { polygon' with stroke = Some stroke } + | Polygon polygon' -> Polygon { polygon' with stroke = stroke } | Complex complex' -> Complex (List.map (with_stroke stroke) complex') let rec with_fill fill = function - | Circle circle' -> Circle { circle' with fill = Some fill } - | Ellipse ellipse' -> Ellipse { ellipse' with fill = Some fill } - | Polygon polygon' -> Polygon { polygon' with fill = Some fill } + | Circle circle' -> Circle { circle' with fill } + | Ellipse ellipse' -> Ellipse { ellipse' with fill } + | Polygon polygon' -> Polygon { polygon' with fill } | Complex complex' -> Complex (List.map (with_fill fill) complex') | _ as line' -> print_endline "lines do not have a fill field!"; line' -let rec no_stroke = function - | Circle circle' -> Circle { circle' with stroke = None } - | Ellipse ellipse' -> Ellipse { ellipse' with stroke = None } - | Polygon polygon' -> Polygon { polygon' with stroke = None } - | Complex complex' -> Complex (List.map no_stroke complex') - | _ as line' -> - print_endline "Cannot remove stroke from lines"; - line' - -let rec no_fill = function - | Circle circle' -> Circle { circle' with fill = None } - | Ellipse ellipse' -> Ellipse { ellipse' with fill = None } - | Polygon polygon' -> Polygon { polygon' with fill = None } - | Complex complex' -> Complex (List.map no_fill complex') - | _ as line' -> - print_endline "Lines do not have a fill field!"; - line' diff --git a/lib/shape.mli b/lib/shape.mli index 692a488..5f7c113 100644 --- a/lib/shape.mli +++ b/lib/shape.mli @@ -4,22 +4,22 @@ type 'a point = { x : 'a; y : 'a } type circle = { c : float point; radius : float; - stroke : color option; - fill : color option; + stroke : color; + fill : color; } type ellipse = { c : float point; rx : float; ry : float; - stroke : color option; - fill : color option; + stroke : color; + fill : color; } type polygon = { vertices : float point list; - stroke : color option; - fill : color option; + stroke : color; + fill : color; } type line = { a : float point; b : float point; stroke : color } @@ -42,5 +42,3 @@ val line : ?a:float point -> float point -> shape val polygon : float point list -> shape val with_stroke : color -> shape -> shape val with_fill : color -> shape -> shape -val no_stroke : shape -> shape -val no_fill : shape -> shape diff --git a/lib/transform.ml b/lib/transform.ml index b2850ce..9c1e981 100644 --- a/lib/transform.ml +++ b/lib/transform.ml @@ -107,20 +107,20 @@ let repeat n op shape = function applied to the original's color *) let rec map_stroke f = function | Circle circle' -> - Circle { circle' with stroke = Option.map f circle'.stroke } + Circle { circle' with stroke = f circle'.stroke } | Ellipse ellipse' -> - Ellipse { ellipse' with stroke = Option.map f ellipse'.stroke } + Ellipse { ellipse' with stroke = f ellipse'.stroke } | Line line' -> Line { line' with stroke = f line'.stroke } | Polygon polygon' -> - Polygon { polygon' with stroke = Option.map f polygon'.stroke } + Polygon { polygon' with stroke = f polygon'.stroke } | Complex complex' -> Complex (List.map (map_stroke f) complex') let rec map_fill f = function - | Circle circle' -> Circle { circle' with fill = Option.map f circle'.fill } + | Circle circle' -> Circle { circle' with fill = f circle'.fill } | Ellipse ellipse' -> - Ellipse { ellipse' with fill = Option.map f ellipse'.fill } + Ellipse { ellipse' with fill = f ellipse'.fill } | Polygon polygon' -> - Polygon { polygon' with fill = Option.map f polygon'.fill } + Polygon { polygon' with fill = f polygon'.fill } | Complex complex' -> Complex (List.map (map_fill f) complex') | _ as line' -> print_endline "Lines do not have a fill field!"; From 4a67b5653487771abc1d7095e3fdb828c520c306 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 11:09:58 +0530 Subject: [PATCH 2/9] Remove axes from square --- examples/square.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/square.ml b/examples/square.ml index 9c68a08..542788c 100644 --- a/examples/square.ml +++ b/examples/square.ml @@ -1,7 +1,7 @@ open Joy let () = - init ~axes:true (); + init (); let square = rectangle 100 100 in show [ square ]; write ~filename:"square.png" () From 9f30f1de0d5dea707cd8399beb1b22ffec081f48 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 11:27:29 +0530 Subject: [PATCH 3/9] Fix bug with rendering axes --- examples/dune | 5 +++++ examples/line.ml | 24 ++++++------------------ examples/parallel_lines.ml | 22 ++++++++++++++++++++++ lib/color.ml | 2 ++ lib/color.mli | 1 + lib/joy.ml | 12 ++++-------- 6 files changed, 40 insertions(+), 26 deletions(-) create mode 100644 examples/parallel_lines.ml diff --git a/examples/dune b/examples/dune index 47a75b9..a88c9b8 100644 --- a/examples/dune +++ b/examples/dune @@ -53,6 +53,11 @@ (modules line) (libraries joy)) +(executable + (name parallel_lines) + (modules parallel_lines) + (libraries joy)) + (executable (name higher_transforms) (modules higher_transforms) diff --git a/examples/line.ml b/examples/line.ml index 2c250c1..d735b8c 100644 --- a/examples/line.ml +++ b/examples/line.ml @@ -1,22 +1,10 @@ open Joy -let size = 800 -let interval = 16 -let line_interval = 800 / interval -let rec range a b = if a > b then [] else a :: range (a + 1) b -let inc x = x + 1 - let _ = - init ~size:(size, size) (); - let half_size = size / 2 in - let lines = - List.map - (fun i -> - let newx = i |> inc |> ( * ) line_interval in - line - ~a:(point (newx - half_size) (-half_size)) - (point (newx - half_size) half_size)) - (range 0 interval) - in - show lines; + init (); + let l1 = line (point 50 50) in + let l2 = line (point (-50) 50) in + let l3 = line ~a:(point (-50) 50) (point 50 50) in + show [l1; l2; l3]; write ~filename:"line.png" () + diff --git a/examples/parallel_lines.ml b/examples/parallel_lines.ml new file mode 100644 index 0000000..a557726 --- /dev/null +++ b/examples/parallel_lines.ml @@ -0,0 +1,22 @@ +open Joy + +let size = 800 +let interval = 16 +let line_interval = 800 / interval +let rec range a b = if a > b then [] else a :: range (a + 1) b +let inc x = x + 1 + +let _ = + init ~size:(size, size) (); + let half_size = size / 2 in + let lines = + List.map + (fun i -> + let newx = i |> inc |> ( * ) line_interval in + line + ~a:(point (newx - half_size) (-half_size)) + (point (newx - half_size) half_size)) + (range 0 interval) + in + show lines; + write ~filename:"parallel_lines.png" () diff --git a/lib/color.ml b/lib/color.ml index 0b5838b..c7121d3 100644 --- a/lib/color.ml +++ b/lib/color.ml @@ -7,6 +7,8 @@ let transparent = (0, 0, 0, 0.0) For use w/ `Context.background` *) let rgb r g b = (r, g, b, 1.0) +let color ?(a = 1.0) r g b = (r, g, b, a) + (** RGB code for black *) let black = rgb 0 0 0 diff --git a/lib/color.mli b/lib/color.mli index 0e0496b..3a252dd 100644 --- a/lib/color.mli +++ b/lib/color.mli @@ -1,6 +1,7 @@ type color = int * int * int * float val rgb : int -> int -> int -> color +val color : ?a:float -> int -> int -> int -> color val black : color val white : color diff --git a/lib/joy.ml b/lib/joy.ml index 0798b5f..9019a0a 100644 --- a/lib/joy.ml +++ b/lib/joy.ml @@ -11,19 +11,15 @@ type context = Context.context let show = Context.show let set_line_width = Context.set_line_width -(* let init ?(background = Color.white) ?(line_width = 2) ?(size = (500, 500)) - ?(axes = false) () = - Context.init_context (Color.opaque background) (float_of_int line_width) size - axes *) - let init ?(size = (500, 500)) ?(line_width = 2) ?(axes = false) _ = let ctx = Backend_cairo.create ~background_color:Color.white ~size ~line_width ~axes in let ctx_container = Context.CairoContext ctx in Context.set_default ctx_container; if axes then - let half_w, half_h = ctx.size |> Util.tmap float_of_int |> Util.tmap ((/.) 2.) in - let x_axis = line ~a:{x = -.half_w; y = 0.} {x = half_w; y = 0.} in - let y_axis = line ~a:{x = 0.; y = -.half_h} {x = 0.; y = half_h} in + let half_w, half_h = ctx.size |> Util.tmap float_of_int |> Util.tmap (fun x -> x /. 2.0) in + let gray = Color.color 128 128 128 ~a:0.5 in + let x_axis = line ~a:{x = -.half_w; y = 0.} {x = half_w; y = 0.} |> with_stroke gray in + let y_axis = line ~a:{x = 0.; y = -.half_h} {x = 0.; y = half_h} |> with_stroke gray in show ~ctx:ctx_container [x_axis; y_axis] let write ?(filename = "joy.png") () = From 96625350c6d8fc9716f2ee8c2f9597f57bd25616 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 11:32:53 +0530 Subject: [PATCH 4/9] Add comment for axes.ml --- examples/axes.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/axes.ml b/examples/axes.ml index c12bbc5..1aee6d5 100644 --- a/examples/axes.ml +++ b/examples/axes.ml @@ -2,6 +2,7 @@ open Joy let _ = + (* intialize rendering context with the axes flag set to true *) init ~axes:true (); let c = circle 50 in show [ c ]; From 137f49e115ad8da00d6afe6f0eda5aeb666700e4 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 11:38:48 +0530 Subject: [PATCH 5/9] Run dune fmt --- examples/fill_rect.ml | 1 - examples/line.ml | 3 +-- lib/backend_cairo.ml | 35 ++++++++++++++++++----------------- lib/backend_cairo.mli | 11 ++++++++--- lib/backend_lazy.ml | 1 - lib/color.mli | 1 - lib/context.ml | 37 +++++++++++-------------------------- lib/context.mli | 5 +---- lib/joy.ml | 26 +++++++++++++++++--------- lib/joy.mli | 8 +------- lib/shape.ml | 29 ++++++++++++----------------- lib/shape.mli | 15 ++------------- lib/transform.ml | 33 +++++++++++++++++---------------- 13 files changed, 88 insertions(+), 117 deletions(-) diff --git a/examples/fill_rect.ml b/examples/fill_rect.ml index 5ca19b3..bfafecc 100644 --- a/examples/fill_rect.ml +++ b/examples/fill_rect.ml @@ -5,4 +5,3 @@ let () = let r = rectangle 200 200 |> with_fill (rgb 255 0 0) in show [ r ]; write ~filename:"fill-rect.png" () - diff --git a/examples/line.ml b/examples/line.ml index d735b8c..68c3798 100644 --- a/examples/line.ml +++ b/examples/line.ml @@ -5,6 +5,5 @@ let _ = let l1 = line (point 50 50) in let l2 = line (point (-50) 50) in let l3 = line ~a:(point (-50) 50) (point 50 50) in - show [l1; l2; l3]; + show [ l1; l2; l3 ]; write ~filename:"line.png" () - diff --git a/lib/backend_cairo.ml b/lib/backend_cairo.ml index 336feac..38a8f69 100644 --- a/lib/backend_cairo.ml +++ b/lib/backend_cairo.ml @@ -2,8 +2,8 @@ type context = { cairo_ctx : Cairo.context; surface : Cairo.Surface.t; size : int * int; - background_color: int * int * int * float; - axes: bool; + background_color : int * int * int * float; + axes : bool; } let write ctx filename = @@ -11,14 +11,14 @@ let write ctx filename = Cairo.Surface.finish ctx.surface let set_color ctx color = - let to_float i = (float_of_int i) /. 255. in + 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 r, g, b, a = color in - let to_float i = (float_of_int i) /. 255. 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; @@ -68,9 +68,7 @@ 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; + 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; @@ -79,15 +77,19 @@ let draw_polygon ctx vertices stroke fill = 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.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.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.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 @@ -101,4 +103,3 @@ let create ~background_color ~line_width ~size ~axes = set_background ctx background_color; set_line_width ctx line_width; ctx - diff --git a/lib/backend_cairo.mli b/lib/backend_cairo.mli index 3a67e8f..b6b23e5 100644 --- a/lib/backend_cairo.mli +++ b/lib/backend_cairo.mli @@ -2,8 +2,8 @@ type context = { cairo_ctx : Cairo.context; surface : Cairo.Surface.t; size : int * int; - background_color: Color.color; - axes: bool; + background_color : Color.color; + axes : bool; } val set_color : context -> Color.color -> unit @@ -12,4 +12,9 @@ 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 create : + background_color:Color.color -> + line_width:int -> + size:int * int -> + axes:bool -> + context diff --git a/lib/backend_lazy.ml b/lib/backend_lazy.ml index e2d719e..e0c304c 100644 --- a/lib/backend_lazy.ml +++ b/lib/backend_lazy.ml @@ -2,4 +2,3 @@ type context = unit let show _ctx _shapes = () let create _ = () - diff --git a/lib/color.mli b/lib/color.mli index 3a252dd..8984bac 100644 --- a/lib/color.mli +++ b/lib/color.mli @@ -2,7 +2,6 @@ type color = int * int * int * float val rgb : int -> int -> int -> color val color : ?a:float -> int -> int -> int -> color - val black : color val white : color val red : color diff --git a/lib/context.ml b/lib/context.ml index 6fcc83d..876a3db 100644 --- a/lib/context.ml +++ b/lib/context.ml @@ -1,5 +1,5 @@ type context = - CairoContext of Backend_cairo.context + | CairoContext of Backend_cairo.context | SVGContext of Backend_svg.context | LazyContext of Backend_lazy.context @@ -7,50 +7,35 @@ exception No_context exception Unsupported_output_format of string let default = ref (LazyContext (Backend_lazy.create ())) - -let get_default _ = - !default - -let set_default ctx = - default := ctx +let get_default _ = !default +let set_default ctx = default := ctx let show ?ctx shapes = - let ctx = match ctx with - | Some ctx -> ctx - | None -> get_default () - in + 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 set_line_width ?ctx int = - let ctx = match ctx with - | Some ctx -> ctx - | None -> get_default () - in + let ctx = match ctx with Some ctx -> ctx | None -> get_default () in match ctx with | CairoContext ctx -> Backend_cairo.set_line_width ctx int | SVGContext _ -> failwith "SVG.set_line_width ctx int" | LazyContext _ -> failwith "Backend_lazy.set_line_width ctx int" let writePNG ?ctx filename = - let ctx = match ctx with - | Some ctx -> ctx - | None -> get_default () - in + let ctx = match ctx with Some ctx -> ctx | None -> get_default () in match ctx with | CairoContext ctx -> Backend_cairo.write ctx filename - | SVGContext _ -> raise (Unsupported_output_format "SVG context cannot render to PNG") + | SVGContext _ -> + raise (Unsupported_output_format "SVG context cannot render to PNG") | LazyContext _ -> failwith "Lazy.writePNG ctx filename" let writeSVG ?ctx = - let ctx = match ctx with - | Some ctx -> ctx - | None -> get_default () - in + 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") + | CairoContext _ -> + raise (Unsupported_output_format "Cairo context cannot render to SVG") | SVGContext _ -> failwith "SVG.writeSVG ctx" | LazyContext _ -> failwith "Lazy.writeSVG ctx" - diff --git a/lib/context.mli b/lib/context.mli index 01b57ec..d789c84 100644 --- a/lib/context.mli +++ b/lib/context.mli @@ -1,5 +1,5 @@ type context = - CairoContext of Backend_cairo.context + | CairoContext of Backend_cairo.context | SVGContext of Backend_svg.context | LazyContext of Backend_lazy.context @@ -8,10 +8,7 @@ exception Unsupported_output_format of string val get_default : unit -> context val set_default : context -> unit - val show : ?ctx:context -> Shape.shapes -> unit val set_line_width : ?ctx:context -> int -> unit - val writeSVG : ?ctx:context -> string val writePNG : ?ctx:context -> string -> unit - diff --git a/lib/joy.ml b/lib/joy.ml index 9019a0a..bc163c8 100644 --- a/lib/joy.ml +++ b/lib/joy.ml @@ -2,26 +2,34 @@ include Random include Shape include Transform include Color - module Backend_cairo = Backend_cairo module Backend_svg = Backend_svg module Backend_lazy = Backend_lazy type context = Context.context + let show = Context.show let set_line_width = Context.set_line_width let init ?(size = (500, 500)) ?(line_width = 2) ?(axes = false) _ = - let ctx = Backend_cairo.create ~background_color:Color.white ~size ~line_width ~axes in + let ctx = + Backend_cairo.create ~background_color:Color.white ~size ~line_width ~axes + in let ctx_container = Context.CairoContext ctx in Context.set_default ctx_container; if axes then - let half_w, half_h = ctx.size |> Util.tmap float_of_int |> Util.tmap (fun x -> x /. 2.0) in + let half_w, half_h = + ctx.size |> Util.tmap float_of_int |> Util.tmap (fun x -> x /. 2.0) + in let gray = Color.color 128 128 128 ~a:0.5 in - let x_axis = line ~a:{x = -.half_w; y = 0.} {x = half_w; y = 0.} |> with_stroke gray in - let y_axis = line ~a:{x = 0.; y = -.half_h} {x = 0.; y = half_h} |> with_stroke gray in - show ~ctx:ctx_container [x_axis; y_axis] - -let write ?(filename = "joy.png") () = - Context.writePNG filename + let x_axis = + line ~a:{ x = -.half_w; y = 0. } { x = half_w; y = 0. } + |> with_stroke gray + in + let y_axis = + line ~a:{ x = 0.; y = -.half_h } { x = 0.; y = half_h } + |> with_stroke gray + in + show ~ctx:ctx_container [ x_axis; y_axis ] +let write ?(filename = "joy.png") () = Context.writePNG filename diff --git a/lib/joy.mli b/lib/joy.mli index 8f36576..1b7be45 100644 --- a/lib/joy.mli +++ b/lib/joy.mli @@ -16,23 +16,19 @@ 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 random : ?min:int -> int -> int val frandom : ?min:float -> float -> float val noise : float list -> float val fractal_noise : ?octaves:int -> float list -> float - val with_stroke : color -> transformation val with_fill : color -> transformation val map_stroke : (color -> color) -> transformation val map_fill : (color -> color) -> transformation - val black : color val white : color val red : color @@ -41,9 +37,7 @@ val blue : color val yellow : color val transparent : color val rgb : int -> int -> int -> color - -val init : ?size:(int * int) -> ?line_width:int -> ?axes:bool -> unit -> unit +val init : ?size:int * int -> ?line_width:int -> ?axes:bool -> unit -> unit val write : ?filename:string -> unit -> unit - val show : ?ctx:context -> shapes -> unit val set_line_width : ?ctx:context -> int -> unit diff --git a/lib/shape.ml b/lib/shape.ml index 93a588b..c804238 100644 --- a/lib/shape.ml +++ b/lib/shape.ml @@ -1,13 +1,7 @@ type 'a point = { x : 'a; y : 'a } type color = Color.color type line = { a : float point; b : float point; stroke : color } - -type circle = { - c : float point; - radius : float; - stroke : color; - fill : color; -} +type circle = { c : float point; radius : float; stroke : color; fill : color } type ellipse = { c : float point; @@ -17,11 +11,7 @@ type ellipse = { fill : color; } -type polygon = { - vertices : float point list; - stroke : color; - fill : color; -} +type polygon = { vertices : float point list; stroke : color; fill : color } type shape = | Circle of circle @@ -39,7 +29,13 @@ let point x y = let origin = { x = 0.; y = 0. } let circle ?(c = origin) r = - Circle { c; radius = float_of_int r; stroke = Color.black; fill = Color.transparent } + Circle + { + c; + radius = float_of_int r; + stroke = Color.black; + fill = Color.transparent; + } let polygon vertices = Polygon { vertices; stroke = Color.black; fill = Color.transparent } @@ -63,10 +59,10 @@ let complex shapes = match shapes with _ :: _ -> Complex shapes | [] -> Complex [] let rec with_stroke stroke = function - | Circle circle' -> Circle { circle' with stroke = stroke } - | Ellipse ellipse' -> Ellipse { ellipse' with stroke = stroke } + | Circle circle' -> Circle { circle' with stroke } + | Ellipse ellipse' -> Ellipse { ellipse' with stroke } | Line line' -> Line { line' with stroke } - | Polygon polygon' -> Polygon { polygon' with stroke = stroke } + | Polygon polygon' -> Polygon { polygon' with stroke } | Complex complex' -> Complex (List.map (with_stroke stroke) complex') let rec with_fill fill = function @@ -77,4 +73,3 @@ let rec with_fill fill = function | _ as line' -> print_endline "lines do not have a fill field!"; line' - diff --git a/lib/shape.mli b/lib/shape.mli index 5f7c113..d0a01a5 100644 --- a/lib/shape.mli +++ b/lib/shape.mli @@ -1,12 +1,6 @@ type color = Color.color type 'a point = { x : 'a; y : 'a } - -type circle = { - c : float point; - radius : float; - stroke : color; - fill : color; -} +type circle = { c : float point; radius : float; stroke : color; fill : color } type ellipse = { c : float point; @@ -16,12 +10,7 @@ type ellipse = { fill : color; } -type polygon = { - vertices : float point list; - stroke : color; - fill : color; -} - +type polygon = { vertices : float point list; stroke : color; fill : color } type line = { a : float point; b : float point; stroke : color } type shape = diff --git a/lib/transform.ml b/lib/transform.ml index 9c1e981..fa71aa2 100644 --- a/lib/transform.ml +++ b/lib/transform.ml @@ -50,11 +50,11 @@ let rec scale factor = function } | Line line' -> Line - { - line' with - a = Util.pmap (scale_length factor) line'.a; - b = Util.pmap (scale_length factor) line'.b; - } + { + line' with + a = Util.pmap (scale_length factor) line'.a; + b = Util.pmap (scale_length factor) line'.b; + } | Polygon polygon' -> Polygon { @@ -83,7 +83,13 @@ let rec rotate degrees = function | Circle circle' -> Circle { circle' with c = rotate_point degrees circle'.c } | Ellipse ellipse' -> Ellipse { ellipse' with c = rotate_point degrees ellipse'.c } - | Line line' -> Line { line' with a = rotate_point degrees line'.a; b = rotate_point degrees line'.b } + | Line line' -> + Line + { + line' with + a = rotate_point degrees line'.a; + b = rotate_point degrees line'.b; + } | Polygon polygon' -> Polygon { @@ -106,21 +112,16 @@ let repeat n op shape = (** Takes a function and a shape and returns a new shape with the function applied to the original's color *) let rec map_stroke f = function - | Circle circle' -> - Circle { circle' with stroke = f circle'.stroke } - | Ellipse ellipse' -> - Ellipse { ellipse' with stroke = f ellipse'.stroke } + | Circle circle' -> Circle { circle' with stroke = f circle'.stroke } + | Ellipse ellipse' -> Ellipse { ellipse' with stroke = f ellipse'.stroke } | Line line' -> Line { line' with stroke = f line'.stroke } - | Polygon polygon' -> - Polygon { polygon' with stroke = f polygon'.stroke } + | Polygon polygon' -> Polygon { polygon' with stroke = f polygon'.stroke } | Complex complex' -> Complex (List.map (map_stroke f) complex') let rec map_fill f = function | Circle circle' -> Circle { circle' with fill = f circle'.fill } - | Ellipse ellipse' -> - Ellipse { ellipse' with fill = f ellipse'.fill } - | Polygon polygon' -> - Polygon { polygon' with fill = f polygon'.fill } + | Ellipse ellipse' -> Ellipse { ellipse' with fill = f ellipse'.fill } + | Polygon polygon' -> Polygon { polygon' with fill = f polygon'.fill } | Complex complex' -> Complex (List.map (map_fill f) complex') | _ as line' -> print_endline "Lines do not have a fill field!"; From 292e9d65919108b09a561a39724fa9030ee2959e Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 11:41:51 +0530 Subject: [PATCH 6/9] Default line_width to 1 for cairo --- lib/backend_cairo.ml | 3 +-- lib/joy.ml | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/backend_cairo.ml b/lib/backend_cairo.ml index 38a8f69..aea5c3e 100644 --- a/lib/backend_cairo.ml +++ b/lib/backend_cairo.ml @@ -25,8 +25,7 @@ let set_background ctx color = 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. - default is 2 *) + 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) diff --git a/lib/joy.ml b/lib/joy.ml index bc163c8..d8c19eb 100644 --- a/lib/joy.ml +++ b/lib/joy.ml @@ -11,7 +11,7 @@ type context = Context.context let show = Context.show let set_line_width = Context.set_line_width -let init ?(size = (500, 500)) ?(line_width = 2) ?(axes = false) _ = +let init ?(size = (500, 500)) ?(line_width = 1) ?(axes = false) _ = let ctx = Backend_cairo.create ~background_color:Color.white ~size ~line_width ~axes in From 0caf3fab43d4c40ecd26df213b76511bf5a476d1 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 11:51:06 +0530 Subject: [PATCH 7/9] Remove stale comment for backend_cairo.ml --- lib/backend_cairo.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/backend_cairo.ml b/lib/backend_cairo.ml index aea5c3e..f592f3b 100644 --- a/lib/backend_cairo.ml +++ b/lib/backend_cairo.ml @@ -30,7 +30,6 @@ 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 = - (* TODO: stroke and fill MUST have a value before coming to the renderer *) 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; From c01733002e6d9de18ee208b72ba250a89be99606 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 12:11:48 +0530 Subject: [PATCH 8/9] Run dune fmt --- examples/smile.ml | 41 ++++++++++++++++++++--------------------- lib/shape.ml | 3 ++- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/examples/smile.ml b/examples/smile.ml index 89ca1d3..85f2842 100644 --- a/examples/smile.ml +++ b/examples/smile.ml @@ -1,27 +1,26 @@ open Joy let make_nose () = - let l = line (point 0 50)|> translate 0 (-25) in - let l1 = l in - let l2 = l |> rotate 90|> translate 0 (-25) in - let nose = complex [l1; l2] in - nose + let l = line (point 0 50) |> translate 0 (-25) in + let l1 = l in + let l2 = l |> rotate 90 |> translate 0 (-25) in + let nose = complex [ l1; l2 ] in + nose -let make_arc rx ry = - let r = rectangle ~c:(point 0 (ry / 2)) (2 * rx) ry in - let col = r |> with_fill white |> with_stroke white in - let e = ellipse ~c:(point 0 0) rx ry in - complex [e; col] +let make_arc rx ry = + let r = rectangle ~c:(point 0 (ry / 2)) (2 * rx) ry in + let col = r |> with_fill white |> with_stroke white in + let e = ellipse ~c:(point 0 0) rx ry in + complex [ e; col ] let () = - init (); - let a = circle 200 in - let d = circle ~c:(point 50 50) 20 in - let b = circle ~c:(point (-50) 50) 20 in - let nose = make_nose () in - let leb = make_arc 26 14 |> rotate 180 |> translate 50 70 in - let reb = make_arc 26 14 |> rotate 180 |> translate (-50) 70 in - let mouth = make_arc 80 40 |>translate 0 (-60) in - show [mouth;leb;reb;a;d;b;nose]; - write () - + init (); + let a = circle 200 in + let d = circle ~c:(point 50 50) 20 in + let b = circle ~c:(point (-50) 50) 20 in + let nose = make_nose () in + let leb = make_arc 26 14 |> rotate 180 |> translate 50 70 in + let reb = make_arc 26 14 |> rotate 180 |> translate (-50) 70 in + let mouth = make_arc 80 40 |> translate 0 (-60) in + show [ mouth; leb; reb; a; d; b; nose ]; + write () diff --git a/lib/shape.ml b/lib/shape.ml index 50451b5..7c6fc3e 100644 --- a/lib/shape.ml +++ b/lib/shape.ml @@ -52,7 +52,8 @@ let rectangle ?(c = origin) width height = let ellipse ?(c = origin) rx ry = let rx, ry = (float_of_int rx, float_of_int ry) in - Ellipse { c; rx; ry; stroke = Color.black; fill = Color.transparent; rotation = 0. } + Ellipse + { c; rx; ry; stroke = Color.black; fill = Color.transparent; rotation = 0. } let line ?(a = origin) b = Line { a; b; stroke = Color.black } From 069d525a16e384196fccb1a0edc6c2148761b891 Mon Sep 17 00:00:00 2001 From: Kaustubh Maske Patil <37668193+nikochiko@users.noreply.github.com> Date: Tue, 12 Mar 2024 12:12:44 +0530 Subject: [PATCH 9/9] Re-add base to joy.opam --- joy.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/joy.opam b/joy.opam index c5bfbd8..632ce28 100644 --- a/joy.opam +++ b/joy.opam @@ -12,6 +12,7 @@ depends: [ "dune" {>= "3.10"} "graphics" "cairo2" + "base" "odoc" {with-doc} ] build: [