type picture = Picture of float * float * float * float * pic_object list

and point = float * float

and pic_object = Line       of point * int * int * float * option list
              | Circle     of point * float * option list
              | Oval       of point * float * float * option list
              | Text       of point * string * option list
              | Curve      of point * point * point * option list
              | SubPicture of point * picture * option list
              | Framebox   of point * float * float * option list

and option = Arrowhead
          | Anchor of anchor * anchor
          | Filled
          | Dashed of float
          | Framed
          | Points of int

and anchor =  N | L | R | T | B

let string_of_anchor = function
 N -> "n" | L -> "l" | R -> "r" | T -> "t" | B -> "b"

let rec extract_anchor = function
   [] -> ""
 | Anchor (a1, a2) :: s -> "[" ^ (string_of_anchor a1) ^
                           (string_of_anchor a2) ^ "]"
 | _ :: s -> extract_anchor s

let rec extract_points = function
   [] -> ""
 | Points i :: s -> "[" ^ (string_of_int i) ^ "]"
 | _ :: s -> extract_points s

let rec extract_dashed = function
   [] -> ""
 | Dashed i :: s -> (string_of_float i)
 | _ :: s -> extract_dashed s

let string_of_point (x, y) =
 "(" ^ (string_of_float x) ^ "," ^ (string_of_float y) ^ ")"

let rec output_pic_objects channel = function
   [] -> ()
 | Line (p, xsl, ysl, length, ol) :: s -> (
     output_string channel (
       "\\put" ^ (string_of_point p) ^
       (if List.mem Arrowhead ol then "{\\vector(" else "{\\line(") ^
       (string_of_int xsl) ^ "," ^ (string_of_int ysl) ^ "){" ^
       (string_of_float length) ^ "}}%\n"
     );
     output_pic_objects channel s
   )
 | Circle (p, d, ol) :: s -> (
     let framed = List.mem Framed ol in
     output_string channel (
       "\\put" ^ (string_of_point p) ^
       (if framed then "{\\frame{" else "{") ^
       (if List.mem Filled ol then "\\circle*{" else "\\circle{") ^
       (string_of_float d) ^
       (if framed then "}}}%\n" else "}}%\n")
     );
     output_pic_objects channel s
   )
 | Oval (p, l, h, ol) :: s -> (
     let framed = List.mem Framed ol in
     output_string channel (
       "\\put" ^ (string_of_point p) ^
       (if framed then "{\\frame{" else "{") ^
       "\\oval" ^ (string_of_point (l, h)) ^ (extract_anchor ol) ^
       (if framed then "}}%\n" else "}%\n")
     );
     output_pic_objects channel s
   )
 | Text (p, t, ol) :: s -> (
     let framed = List.mem Framed ol in
     output_string channel (
       "\\put" ^ (string_of_point p) ^
       (if framed then "{\\frame{" else "{") ^
       "\\makebox(0,0)" ^ (extract_anchor ol) ^ "{" ^ t ^
       (if framed then "}}}%\n" else "}}%\n")
     );
     output_pic_objects channel s
   )
 | Curve (p1, p2, p3, ol) :: s -> (
     output_string channel (
       "\\qbezier" ^ (extract_points ol) ^ (string_of_point p1) ^
       (string_of_point p2) ^ (string_of_point p3) ^ "%\n"
     );
     output_pic_objects channel s
   )
 | SubPicture (p, pic, ol) :: s -> (
     let framed = List.mem Framed ol in
     output_string channel (
       "\\put" ^ (string_of_point p) ^
       (if framed then "{\\frame{" else "{")
     );
     output channel pic;
     output_string channel (if framed then "}}%\n" else "}%\n");
     output_pic_objects channel s
   )
 | Framebox (p, l, h, ol) :: s -> (
     let framed = List.mem Framed ol in
     output_string channel (
       "\\put" ^ (string_of_point p) ^ "{" ^
       ( let dc = extract_dashed ol
         in if dc = "" then "\\framebox"
            else "\\dashbox{" ^ dc ^ "}" ) ^
       (string_of_point (l, h)) ^ (extract_anchor ol) ^ "{%\n"
     );
     output_string channel "}}%\n";
     output_pic_objects channel s
   )

and output channel (Picture (xs, ys, xo, yo, l)) = (
 output_string channel (
   "\\begin{picture}" ^ (string_of_point (xs, ys)) ^
   (string_of_point (xo, yo)) ^ "%\n"
 );
 output_pic_objects channel l;
 output_string channel "\\end{picture}%\n"
)