User:Kopophex/venn.ml

(* An experiment in drawing n-degree Venn diagrams. *)
(* to compile: ocamlc -o venn -I +cairo bigarray.cma cairo.cma venn.ml *)
(* To run: ./venn n
   where, n is the degree of the diagram to draw. *)
 
open List
 
let rec take n l = match (n,l) with
    0,_ -> []
  | _,h::t -> h :: take (n-1) t
  | _,[] -> failwith "take: empty list"
 
 
 
let pi = 4. *. atan 1.
 
let alpha = 0.65
 
let (cx,cy) = (alpha /. (sqrt 2.)), -.(alpha /. (sqrt 2.))
 
let draw1 ctx =
  Cairo.arc ctx cx cy 1.0 0.0 (2.*.pi) ; 
  Cairo.stroke ctx
 
let draw2 ctx =
  let theta = 5. *. pi /. 12. in
  Cairo.arc ctx 
    (alpha *. (cos theta))
    (alpha *. (sin theta)) 
    1.0 0.0 (2.*.pi) ;
  Cairo.stroke ctx
 
let draw3 ctx =
  let theta = 13. *. pi /. 12. in
  Cairo.arc ctx
    (alpha *. (cos theta))
    (alpha *. (sin theta))    
    1.0 0.0 (2.0*.pi) ;
  Cairo.stroke ctx
 
 
let rec draw_n_curves ctx r = function
    i when i <= 0. -> ()
  | i ->
      Cairo.arc ctx cx cy ((1.0 +. i*.r) -. (r /. 2.0)) 0.0 (-. pi) ;
      Cairo.stroke ctx;
      Cairo.arc ctx cx cy ((1.0 -. i*.r) +. (r /. 2.0)) 0.0 (-. pi) ;
      Cairo.stroke ctx ;
      draw_n_curves ctx r (i-.1.0)
 
let rec draw_n_right_arcs ctx r = function
    i when i <= 0. -> ()
  | i ->
      Cairo.arc ctx (cx+.1.0) cy (((i-.1.0)*.r)+.(r/.2.0)) (-. pi) 0.0 ;
      Cairo.stroke ctx ;
      draw_n_right_arcs ctx r (i-.1.0)
 
 
let rec draw_n_left_arcs ctx r x = function
    i when i = 0. ->
      Cairo.arc ctx (x+.r) cy (r/.2.0) (-. pi) 0.0 ; Cairo.stroke ctx
  | i ->
      let rec draw_arcs x = function
          j when j <= 0. -> ()
        | j -> Cairo.arc ctx x cy ((r*.(j-.1.0))+.(r/.2.0)) (-. pi) 0.0 ; 
               Cairo.stroke ctx ; 
               draw_arcs x (j-.1.0) in
 
        draw_arcs (x+.(r*.(i/.2.0))) (i/.2.0) ;
        draw_n_left_arcs ctx r (x-.(r*.(i/.2.0))) (i/.2.0)
 
 
 
let base_r = 1.5 
 
let draw_n ctx n =
  let i = 2.0 ** ((float_of_int n) -. 1.0) in
  let r = base_r /. 2.0 ** (float_of_int n) in
    draw_n_curves ctx r i ; 
    draw_n_right_arcs ctx r i ;
    draw_n_left_arcs ctx r (cx-.1.0) i
 
 
let rec draw ctx colors = function
    0 -> ()
  | i ->
      let (r,g,b,a) = (hd colors) in
        Cairo.set_source_rgba ctx r g b a ;
        (match i with
            1 -> draw1 ctx
          | 2 -> draw2 ctx
          | 3 -> draw3 ctx
          | _ -> draw_n ctx (i-3)) ;
        draw ctx (tl colors) (i-1)
 
 
 
 
let () =
  let n = int_of_string Sys.argv.(1) in
  let colors = rev (take n [
    (0.0,0.0,0.0,1.0); (0.0,0.0,0.0,1.0); (0.0,0.0,0.0,1.0);
    (6.0,0.0,0.0,1.0); (0.0,6.0,0.0,1.0); (0.0,0.0,6.0,1.0) ]) in
  let (width,height) = (600,530) in
  let (fwidth,fheight) = (float_of_int width, float_of_int height) in
  let scale = 160. in
  let file = open_out "out.svg" in
  let surface = Cairo_svg.surface_create_for_channel file 650.0 520.0 in
  let ctx = Cairo.create surface in
    Cairo.translate ctx (fwidth/.2.) (fheight/.2.) ;
    Cairo.scale ctx scale (-.scale) ;
    Cairo.set_line_width ctx (2.0/.scale) ;
 
    draw ctx colors n ;
 
    Cairo.surface_finish surface