diff --git a/lib/context.ml b/lib/context.ml index beaf4b0..f380448 100644 --- a/lib/context.ml +++ b/lib/context.ml @@ -1,3 +1,5 @@ +open Util + (* Global rendering context singleton definition and instantiation *) type context = { ctx : Cairo.context; @@ -22,9 +24,6 @@ let () = let fail () = raise (Context "not initialized") 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_channel n = n /. 255. let scale_color_channel = float_of_int >> scale_channel @@ -59,14 +58,14 @@ let save () = let restore () = match !context with Some ctx -> Cairo.restore ctx.ctx | None -> fail () -let init_context background_color line_width (x, y) axes = +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:x ~h:y in + let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w ~h in let ctx = Cairo.create surface in - Cairo.scale ctx (float_of_int x) (float_of_int y); Cairo.set_line_width ctx line_width; - context := Some { ctx; surface; size = (x, y); axes }; + 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/joy.ml b/lib/joy.ml index 99d5a9a..c2f3b4e 100644 --- a/lib/joy.ml +++ b/lib/joy.ml @@ -3,13 +3,13 @@ include Transform include Color let context = Context.context + 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 /. 1000.) - size axes + Context.init_context (Color.opaque background) (float_of_int line_width) size + axes let write ?(filename = "joy.png") () = match !Context.context with diff --git a/lib/joy.mli b/lib/joy.mli index 1b12f04..2037066 100644 --- a/lib/joy.mli +++ b/lib/joy.mli @@ -13,6 +13,8 @@ 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 diff --git a/lib/render.ml b/lib/render.ml index 4723ba0..76ffa54 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -1,14 +1,6 @@ open Shape open Context - -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. +open Util let draw_circle ctx ({ c; radius; stroke; fill } : circle) = let stroke_circle stroke = @@ -19,20 +11,14 @@ let draw_circle ctx ({ c; radius; stroke; fill } : circle) = set_color fill; Cairo.fill_preserve ctx.ctx in - let size = tmap float_of_int ctx.size in - let x, y = denormalize c in - let radius = radius /. euclid_norm size in - save (); - Cairo.arc ctx.ctx x y ~r:radius ~a1:0. ~a2:(Float.pi *. 2.); + Cairo.arc ctx.ctx c.x c.y ~r:radius ~a1:0. ~a2:(Float.pi *. 2.); Option.iter stroke_circle stroke; Option.iter fill_circle fill; - restore () + Cairo.Path.clear 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 +let create_control_points ({ x; y }, rx, ry) = + let half_height = ry /. 2. in + let width_two_thirds = rx *. (2. /. 3.) *. 2. in ( { x; y = y -. half_height }, ( x +. width_two_thirds, y -. half_height, @@ -56,7 +42,6 @@ let draw_ellipse ctx { c; rx; ry; stroke; fill } = set_color fill; Cairo.fill_preserve ctx.ctx in - save (); let start, curve_one, curve_two = create_control_points (c, rx, ry) in Cairo.move_to ctx.ctx start.x start.y; let x1, y1, x2, y2, x3, y3 = curve_one in @@ -65,39 +50,18 @@ let draw_ellipse ctx { c; rx; ry; stroke; fill } = Cairo.curve_to ctx.ctx x1 y1 x2 y2 x3 y3; Option.iter stroke_ellipse stroke; Option.iter fill_ellipse fill; - restore () + Cairo.Path.clear ctx.ctx let draw_line ctx { a; b; stroke } = - save (); - let x1, y1 = denormalize a in - let x2, y2 = denormalize b in set_color stroke; - Cairo.move_to ctx.ctx x1 y1; - Cairo.line_to ctx.ctx x2 y2; - Cairo.stroke ctx.ctx + let { x; y } = a in + Cairo.move_to ctx.ctx x y; + let { x; y } = b in + Cairo.line_to ctx.ctx x y; + Cairo.stroke ctx.ctx; + Cairo.Path.clear ctx.ctx -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 { vertices = points; stroke; fill } = +let draw_polygon ctx { vertices; stroke; fill } = let stroke_rect stroke = set_color stroke; Cairo.stroke_preserve ctx.ctx @@ -106,8 +70,7 @@ let draw_polygon ctx { vertices = points; stroke; fill } = set_color fill; Cairo.fill_preserve ctx.ctx in - let points = partition 2 ~step:1 (points @ [ List.hd points ]) in - save (); + let points = partition 2 ~step:1 (vertices @ [ List.hd vertices ]) in List.iter (fun pair -> let { x = x1; y = y1 }, { x = x2; y = y2 } = @@ -118,26 +81,25 @@ let draw_polygon ctx { vertices = points; stroke; fill } = points; Option.iter stroke_rect stroke; Option.iter fill_rect fill; - restore () + Cairo.Path.clear 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 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_shape ctx) shapes + | Some ctx -> List.iter (render ctx) shapes | None -> fail () let render_axes () = - print_endline "rendering 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 ] diff --git a/lib/render.mli b/lib/render.mli index c4c7e03..87f72dd 100644 --- a/lib/render.mli +++ b/lib/render.mli @@ -3,6 +3,4 @@ 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/shape.ml b/lib/shape.ml index 52a066a..758b6d5 100644 --- a/lib/shape.ml +++ b/lib/shape.ml @@ -32,15 +32,6 @@ type shape = type shapes = shape list -(* point -> point arithmetic *) -let ( /~ ) p1 p2 = { x = p1.x /. p2.x; y = p1.x /. p2.x } - -(* point -> scalar arithmetic *) -let ( -! ) { x; y } scalar = { x = x -. scalar; y = y -. scalar } -let ( /! ) { x; y } scalar = { x = x /. scalar; y = y /. scalar } -let ( *! ) { x; y } scalar = { x = x *. scalar; y = y *. scalar } -let pmap f { x; y } = { x = f x; y = f y } - let point x y = let x, y = (float_of_int x, float_of_int y) in { x; y } @@ -55,14 +46,14 @@ let polygon vertices = let rectangle ?(c = center) width height = let w, h = (float_of_int width, float_of_int height) in - let x1 = c.x -. (w /. 2.) in - let y1 = c.x -. (h /. 2.) in + let x = c.x -. (w /. 2.) in + let y = c.y -. (h /. 2.) in polygon [ - { x = x1; y = y1 }; - { x = x1; y = y1 +. h }; - { x = x1 +. w; y = y1 +. h }; - { x = x1 +. w; y = y1 }; + { x; y }; + { x; y = y +. h }; + { x = x +. w; y = y +. h }; + { x = x +. w; y }; ] let ellipse ?(c = center) rx ry = @@ -89,3 +80,21 @@ let rec with_fill fill = function | _ 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 37bce24..692a488 100644 --- a/lib/shape.mli +++ b/lib/shape.mli @@ -34,11 +34,6 @@ type shape = type shapes = shape list val point : int -> int -> float point -val ( /~ ) : float point -> float point -> float point -val ( -! ) : float point -> float -> float point -val ( /! ) : float point -> float -> float point -val ( *! ) : float point -> float -> float point -val pmap : ('a -> 'b) -> 'a point -> 'b point val circle : ?c:float point -> int -> shape val rectangle : ?c:float point -> int -> int -> shape val ellipse : ?c:float point -> int -> int -> shape @@ -47,3 +42,5 @@ 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 536f936..7d27da0 100644 --- a/lib/transform.ml +++ b/lib/transform.ml @@ -31,21 +31,19 @@ let rec translate dx dy = function | Complex shapes -> Complex (List.map (translate dx dy) shapes) let scale_length fact len = len *. fact -let pmap f { x; y } = { x = f x; y = f y } - let rec scale factor = function | Circle circle' -> Circle { circle' with - c = pmap (scale_length factor) circle'.c; + c = Util.pmap (scale_length factor) circle'.c; radius = scale_length factor circle'.radius; } | Ellipse ellipse' -> Ellipse { ellipse' with - c = pmap (scale_length factor) ellipse'.c; + c = Util.pmap (scale_length factor) ellipse'.c; rx = scale_length factor ellipse'.rx; ry = scale_length factor ellipse'.ry; } @@ -54,7 +52,7 @@ let rec scale factor = function Polygon { polygon' with - vertices = List.map (pmap (scale_length factor)) polygon'.vertices; + vertices = List.map (Util.pmap (scale_length factor)) polygon'.vertices; } | Complex shapes -> Complex (List.map (scale factor) shapes) @@ -77,7 +75,7 @@ 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 -> failwith "Not Implemented" + | Line line' -> Line { line' with b = rotate_point degrees line'.b } | Polygon polygon' -> Polygon { @@ -87,14 +85,16 @@ let rec rotate degrees = function | Complex shapes -> Complex (List.map (rotate degrees) shapes) let compose f g x = g (f x) -let range n = List.init n Fun.id let repeat n op shape = - let match_list l = - match l with [] -> [ op shape ] | last :: _ -> op last :: l + let rec repeat' = function + | 0, shapes -> shapes + | n, [] -> repeat' (n - 1, [ shape ]) + | n, (transformed :: _ as shapes) -> + repeat' (n - 1, op transformed :: shapes) in - let shapes = List.fold_right (fun _ acc -> match_list acc) (range n) [] in - complex shapes + Complex (repeat' (n, [])) + (** Takes a function and a shape and returns a new shape with the function applied to the original's color *) diff --git a/lib/util.ml b/lib/util.ml new file mode 100644 index 0000000..2aaed7f --- /dev/null +++ b/lib/util.ml @@ -0,0 +1,40 @@ +(* point -> point arithmetic *) +open Shape +let ( /~ ) p1 p2 = { x = p1.x /. p2.x; y = p1.x /. p2.x } + +(* point -> scalar arithmetic *) +let ( -! ) { x; y } scalar = { x = x -. scalar; y = y -. scalar } +let ( /! ) { x; y } scalar = { x = x /. scalar; y = y /. scalar } +let ( *! ) { x; y } scalar = { x = x *. scalar; y = y *. scalar } +let pmap f { x; y } = { x = f x; y = f y } + +(* Tuple/Vector ops *) +let tmap f (x, y) = (f x, f y) +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) + +(** Function composition *) +let ( >> ) f g x = g (f x) + +(* Partitions point in a polygon into faces *) +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 = 0) lst = + match lst with + | [] -> [] + | lst' -> + let taken, _ = take n lst in + if List.length taken = n then + taken + :: + partition n ~step (List.tl lst') + else [] + +(* Misc *) +let range n = List.init n Fun.id diff --git a/lib/util.mli b/lib/util.mli new file mode 100644 index 0000000..74cadbd --- /dev/null +++ b/lib/util.mli @@ -0,0 +1,12 @@ +val ( /~ ) : float Shape.point -> float Shape.point -> float Shape.point +val ( -! ) : float Shape.point -> float -> float Shape.point +val ( /! ) : float Shape.point -> float -> float Shape.point +val ( *! ) : float Shape.point -> float -> float Shape.point +val pmap : ('a -> 'b) -> 'a Shape.point -> 'b Shape.point +val tmap : ('a -> 'b) -> 'a * 'a -> 'b * 'b +val tmap3 : ('a -> 'b) -> 'a * 'a * 'a -> 'b * 'b * 'b +val tmap4 : ('a -> 'b) -> 'a * 'a * 'a * 'a -> 'b * 'b * 'b * 'b +val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c +val take : int -> 'a list -> 'a list * 'a list +val partition : int -> ?step:int -> 'a list -> 'a list list +val range : int -> int list