merge main

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

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

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

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 ]

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

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'

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

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 *)

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