From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Delivered-To: caml-list@yquem.inria.fr Received: from concorde.inria.fr (concorde.inria.fr [192.93.2.39]) by yquem.inria.fr (Postfix) with ESMTP id A7AC6BC84 for ; Thu, 24 Mar 2005 16:34:49 +0100 (CET) Received: from first.in-berlin.de (dialin-145-254-055-133.arcor-ip.net [145.254.55.133]) by concorde.inria.fr (8.13.0/8.13.0) with ESMTP id j2OFYiBr030261 for ; Thu, 24 Mar 2005 16:34:45 +0100 Received: by first.in-berlin.de (Postfix, from userid 501) id EFFA4C3CCC; Thu, 24 Mar 2005 15:25:13 +0100 (CET) Date: Thu, 24 Mar 2005 15:25:12 +0100 From: Oliver Bandel To: caml-list@yquem.inria.fr Subject: Changed GraphPS-Files (had problems with interface/implementation) (Re: [Caml-list] GraphPS missed...) Message-ID: <20050324142512.GA792@first.in-berlin.de> References: <20050320180635.GA4860@first.in-berlin.de> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="WIyZ46R2i8wDzkSu" Content-Disposition: inline In-Reply-To: <20050320180635.GA4860@first.in-berlin.de> User-Agent: Mutt/1.5.6i X-Miltered: at concorde with ID 4242DE14.000 by Joe's j-chkmail (http://j-chkmail.ensmp.fr)! X-Spam: no; 0.00; oliver:01 bandel:01 oliver:01 in-berlin:01 caml-list:01 graphps:01 bandel:01 graphps:01 ml-file:01 weis:01 rocquencourt:01 mli:01 weis:01 val:01 val:01 X-Attachments: name="graphics_ps.mli" name="graphics_ps.ml" X-Spam-Checker-Version: SpamAssassin 3.0.2 (2004-11-16) on yquem.inria.fr X-Spam-Status: No, score=0.1 required=5.0 tests=FORGED_RCVD_HELO autolearn=disabled version=3.0.2 X-Spam-Level: --WIyZ46R2i8wDzkSu Content-Type: text/plain; charset=us-ascii Content-Disposition: inline On Sun, Mar 20, 2005 at 07:06:35PM +0100, Oliver Bandel wrote: > > Hello, > > I found the documentation on GraphPS via CamlHump, > but the ftp-adress which was mentioned in the documentation > was unvalid. > > Where to find GraphPS? OK, I found it with Google's help. But the code didn't compile. There was a problem between the function-declarations in the signature, which uses labels and the function definitions in the ml-file. I changed the files and then it compiled without problems. I attached the two files here. Ciao, Oliver --WIyZ46R2i8wDzkSu Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename="graphics_ps.mli" (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License. *) (* *) (***********************************************************************) (* changed by Oliver Bandel, 24.03.2005 *) (* $Id: graphics.mli,v 1.7 2001/03/08 09:17:16 weis Exp $ *) (* Alternate [graphics] module: PostScript interpretation of Caml machine-independent graphics primitives. *) (*** Initializations *) val open_ps : string -> unit (* Opens the file where the PostScript code corresponding to the Caml drawing is written. At the end of the Caml program, this file will contain a stand alone PostScript file, suitable for direct visualization or printing. *) val open_eps : string -> unit (* Opens the file where the encapsulated PostScript code corresponding to the Caml drawing is written. At the end of the Caml program, this file will contain an encapsulated PostScript file, suitable for insertion into a TeX file. *) val open_graph : string -> unit (* Starts the graphics mode. The PostScript drawing initialization is emited. The page is cleared and the current point is set to (0, 0). The string argument is used to pass optional information on the graphics size (using the X Windows geometry convention). If the empty string is given, a sensible default is selected. *) val close_graph : unit -> unit (* Emits the set of PostScript commands corresponding to the program execution. Closes the PostScript output file if necessary. *) val clear_graph : unit -> unit (* Clear the PostScript page. *) val size_x : unit -> int val size_y : unit -> int (* Returns the size of the graphics page. Coordinates of the page range over [0 .. size_x()-1] and [0 .. size_y()-1]. Drawings outside of this rectangle are clipped, without causing an error. The origin (0,0) is at the lower left corner. *) (*** Colors *) type color = int (* A color is specified by its R, G, B components. Each component is in the range [0..255]. The three components are packed in an [int]: [0xRRGGBB], where [RR] are the two hexadecimal digits for the red component, [GG] for the green component, [BB] for the blue component. *) val rgb : int -> int -> int -> color (* [rgb r g b] returns the integer encoding the color with red component [r], green component [g], and blue component [b]. [r], [g] and [b] are in the range [0..255]. *) val set_color : color -> unit (* Set the current drawing color. *) val black : color val white : color val red : color val green : color val blue : color val yellow : color val cyan : color val magenta : color (* Some predefined colors. *) val background : color val foreground : color (* Default background and foreground colors (usually, either black foreground on a white background or white foreground on a black background). [clear_graph] fills the page with the [background] color. The initial drawing color is [foreground]. *) (*** Point and line drawing *) val plot : x:int -> y:int -> unit (* Plot the given point with the current drawing color. *) val moveto : x:int -> y:int -> unit (* Position the current point. *) val rmoveto : dx:int -> dy:int -> unit (* [rmoveto x y] translates the current point of the given vector. *) val current_x : unit -> int (* Return the abscissa of the current point. *) val current_y : unit -> int (* Return the ordinate of the current point. *) val current_point : unit -> int * int (* Return the position of the current point. *) val lineto : x:int -> y:int -> unit (* Draw a line with endpoints the current point and the given point, and move the current point to the given point. *) val rlineto : dx:int -> dy:int -> unit (* Draws a line with endpoints the current point and the current point translated of the given vector, and move the current point to this point. *) val draw_rect : x:int -> y:int -> w:int -> h:int -> unit (* [draw_rect x y w h] draws the rectangle with lower left corner at [x,y], width [w] and height [h]. The current point is unchanged. *) val draw_arc : x:int -> y:int -> rx:int -> ry:int -> a1:int -> a2:int -> unit (* [draw_arc x y rx ry a1 a2] draws an elliptical arc with center [x,y], horizontal radius [rx], vertical radius [ry], from angle [a1] to angle [a2] (in degrees). The current point is unchanged. *) val draw_ellipse : x:int -> y:int -> rx:int -> ry:int -> unit (* [draw_ellipse x y rx ry] draws an ellipse with center [x,y], horizontal radius [rx] and vertical radius [ry]. The current point is unchanged. *) val draw_circle : x:int -> y:int -> r:int -> unit (* [draw_circle x y r] draws a circle with center [x,y] and radius [r]. The current point is unchanged. *) val draw_poly : (int * int) array -> unit (* Draw the given polygon with the current color. The array contains the coordinates of the vertices of the polygon. The current point is unchanged. *) val set_line_width : int -> unit (* Set the width of points and lines drawn with the functions above. *) (*** Text drawing *) val draw_char : char -> unit val draw_string : string -> unit (* Draw a character or a character string with lower left corner at current position. After drawing, the current position is set to the lower right corner of the text drawn. *) val set_font : string -> unit val set_text_size : int -> unit (* Set the font and character size used for drawing text. The interpretation of the arguments to [set_font] and [set_text_size] is implementation-dependent. *) val text_size : string -> int * int (* Return the dimensions of the given text, if it were drawn with the current font and size. *) (*** Filling *) val fill_rect : x:int -> y:int -> w:int -> h:int -> unit (* [fill_rect x y w h] fills the rectangle with lower left corner at [x,y], width [w] and height [h], with the current color. *) val fill_poly : (int * int) array -> unit (* Fill the given polygon with the current color. The array contains the coordinates of the vertices of the polygon. *) val fill_arc : x:int -> y:int -> rx:int -> ry:int -> a1:int -> a2:int -> unit (* Fill an elliptical pie slice with the current color. The parameters are the same as for [draw_arc]. *) val fill_ellipse : x:int -> y:int -> rx:int -> ry:int -> unit (* Fill an ellipse with the current color. The parameters are the same as for [draw_ellipse]. *) val fill_circle : x:int -> y:int -> r:int -> unit (* Fill a circle with the current color. The parameters are the same as for [draw_circle]. *) (*** Images *) type image (* The abstract type for images, in internal representation. Externally, images are represented as matrices of colors. Only here for compatibility: drawing of image is not yet implemented. *) val transp : color (* In matrices of colors, this color represents a ``transparent'' point: when drawing the corresponding image, all pixels on the screen corresponding to a transparent pixel in the image will not be modified, while other points will be set to the color of the corresponding point in the image. This allows superimposing an image over an existing background. *) --WIyZ46R2i8wDzkSu Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename="graphics_ps.ml" (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License. *) (* *) (***********************************************************************) (* changed by Oliver Bandel, 24.03.2005 *) open Printf;; type command = | Open_graph of int * int | Close_graph | Set_rgb_color of int * int * int | Plot of int * int | Moveto of int * int | Lineto of int * int | Rmoveto of int * int | Rlineto of int * int | Draw_rect of int * int * int * int | Fill_rect of int * int * int * int | Draw_poly of (int * int) array | Fill_poly of (int * int) array | Draw_arc of int * int * int * int * int * int | Fill_arc of int * int * int * int * int * int | Draw_ellipse of int * int * int * int | Fill_ellipse of int * int * int * int | Draw_circle of int * int * int | Fill_circle of int * int * int | Set_line_width of int | Draw_char of char | Draw_string of string | Set_font of string * int ;; let eps_mode = ref false;; let ps_out_channel = ref stdout;; let open_ps s = ps_out_channel := open_out s; eps_mode := false;; let open_eps s = open_ps s; eps_mode := true;; let current_ps_program = ref [];; let add_command c = current_ps_program := c :: !current_ps_program;; let size_x_ref = ref 640 and size_y_ref = ref 640;; let parse_geometry s = let lim = String.length s in let rec find_x i = if i >= lim then raise Not_found else if s.[i] = 'x' then i else find_x (i + 1) in let rec find_digit i = if i >= lim then raise Not_found else match s.[i] with | '0' .. '9' -> i | _ -> find_digit (i + 1) in try let ix = find_x 0 in let dx = find_digit 0 in let sx = String.sub s dx (ix - dx) in let dy = find_digit ix in let sy = String.sub s dy (lim - dy) in int_of_string sx, int_of_string sy with Not_found -> (640, 640) | Failure _ -> (640, 640);; let open_graph s = let x, y = parse_geometry s in size_x_ref := x; size_y_ref := y; add_command (Open_graph (x, y));; let clear_graph () = current_ps_program := [];; let size_x () = !size_x_ref;; let size_y () = !size_y_ref;; (* Colors *) type color = int;; let rgb r g b = (r lsl 16) + (g lsl 8) + b;; let rgb_of_color c = let r = (c lsr 16) land 0xFF in let g = (c lsr 8) land 0xFF in let b = c land 0xFF in r, g, b;; let black = 0x000000 and white = 0xFFFFFF and red = 0xFF0000 and green = 0x00FF00 and blue = 0x0000FF and yellow = 0xFFFF00 and cyan = 0x00FFFF and magenta = 0xFF00FF;; let background = white and foreground = black;; let set_color c = let c = if c < 0 then background else c in let r, g, b = rgb_of_color c in add_command (Set_rgb_color (r, g, b));; (* Drawing *) let plot ~x ~y = add_command (Plot (x, y));; let curr_x = ref 0;; let curr_y = ref 0;; let current_x () = !curr_x;; let current_y () = !curr_y;; let current_point () = !curr_x, !curr_y;; let set_point x y = curr_x := x; curr_y := y;; let moveto ~x ~y = set_point x y; add_command (Moveto (x, y));; let lineto ~x ~y = set_point x y; add_command (Lineto (x, y));; let rlineto ~dx ~dy = set_point (current_x () + dx) (current_y () + dy); add_command (Rlineto (dx, dy));; let rmoveto ~dx ~dy = set_point (current_x () + dx) (current_y () + dy); add_command (Rmoveto (dx, dy));; let draw_arc ~x ~y ~rx ~ry ~a1 ~a2 = add_command (Draw_arc (x, y, rx, ry, a1, a2));; let draw_ellipse ~x ~y ~rx ~ry = add_command (Draw_ellipse (x, y, rx, ry));; let draw_circle ~x ~y ~r = add_command (Draw_circle (x, y, r));; let set_line_width w = add_command (Set_line_width w);; let draw_rect ~x ~y ~w ~h = add_command (Draw_rect (x, y, w, h));; let fill_rect ~x ~y ~w ~h = add_command (Fill_rect (x, y, w, h));; let fill_poly v = add_command (Fill_poly v);; let draw_poly v = add_command (Draw_poly v);; let fill_arc ~x ~y ~rx ~ry ~a1 ~a2 = add_command (Fill_arc (x, y, rx, ry, a1, a2));; let fill_ellipse ~x ~y ~rx ~ry = add_command (Fill_ellipse (x, y, rx, ry));; let fill_circle ~x ~y ~r = add_command (Fill_circle (x, y, r));; (* Text *) let default_font = "Helvetica-Bold";; let default_font_size = 10;; let x_text_size = ref default_font_size;; let y_text_size = ref default_font_size;; let draw_char c = let x = current_x () and y = current_y () in set_point (x + !x_text_size) y; add_command (Draw_char c);; let draw_string s = let x = current_x () and y = current_y () in set_point (x + (String.length s * !x_text_size)) y; add_command (Draw_string s);; (* The font machinery *) let current_font = ref default_font;; let fonts = Hashtbl.create 11;; let add_font f = if not (Hashtbl.mem fonts f) then Hashtbl.add fonts f f;; let parse_font f = match f with | "Times" -> f, !x_text_size | "Times-Italic" -> f, !x_text_size | "Times-Bold" -> f, !x_text_size | "Helvetica" -> f, !x_text_size | "Helvetica-Bold" -> f, !x_text_size | "Helvetica-Italic" -> f, !x_text_size | _ -> "Helvetica", !x_text_size;; let change_font f = let f, sz = parse_font f in add_font f; current_font := f; x_text_size := sz; sz;; let set_font f = let sz = change_font f in add_command (Set_font (f, sz));; let init_font () = ignore (change_font default_font);; init_font ();; let set_text_size i = x_text_size := i; add_command (Set_font (!current_font, i));; let text_size s = (String.length s * !x_text_size, !y_text_size);; (* Images *) type image;; let transp = -1;; (* Post Script functions embedded into the output *) let ps_defs = "\ /m { moveto } def /rm { rmoveto } def /l { lineto } def /c { currentpoint } def /cp { currentlinewidth currentpoint } def /dl { l c stroke m } def /rl { rlineto c stroke m } def /p { newpath m c lineto 1 setlinewidth stroke m setlinewidth} def /pr %% define the path for a rectangle w h x y { newpath moveto dup %% w h h 0 exch rlineto %% rlineto 0 h -- w h exch 0 rlineto %% rlineto w 0 -- h 0 exch sub 0 exch rlineto %% rlineto 0 -h -- closepath } def /dr %% w h x y { pr stroke moveto } def /fr { pr fill moveto } def /fc { 0 360 newpath arc fill moveto } def /dc { 0 360 newpath arc stroke moveto } def /ac { newpath m c } def /fa { gsave translate scale newpath 0 0 m arc closepath fill grestore } def /da { savematrix gsave translate scale newpath arc restorematrix stroke grestore } def /fe { gsave translate scale newpath 0 0 1 0 360 arc fill grestore } def /de { savematrix gsave translate scale newpath 0 0 1 0 360 arc restorematrix stroke grestore } def /pc { newpath m} def /dp { closepath stroke m} def /fp { closepath fill m} def /kcolor { 1 255 div } def /color { kcolor mul } def /stmp { /tmp exch def } def /srgb {% r g b - color stmp color exch color exch tmp setrgbcolor } def /t { show } def /savedmatrix [0 0 0 0 0 0] def /savematrix { savedmatrix currentmatrix pop } def /restorematrix { savedmatrix setmatrix } def %% ISO fonts /ISOLatin1Encoding [ /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /space /exclam /quotedbl /numbersign /dollar /percent /ampersand /quoteright /parenleft /parenright /asterisk /plus /comma /minus /period /slash /zero /one /two /three /four /five /six /seven /eight /nine /colon /semicolon /less /equal /greater /question /at /A /B /C /D /E /F /G /H /I /J /K /L /M /N /O /P /Q /R /S /T /U /V /W /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore /quoteleft /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o /p /q /r /s /t /u /v /w /x /y /z /braceleft /bar /braceright /asciitilde /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /space /exclamdown /cent /sterling /currency /yen /brokenbar /section /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen /registered /macron /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph /periodcentered /cedilla /onesuperior /ordmasculine /guillemotright /onequarter /onehalf /threequarters /questiondown /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex /Idieresis /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn /germandbls /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex /idieresis /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn /ydieresis ] def %% usage: isoname oldname makeisofont - /makeisofont { dup findfont length dict dup begin exch findfont { exch dup /FID eq { pop pop } { exch def } ifelse } forall /Encoding ISOLatin1Encoding def end definefont pop } def ";; let make_iso_font f = sprintf "/ISO%s /%s makeisofont" f f;; let hashtbl_assocs t = let res = ref [] in Hashtbl.iter (fun k v -> res := (k, v) :: !res) t; !res;; let hashtbl_vals t = let res = ref [] in Hashtbl.iter (fun k v -> res := v :: !res) t; !res;; let hashtbl_map f t = let res = ref [] in Hashtbl.iter (fun k v -> res := f k v :: !res) t; !res;; let make_iso_fonts () = let font_list = hashtbl_vals fonts in String.concat "\n" (List.map make_iso_font font_list);; let set_default_font default_font default_font_size = sprintf "/ISO%s findfont %i scalefont setfont\n" default_font default_font_size;; let creator size_x size_y = sprintf "%%!PS-Adobe-2.0 EPSF-2.0\n\ %%%%Creator: GraphPs\n\ %%%%BoundingBox: 0 0 %i %i\n" size_x size_y;; let document_fonts () = let font_list = hashtbl_vals fonts in sprintf "%%%%DocumentFonts: %s\n\ %%%%EndComments\n" (String.concat " " font_list);; let header size_x size_y = sprintf "%s%s" (creator size_x size_y) (document_fonts ());; let prelude size_x size_y default_font default_font_size = sprintf "%s\ %%BeginProcSet\n\ gsave\n\ %s\ 0 0 m\n\ 1 setlinewidth\n\ 1 setlinecap\n\ 2 setlinejoin\n\ 10 setmiterlimit\n\ %s\n\ %s\ %%EndProcSet\n" (header size_x size_y) ps_defs (make_iso_fonts ()) (set_default_font default_font default_font_size);; (* Could be "showpage", if one wants automatic display of the current page. *) let postlude () = if !eps_mode then "grestore\n" else "grestore\nshowpage\n%%end\n";; let escape_char b = function | '(' | ')' | '\\' as c -> Buffer.add_char b '\\'; Buffer.add_char b c | c -> Buffer.add_char b c;; let escape_char_for_ps c = let b = Buffer.create 3 in escape_char b c; Buffer.contents b;; let escape_string_for_ps s = let l = String.length s in let b = Buffer.create l in for i = 0 to l - 1 do escape_char b s.[i] done; Buffer.contents b;; type filling = Fill | Draw;; let print_poly oc filling v = if Array.length v > 0 then begin let x, y = v.(0) in fprintf oc "c %i %i pc\n" x y; for i = 1 to Array.length v - 1 do let x, y = v.(i) in fprintf oc "%i %i l\n" x y done; if filling = Draw then fprintf oc "dp\n" else fprintf oc "fp\n" end;; let to_ps oc = function | Open_graph (x, y) -> fprintf oc "%s" (prelude x y default_font default_font_size); set_color background; fill_rect 0 0 x y; set_color foreground | Close_graph -> fprintf oc "%s\n" (postlude ()) | Set_rgb_color (r, g, b) -> fprintf oc "%i %i %i srgb\n" r g b | Plot (x, y) -> fprintf oc "cp %i %i p\n" x y | Moveto (x, y) -> fprintf oc "%i %i m\n" x y | Lineto (x, y) -> fprintf oc "%i %i dl\n" x y | Rmoveto (x, y) -> fprintf oc "%i %i rm\n" x y | Rlineto (x, y) -> fprintf oc "%i %i rl\n" x y | Set_line_width w -> fprintf oc "%i setlinewidth\n" w | Draw_char c -> fprintf oc "(%s) show\n" (escape_char_for_ps c) | Draw_string s -> fprintf oc "(%s) show\n" (escape_string_for_ps s) | Set_font (f, size) -> fprintf oc "/ISO%s findfont %i scalefont setfont\n" f (2 * size) | Draw_rect (x, y, w, h) -> fprintf oc "c %i %i %i %i dr\n" w h x y | Fill_rect (x, y, w, h) -> fprintf oc "c %i %i %i %i fr\n" w h x y | Fill_poly v -> print_poly oc Fill v | Draw_poly v -> print_poly oc Draw v | Draw_circle (x, y, r) -> fprintf oc "c %i %i %i dc\n" x y r | Fill_circle (x, y, r) -> fprintf oc "c %i %i %i fc\n" x y r | Draw_ellipse (x, y, rx, ry) -> fprintf oc "%i %i %i %i de\n" rx ry x y | Fill_ellipse (x, y, rx, ry) -> fprintf oc "%i %i %i %i fe\n" rx ry x y | Draw_arc (x, y, rx, ry, a1, a2) -> fprintf oc "0 0 1 %i %i %i %i %i %i da\n" a1 a2 rx ry x y | Fill_arc (x, y, rx, ry, a1, a2) -> fprintf oc "0 0 1 %i %i %i %i %i %i fa\n" a1 a2 rx ry x y ;; let close_graph () = if !current_ps_program <> [] then begin let oc = !ps_out_channel in add_command Close_graph; let commands = !current_ps_program in List.iter (to_ps oc) (List.rev commands); current_ps_program := []; flush oc; if oc != stdout then close_out oc end ;; at_exit close_graph;; --WIyZ46R2i8wDzkSu--