/[dtapublic]/projs/trunk/shared_source/tk_base/tkcanvps.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/tk_base/tkcanvps.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (7 years, 9 months ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tk_base/tkcanvps.c
File MIME type: text/plain
File size: 68400 byte(s)
Initial commit.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tk_base/tkcanvps.c,v 1.1.1.1 2001/06/13 04:57:25 dtashley Exp $ */
2    
3     /*
4     * tkCanvPs.c --
5     *
6     * This module provides Postscript output support for canvases,
7     * including the "postscript" widget command plus a few utility
8     * procedures used for generating Postscript.
9     *
10     * Copyright (c) 1991-1994 The Regents of the University of California.
11     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
12     *
13     * See the file "license.terms" for information on usage and redistribution
14     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15     *
16     * RCS: @(#) $Id: tkcanvps.c,v 1.1.1.1 2001/06/13 04:57:25 dtashley Exp $
17     */
18    
19     #include "tkInt.h"
20     #include "tkCanvas.h"
21     #include "tkPort.h"
22    
23     /*
24     * See tkCanvas.h for key data structures used to implement canvases.
25     */
26    
27     /*
28     * One of the following structures is created to keep track of Postscript
29     * output being generated. It consists mostly of information provided on
30     * the widget command line.
31     */
32    
33     typedef struct TkPostscriptInfo {
34     int x, y, width, height; /* Area to print, in canvas pixel
35     * coordinates. */
36     int x2, y2; /* x+width and y+height. */
37     char *pageXString; /* String value of "-pagex" option or NULL. */
38     char *pageYString; /* String value of "-pagey" option or NULL. */
39     double pageX, pageY; /* Postscript coordinates (in points)
40     * corresponding to pageXString and
41     * pageYString. Don't forget that y-values
42     * grow upwards for Postscript! */
43     char *pageWidthString; /* Printed width of output. */
44     char *pageHeightString; /* Printed height of output. */
45     double scale; /* Scale factor for conversion: each pixel
46     * maps into this many points. */
47     Tk_Anchor pageAnchor; /* How to anchor bbox on Postscript page. */
48     int rotate; /* Non-zero means output should be rotated
49     * on page (landscape mode). */
50     char *fontVar; /* If non-NULL, gives name of global variable
51     * containing font mapping information.
52     * Malloc'ed. */
53     char *colorVar; /* If non-NULL, give name of global variable
54     * containing color mapping information.
55     * Malloc'ed. */
56     char *colorMode; /* Mode for handling colors: "monochrome",
57     * "gray", or "color". Malloc'ed. */
58     int colorLevel; /* Numeric value corresponding to colorMode:
59     * 0 for mono, 1 for gray, 2 for color. */
60     char *fileName; /* Name of file in which to write Postscript;
61     * NULL means return Postscript info as
62     * result. Malloc'ed. */
63     char *channelName; /* If -channel is specified, the name of
64     * the channel to use. */
65     Tcl_Channel chan; /* Open channel corresponding to fileName. */
66     Tcl_HashTable fontTable; /* Hash table containing names of all font
67     * families used in output. The hash table
68     * values are not used. */
69     int prepass; /* Non-zero means that we're currently in
70     * the pre-pass that collects font information,
71     * so the Postscript generated isn't
72     * relevant. */
73     int prolog; /* Non-zero means output should contain
74     the file prolog.ps in the header. */
75     } TkPostscriptInfo;
76    
77     /*
78     * The table below provides a template that's used to process arguments
79     * to the canvas "postscript" command and fill in TkPostscriptInfo
80     * structures.
81     */
82    
83     static Tk_ConfigSpec configSpecs[] = {
84     {TK_CONFIG_STRING, "-colormap", (char *) NULL, (char *) NULL,
85     "", Tk_Offset(TkPostscriptInfo, colorVar), 0},
86     {TK_CONFIG_STRING, "-colormode", (char *) NULL, (char *) NULL,
87     "", Tk_Offset(TkPostscriptInfo, colorMode), 0},
88     {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL,
89     "", Tk_Offset(TkPostscriptInfo, fileName), 0},
90     {TK_CONFIG_STRING, "-channel", (char *) NULL, (char *) NULL,
91     "", Tk_Offset(TkPostscriptInfo, channelName), 0},
92     {TK_CONFIG_STRING, "-fontmap", (char *) NULL, (char *) NULL,
93     "", Tk_Offset(TkPostscriptInfo, fontVar), 0},
94     {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL,
95     "", Tk_Offset(TkPostscriptInfo, height), 0},
96     {TK_CONFIG_ANCHOR, "-pageanchor", (char *) NULL, (char *) NULL,
97     "", Tk_Offset(TkPostscriptInfo, pageAnchor), 0},
98     {TK_CONFIG_STRING, "-pageheight", (char *) NULL, (char *) NULL,
99     "", Tk_Offset(TkPostscriptInfo, pageHeightString), 0},
100     {TK_CONFIG_STRING, "-pagewidth", (char *) NULL, (char *) NULL,
101     "", Tk_Offset(TkPostscriptInfo, pageWidthString), 0},
102     {TK_CONFIG_STRING, "-pagex", (char *) NULL, (char *) NULL,
103     "", Tk_Offset(TkPostscriptInfo, pageXString), 0},
104     {TK_CONFIG_STRING, "-pagey", (char *) NULL, (char *) NULL,
105     "", Tk_Offset(TkPostscriptInfo, pageYString), 0},
106     {TK_CONFIG_BOOLEAN, "-prolog", (char *) NULL, (char *) NULL,
107     "", Tk_Offset(TkPostscriptInfo, prolog), 0},
108     {TK_CONFIG_BOOLEAN, "-rotate", (char *) NULL, (char *) NULL,
109     "", Tk_Offset(TkPostscriptInfo, rotate), 0},
110     {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL,
111     "", Tk_Offset(TkPostscriptInfo, width), 0},
112     {TK_CONFIG_PIXELS, "-x", (char *) NULL, (char *) NULL,
113     "", Tk_Offset(TkPostscriptInfo, x), 0},
114     {TK_CONFIG_PIXELS, "-y", (char *) NULL, (char *) NULL,
115     "", Tk_Offset(TkPostscriptInfo, y), 0},
116     {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
117     (char *) NULL, 0, 0}
118     };
119    
120     /*
121     * The prolog data. Generated by str2c from prolog.ps
122     * This was split in small chunks by str2c because
123     * some C compiler have limitations on the size of static strings.
124     * (str2c is a small tcl script in tcl's tool directory (source release))
125     */
126     static CONST char * CONST prolog[]= {
127     /* Start of part 1 (2000 characters) */
128     "%%BeginProlog\n\
129     50 dict begin\n\
130     \n\
131     % This is a standard prolog for Postscript generated by Tk's canvas\n\
132     % widget.\n\
133     % RCS: @(#) $Id: tkcanvps.c,v 1.1.1.1 2001/06/13 04:57:25 dtashley Exp $\n\
134     \n\
135     % The definitions below just define all of the variables used in\n\
136     % any of the procedures here. This is needed for obscure reasons\n\
137     % explained on p. 716 of the Postscript manual (Section H.2.7,\n\
138     % \"Initializing Variables,\" in the section on Encapsulated Postscript).\n\
139     \n\
140     /baseline 0 def\n\
141     /stipimage 0 def\n\
142     /height 0 def\n\
143     /justify 0 def\n\
144     /lineLength 0 def\n\
145     /spacing 0 def\n\
146     /stipple 0 def\n\
147     /strings 0 def\n\
148     /xoffset 0 def\n\
149     /yoffset 0 def\n\
150     /tmpstip null def\n\
151     \n\
152     % Define the array ISOLatin1Encoding (which specifies how characters are\n\
153     % encoded for ISO-8859-1 fonts), if it isn't already present (Postscript\n\
154     % level 2 is supposed to define it, but level 1 doesn't).\n\
155     \n\
156     systemdict /ISOLatin1Encoding known not {\n\
157     /ISOLatin1Encoding [\n\
158     /space /space /space /space /space /space /space /space\n\
159     /space /space /space /space /space /space /space /space\n\
160     /space /space /space /space /space /space /space /space\n\
161     /space /space /space /space /space /space /space /space\n\
162     /space /exclam /quotedbl /numbersign /dollar /percent /ampersand\n\
163     /quoteright\n\
164     /parenleft /parenright /asterisk /plus /comma /minus /period /slash\n\
165     /zero /one /two /three /four /five /six /seven\n\
166     /eight /nine /colon /semicolon /less /equal /greater /question\n\
167     /at /A /B /C /D /E /F /G\n\
168     /H /I /J /K /L /M /N /O\n\
169     /P /Q /R /S /T /U /V /W\n\
170     /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore\n\
171     /quoteleft /a /b /c /d /e /f /g\n\
172     /h /i /j /k /l /m /n /o\n\
173     /p /q /r /s /t /u /v /w\n\
174     /x /y /z /braceleft /bar /braceright /asciitilde /space\n\
175     /space /space /space /space /space /space /space /space\n\
176     /space /space /space /space /space /space /space /space\n\
177     /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent\n\
178     /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron\n\
179     /space /exclamdown /cent /sterling /currency /yen /brokenbar /section\n\
180     /dieresis /copyright /ordfem",
181     /* End of part 1 */
182    
183     /* Start of part 2 (2000 characters) */
184     "inine /guillemotleft /logicalnot /hyphen\n\
185     /registered /macron\n\
186     /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph\n\
187     /periodcentered\n\
188     /cedillar /onesuperior /ordmasculine /guillemotright /onequarter\n\
189     /onehalf /threequarters /questiondown\n\
190     /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla\n\
191     /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex\n\
192     /Idieresis\n\
193     /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply\n\
194     /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn\n\
195     /germandbls\n\
196     /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla\n\
197     /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex\n\
198     /idieresis\n\
199     /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide\n\
200     /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn\n\
201     /ydieresis\n\
202     ] def\n\
203     } if\n\
204     \n\
205     % font ISOEncode font\n\
206     % This procedure changes the encoding of a font from the default\n\
207     % Postscript encoding to ISOLatin1. It's typically invoked just\n\
208     % before invoking \"setfont\". The body of this procedure comes from\n\
209     % Section 5.6.1 of the Postscript book.\n\
210     \n\
211     /ISOEncode {\n\
212     dup length dict begin\n\
213     {1 index /FID ne {def} {pop pop} ifelse} forall\n\
214     /Encoding ISOLatin1Encoding def\n\
215     currentdict\n\
216     end\n\
217     \n\
218     % I'm not sure why it's necessary to use \"definefont\" on this new\n\
219     % font, but it seems to be important; just use the name \"Temporary\"\n\
220     % for the font.\n\
221     \n\
222     /Temporary exch definefont\n\
223     } bind def\n\
224     \n\
225     % StrokeClip\n\
226     %\n\
227     % This procedure converts the current path into a clip area under\n\
228     % the assumption of stroking. It's a bit tricky because some Postscript\n\
229     % interpreters get errors during strokepath for dashed lines. If\n\
230     % this happens then turn off dashes and try again.\n\
231     \n\
232     /StrokeClip {\n\
233     {strokepath} stopped {\n\
234     (This Postscript printer gets limitcheck overflows when) =\n\
235     (stippling dashed lines; lines will be printed solid instead.) =\n\
236     [] 0 setdash strokepath} if\n\
237     clip\n\
238     } bind def\n\
239     \n\
240     % d",
241     /* End of part 2 */
242    
243     /* Start of part 3 (2000 characters) */
244     "esiredSize EvenPixels closestSize\n\
245     %\n\
246     % The procedure below is used for stippling. Given the optimal size\n\
247     % of a dot in a stipple pattern in the current user coordinate system,\n\
248     % compute the closest size that is an exact multiple of the device's\n\
249     % pixel size. This allows stipple patterns to be displayed without\n\
250     % aliasing effects.\n\
251     \n\
252     /EvenPixels {\n\
253     % Compute exact number of device pixels per stipple dot.\n\
254     dup 0 matrix currentmatrix dtransform\n\
255     dup mul exch dup mul add sqrt\n\
256     \n\
257     % Round to an integer, make sure the number is at least 1, and compute\n\
258     % user coord distance corresponding to this.\n\
259     dup round dup 1 lt {pop 1} if\n\
260     exch div mul\n\
261     } bind def\n\
262     \n\
263     % width height string StippleFill --\n\
264     %\n\
265     % Given a path already set up and a clipping region generated from\n\
266     % it, this procedure will fill the clipping region with a stipple\n\
267     % pattern. \"String\" contains a proper image description of the\n\
268     % stipple pattern and \"width\" and \"height\" give its dimensions. Each\n\
269     % stipple dot is assumed to be about one unit across in the current\n\
270     % user coordinate system. This procedure trashes the graphics state.\n\
271     \n\
272     /StippleFill {\n\
273     % The following code is needed to work around a NeWSprint bug.\n\
274     \n\
275     /tmpstip 1 index def\n\
276     \n\
277     % Change the scaling so that one user unit in user coordinates\n\
278     % corresponds to the size of one stipple dot.\n\
279     1 EvenPixels dup scale\n\
280     \n\
281     % Compute the bounding box occupied by the path (which is now\n\
282     % the clipping region), and round the lower coordinates down\n\
283     % to the nearest starting point for the stipple pattern. Be\n\
284     % careful about negative numbers, since the rounding works\n\
285     % differently on them.\n\
286     \n\
287     pathbbox\n\
288     4 2 roll\n\
289     5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll\n\
290     6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll\n\
291     \n\
292     % Stack now: width height string y1 y2 x1 x2\n\
293     % Below is a doubly-nested for loop to iterate across this area\n\
294     % in units of the stipple pattern size, going up columns then\n\
295     % acr",
296     /* End of part 3 */
297    
298     /* Start of part 4 (2000 characters) */
299     "oss rows, blasting out a stipple-pattern-sized rectangle at\n\
300     % each position\n\
301     \n\
302     6 index exch {\n\
303     2 index 5 index 3 index {\n\
304     % Stack now: width height string y1 y2 x y\n\
305     \n\
306     gsave\n\
307     1 index exch translate\n\
308     5 index 5 index true matrix tmpstip imagemask\n\
309     grestore\n\
310     } for\n\
311     pop\n\
312     } for\n\
313     pop pop pop pop pop\n\
314     } bind def\n\
315     \n\
316     % -- AdjustColor --\n\
317     % Given a color value already set for output by the caller, adjusts\n\
318     % that value to a grayscale or mono value if requested by the CL\n\
319     % variable.\n\
320     \n\
321     /AdjustColor {\n\
322     CL 2 lt {\n\
323     currentgray\n\
324     CL 0 eq {\n\
325     .5 lt {0} {1} ifelse\n\
326     } if\n\
327     setgray\n\
328     } if\n\
329     } bind def\n\
330     \n\
331     % x y strings spacing xoffset yoffset justify stipple DrawText --\n\
332     % This procedure does all of the real work of drawing text. The\n\
333     % color and font must already have been set by the caller, and the\n\
334     % following arguments must be on the stack:\n\
335     %\n\
336     % x, y - Coordinates at which to draw text.\n\
337     % strings - An array of strings, one for each line of the text item,\n\
338     % in order from top to bottom.\n\
339     % spacing - Spacing between lines.\n\
340     % xoffset - Horizontal offset for text bbox relative to x and y: 0 for\n\
341     % nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.\n\
342     % yoffset - Vertical offset for text bbox relative to x and y: 0 for\n\
343     % nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.\n\
344     % justify - 0 for left justification, 0.5 for center, 1 for right justify.\n\
345     % stipple - Boolean value indicating whether or not text is to be\n\
346     % drawn in stippled fashion. If text is stippled,\n\
347     % procedure StippleText must have been defined to call\n\
348     % StippleFill in the right way.\n\
349     %\n\
350     % Also, when this procedure is invoked, the color and font must already\n\
351     % have been set for the text.\n\
352     \n\
353     /DrawText {\n\
354     /stipple exch def\n\
355     /justify exch def\n\
356     /yoffset exch def\n\
357     /xoffset exch def\n\
358     /spacing exch def\n\
359     /strings exch def\n\
360     \n\
361     % First scan through all of the text to find the widest line.\n\
362     \n\
363     /lineLength 0 def\n\
364     strings {\n\
365     stringwidth pop\n\
366     dup lineLength gt {/lineLength exch def}",
367     /* End of part 4 */
368    
369     /* Start of part 5 (1546 characters) */
370     " {pop} ifelse\n\
371     newpath\n\
372     } forall\n\
373     \n\
374     % Compute the baseline offset and the actual font height.\n\
375     \n\
376     0 0 moveto (TXygqPZ) false charpath\n\
377     pathbbox dup /baseline exch def\n\
378     exch pop exch sub /height exch def pop\n\
379     newpath\n\
380     \n\
381     % Translate coordinates first so that the origin is at the upper-left\n\
382     % corner of the text's bounding box. Remember that x and y for\n\
383     % positioning are still on the stack.\n\
384     \n\
385     translate\n\
386     lineLength xoffset mul\n\
387     strings length 1 sub spacing mul height add yoffset mul translate\n\
388     \n\
389     % Now use the baseline and justification information to translate so\n\
390     % that the origin is at the baseline and positioning point for the\n\
391     % first line of text.\n\
392     \n\
393     justify lineLength mul baseline neg translate\n\
394     \n\
395     % Iterate over each of the lines to output it. For each line,\n\
396     % compute its width again so it can be properly justified, then\n\
397     % display it.\n\
398     \n\
399     strings {\n\
400     dup stringwidth pop\n\
401     justify neg mul 0 moveto\n\
402     stipple {\n\
403     \n\
404     % The text is stippled, so turn it into a path and print\n\
405     % by calling StippledText, which in turn calls StippleFill.\n\
406     % Unfortunately, many Postscript interpreters will get\n\
407     % overflow errors if we try to do the whole string at\n\
408     % once, so do it a character at a time.\n\
409     \n\
410     gsave\n\
411     /char (X) def\n\
412     {\n\
413     char 0 3 -1 roll put\n\
414     currentpoint\n\
415     gsave\n\
416     char true charpath clip StippleText\n\
417     grestore\n\
418     char stringwidth translate\n\
419     moveto\n\
420     } forall\n\
421     grestore\n\
422     } {show} ifelse\n\
423     0 spacing neg translate\n\
424     } forall\n\
425     } bind def\n\
426     \n\
427     %%EndProlog\n\
428     ",
429     /* End of part 5 */
430    
431     NULL /* End of data marker */
432     };
433    
434     /*
435     * Forward declarations for procedures defined later in this file:
436     */
437    
438     static int GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp,
439     char *string, double *doublePtr));
440    
441     /*
442     *--------------------------------------------------------------
443     *
444     * TkCanvPostscriptCmd --
445     *
446     * This procedure is invoked to process the "postscript" options
447     * of the widget command for canvas widgets. See the user
448     * documentation for details on what it does.
449     *
450     * Results:
451     * A standard Tcl result.
452     *
453     * Side effects:
454     * See the user documentation.
455     *
456     *--------------------------------------------------------------
457     */
458    
459     /* ARGSUSED */
460     int
461     TkCanvPostscriptCmd(canvasPtr, interp, argc, argv)
462     TkCanvas *canvasPtr; /* Information about canvas widget. */
463     Tcl_Interp *interp; /* Current interpreter. */
464     int argc; /* Number of arguments. */
465     char **argv; /* Argument strings. Caller has
466     * already parsed this command enough
467     * to know that argv[1] is
468     * "postscript". */
469     {
470     TkPostscriptInfo psInfo;
471     Tk_PostscriptInfo oldInfoPtr;
472     int result;
473     Tk_Item *itemPtr;
474     #define STRING_LENGTH 400
475     char string[STRING_LENGTH+1], *p;
476     time_t now;
477     size_t length;
478     Tk_Window tkwin = canvasPtr->tkwin;
479     int deltaX = 0, deltaY = 0; /* Offset of lower-left corner of
480     * area to be marked up, measured
481     * in canvas units from the positioning
482     * point on the page (reflects
483     * anchor position). Initial values
484     * needed only to stop compiler
485     * warnings. */
486     Tcl_HashSearch search;
487     Tcl_HashEntry *hPtr;
488     Tcl_DString buffer;
489     CONST char * CONST *chunk;
490    
491     /*
492     *----------------------------------------------------------------
493     * Initialize the data structure describing Postscript generation,
494     * then process all the arguments to fill the data structure in.
495     *----------------------------------------------------------------
496     */
497    
498     oldInfoPtr = canvasPtr->psInfo;
499     canvasPtr->psInfo = (Tk_PostscriptInfo) &psInfo;
500     psInfo.x = canvasPtr->xOrigin;
501     psInfo.y = canvasPtr->yOrigin;
502     psInfo.width = -1;
503     psInfo.height = -1;
504     psInfo.pageXString = NULL;
505     psInfo.pageYString = NULL;
506     psInfo.pageX = 72*4.25;
507     psInfo.pageY = 72*5.5;
508     psInfo.pageWidthString = NULL;
509     psInfo.pageHeightString = NULL;
510     psInfo.scale = 1.0;
511     psInfo.pageAnchor = TK_ANCHOR_CENTER;
512     psInfo.rotate = 0;
513     psInfo.fontVar = NULL;
514     psInfo.colorVar = NULL;
515     psInfo.colorMode = NULL;
516     psInfo.colorLevel = 0;
517     psInfo.fileName = NULL;
518     psInfo.channelName = NULL;
519     psInfo.chan = NULL;
520     psInfo.prepass = 0;
521     psInfo.prolog = 1;
522     Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS);
523     result = Tk_ConfigureWidget(interp, tkwin,
524     configSpecs, argc-2, argv+2, (char *) &psInfo,
525     TK_CONFIG_ARGV_ONLY);
526     if (result != TCL_OK) {
527     goto cleanup;
528     }
529    
530     if (psInfo.width == -1) {
531     psInfo.width = Tk_Width(tkwin);
532     }
533     if (psInfo.height == -1) {
534     psInfo.height = Tk_Height(tkwin);
535     }
536     psInfo.x2 = psInfo.x + psInfo.width;
537     psInfo.y2 = psInfo.y + psInfo.height;
538    
539     if (psInfo.pageXString != NULL) {
540     if (GetPostscriptPoints(interp, psInfo.pageXString,
541     &psInfo.pageX) != TCL_OK) {
542     goto cleanup;
543     }
544     }
545     if (psInfo.pageYString != NULL) {
546     if (GetPostscriptPoints(interp, psInfo.pageYString,
547     &psInfo.pageY) != TCL_OK) {
548     goto cleanup;
549     }
550     }
551     if (psInfo.pageWidthString != NULL) {
552     if (GetPostscriptPoints(interp, psInfo.pageWidthString,
553     &psInfo.scale) != TCL_OK) {
554     goto cleanup;
555     }
556     psInfo.scale /= psInfo.width;
557     } else if (psInfo.pageHeightString != NULL) {
558     if (GetPostscriptPoints(interp, psInfo.pageHeightString,
559     &psInfo.scale) != TCL_OK) {
560     goto cleanup;
561     }
562     psInfo.scale /= psInfo.height;
563     } else {
564     psInfo.scale = (72.0/25.4)*WidthMMOfScreen(Tk_Screen(tkwin));
565     psInfo.scale /= WidthOfScreen(Tk_Screen(tkwin));
566     }
567     switch (psInfo.pageAnchor) {
568     case TK_ANCHOR_NW:
569     case TK_ANCHOR_W:
570     case TK_ANCHOR_SW:
571     deltaX = 0;
572     break;
573     case TK_ANCHOR_N:
574     case TK_ANCHOR_CENTER:
575     case TK_ANCHOR_S:
576     deltaX = -psInfo.width/2;
577     break;
578     case TK_ANCHOR_NE:
579     case TK_ANCHOR_E:
580     case TK_ANCHOR_SE:
581     deltaX = -psInfo.width;
582     break;
583     }
584     switch (psInfo.pageAnchor) {
585     case TK_ANCHOR_NW:
586     case TK_ANCHOR_N:
587     case TK_ANCHOR_NE:
588     deltaY = - psInfo.height;
589     break;
590     case TK_ANCHOR_W:
591     case TK_ANCHOR_CENTER:
592     case TK_ANCHOR_E:
593     deltaY = -psInfo.height/2;
594     break;
595     case TK_ANCHOR_SW:
596     case TK_ANCHOR_S:
597     case TK_ANCHOR_SE:
598     deltaY = 0;
599     break;
600     }
601    
602     if (psInfo.colorMode == NULL) {
603     psInfo.colorLevel = 2;
604     } else {
605     length = strlen(psInfo.colorMode);
606     if (strncmp(psInfo.colorMode, "monochrome", length) == 0) {
607     psInfo.colorLevel = 0;
608     } else if (strncmp(psInfo.colorMode, "gray", length) == 0) {
609     psInfo.colorLevel = 1;
610     } else if (strncmp(psInfo.colorMode, "color", length) == 0) {
611     psInfo.colorLevel = 2;
612     } else {
613     Tcl_AppendResult(interp, "bad color mode \"",
614     psInfo.colorMode, "\": must be monochrome, ",
615     "gray, or color", (char *) NULL);
616     goto cleanup;
617     }
618     }
619    
620     if (psInfo.fileName != NULL) {
621    
622     /*
623     * Check that -file and -channel are not both specified.
624     */
625    
626     if (psInfo.channelName != NULL) {
627     Tcl_AppendResult(interp, "can't specify both -file",
628     " and -channel", (char *) NULL);
629     result = TCL_ERROR;
630     goto cleanup;
631     }
632    
633     /*
634     * Check that we are not in a safe interpreter. If we are, disallow
635     * the -file specification.
636     */
637    
638     if (Tcl_IsSafe(interp)) {
639     Tcl_AppendResult(interp, "can't specify -file in a",
640     " safe interpreter", (char *) NULL);
641     result = TCL_ERROR;
642     goto cleanup;
643     }
644    
645     p = Tcl_TranslateFileName(interp, psInfo.fileName, &buffer);
646     if (p == NULL) {
647     goto cleanup;
648     }
649     psInfo.chan = Tcl_OpenFileChannel(interp, p, "w", 0666);
650     Tcl_DStringFree(&buffer);
651     if (psInfo.chan == NULL) {
652     goto cleanup;
653     }
654     }
655    
656     if (psInfo.channelName != NULL) {
657     int mode;
658    
659     /*
660     * Check that the channel is found in this interpreter and that it
661     * is open for writing.
662     */
663    
664     psInfo.chan = Tcl_GetChannel(interp, psInfo.channelName,
665     &mode);
666     if (psInfo.chan == (Tcl_Channel) NULL) {
667     result = TCL_ERROR;
668     goto cleanup;
669     }
670     if ((mode & TCL_WRITABLE) == 0) {
671     Tcl_AppendResult(interp, "channel \"",
672     psInfo.channelName, "\" wasn't opened for writing",
673     (char *) NULL);
674     result = TCL_ERROR;
675     goto cleanup;
676     }
677     }
678    
679     /*
680     *--------------------------------------------------------
681     * Make a pre-pass over all of the items, generating Postscript
682     * and then throwing it away. The purpose of this pass is just
683     * to collect information about all the fonts in use, so that
684     * we can output font information in the proper form required
685     * by the Document Structuring Conventions.
686     *--------------------------------------------------------
687     */
688    
689     psInfo.prepass = 1;
690     for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
691     itemPtr = itemPtr->nextPtr) {
692     if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
693     || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
694     continue;
695     }
696     if (itemPtr->typePtr->postscriptProc == NULL) {
697     continue;
698     }
699     result = (*itemPtr->typePtr->postscriptProc)(interp,
700     (Tk_Canvas) canvasPtr, itemPtr, 1);
701     Tcl_ResetResult(interp);
702     if (result != TCL_OK) {
703     /*
704     * An error just occurred. Just skip out of this loop.
705     * There's no need to report the error now; it can be
706     * reported later (errors can happen later that don't
707     * happen now, so we still have to check for errors later
708     * anyway).
709     */
710     break;
711     }
712     }
713     psInfo.prepass = 0;
714    
715     /*
716     *--------------------------------------------------------
717     * Generate the header and prolog for the Postscript.
718     *--------------------------------------------------------
719     */
720    
721     if (psInfo.prolog) {
722     Tcl_AppendResult(interp, "%!PS-Adobe-3.0 EPSF-3.0\n",
723     "%%Creator: Tk Canvas Widget\n", (char *) NULL);
724     #ifdef HAVE_PW_GECOS
725     if (!Tcl_IsSafe(interp)) {
726     struct passwd *pwPtr = getpwuid(getuid()); /* INTL: Native. */
727     Tcl_AppendResult(interp, "%%For: ",
728     (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n",
729     (char *) NULL);
730     endpwent();
731     }
732     #endif /* HAVE_PW_GECOS */
733     Tcl_AppendResult(interp, "%%Title: Window ",
734     Tk_PathName(tkwin), "\n", (char *) NULL);
735     time(&now);
736     Tcl_AppendResult(interp, "%%CreationDate: ",
737     ctime(&now), (char *) NULL); /* INTL: Native. */
738     if (!psInfo.rotate) {
739     sprintf(string, "%d %d %d %d",
740     (int) (psInfo.pageX + psInfo.scale*deltaX),
741     (int) (psInfo.pageY + psInfo.scale*deltaY),
742     (int) (psInfo.pageX + psInfo.scale*(deltaX + psInfo.width)
743     + 1.0),
744     (int) (psInfo.pageY + psInfo.scale*(deltaY + psInfo.height)
745     + 1.0));
746     } else {
747     sprintf(string, "%d %d %d %d",
748     (int) (psInfo.pageX - psInfo.scale*(deltaY + psInfo.height)),
749     (int) (psInfo.pageY + psInfo.scale*deltaX),
750     (int) (psInfo.pageX - psInfo.scale*deltaY + 1.0),
751     (int) (psInfo.pageY + psInfo.scale*(deltaX + psInfo.width)
752     + 1.0));
753     }
754     Tcl_AppendResult(interp, "%%BoundingBox: ", string,
755     "\n", (char *) NULL);
756     Tcl_AppendResult(interp, "%%Pages: 1\n",
757     "%%DocumentData: Clean7Bit\n", (char *) NULL);
758     Tcl_AppendResult(interp, "%%Orientation: ",
759     psInfo.rotate ? "Landscape\n" : "Portrait\n", (char *) NULL);
760     p = "%%DocumentNeededResources: font ";
761     for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
762     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
763     Tcl_AppendResult(interp, p,
764     Tcl_GetHashKey(&psInfo.fontTable, hPtr),
765     "\n", (char *) NULL);
766     p = "%%+ font ";
767     }
768     Tcl_AppendResult(interp, "%%EndComments\n\n", (char *) NULL);
769    
770     /*
771     * Insert the prolog
772     */
773     for (chunk=prolog; *chunk; chunk++) {
774     Tcl_AppendResult(interp, *chunk, (char *) NULL);
775     }
776    
777     if (psInfo.chan != NULL) {
778     Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
779     Tcl_ResetResult(canvasPtr->interp);
780     }
781    
782     /*
783     *-----------------------------------------------------------
784     * Document setup: set the color level and include fonts.
785     *-----------------------------------------------------------
786     */
787    
788     sprintf(string, "/CL %d def\n", psInfo.colorLevel);
789     Tcl_AppendResult(interp, "%%BeginSetup\n", string,
790     (char *) NULL);
791     for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
792     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
793     Tcl_AppendResult(interp, "%%IncludeResource: font ",
794     Tcl_GetHashKey(&psInfo.fontTable, hPtr), "\n", (char *) NULL);
795     }
796     Tcl_AppendResult(interp, "%%EndSetup\n\n", (char *) NULL);
797    
798     /*
799     *-----------------------------------------------------------
800     * Page setup: move to page positioning point, rotate if
801     * needed, set scale factor, offset for proper anchor position,
802     * and set clip region.
803     *-----------------------------------------------------------
804     */
805    
806     Tcl_AppendResult(interp, "%%Page: 1 1\n", "save\n",
807     (char *) NULL);
808     sprintf(string, "%.1f %.1f translate\n", psInfo.pageX, psInfo.pageY);
809     Tcl_AppendResult(interp, string, (char *) NULL);
810     if (psInfo.rotate) {
811     Tcl_AppendResult(interp, "90 rotate\n", (char *) NULL);
812     }
813     sprintf(string, "%.4g %.4g scale\n", psInfo.scale, psInfo.scale);
814     Tcl_AppendResult(interp, string, (char *) NULL);
815     sprintf(string, "%d %d translate\n", deltaX - psInfo.x, deltaY);
816     Tcl_AppendResult(interp, string, (char *) NULL);
817     sprintf(string, "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g",
818     psInfo.x,
819     Tk_PostscriptY((double) psInfo.y, (Tk_PostscriptInfo) &psInfo),
820     psInfo.x2,
821     Tk_PostscriptY((double) psInfo.y, (Tk_PostscriptInfo) &psInfo),
822     psInfo.x2,
823     Tk_PostscriptY((double) psInfo.y2, (Tk_PostscriptInfo) &psInfo),
824     psInfo.x,
825     Tk_PostscriptY((double) psInfo.y2, (Tk_PostscriptInfo) &psInfo));
826     Tcl_AppendResult(interp, string,
827     " lineto closepath clip newpath\n", (char *) NULL);
828     }
829     if (psInfo.chan != NULL) {
830     Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
831     Tcl_ResetResult(canvasPtr->interp);
832     }
833    
834     /*
835     *---------------------------------------------------------------------
836     * Iterate through all the items, having each relevant one draw itself.
837     * Quit if any of the items returns an error.
838     *---------------------------------------------------------------------
839     */
840    
841     result = TCL_OK;
842     for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
843     itemPtr = itemPtr->nextPtr) {
844     if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
845     || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
846     continue;
847     }
848     if (itemPtr->typePtr->postscriptProc == NULL) {
849     continue;
850     }
851     if (itemPtr->state == TK_STATE_HIDDEN) {
852     continue;
853     }
854     Tcl_AppendResult(interp, "gsave\n", (char *) NULL);
855     result = (*itemPtr->typePtr->postscriptProc)(interp,
856     (Tk_Canvas) canvasPtr, itemPtr, 0);
857     if (result != TCL_OK) {
858     char msg[64 + TCL_INTEGER_SPACE];
859    
860     sprintf(msg, "\n (generating Postscript for item %d)",
861     itemPtr->id);
862     Tcl_AddErrorInfo(interp, msg);
863     goto cleanup;
864     }
865     Tcl_AppendResult(interp, "grestore\n", (char *) NULL);
866     if (psInfo.chan != NULL) {
867     Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
868     Tcl_ResetResult(interp);
869     }
870     }
871    
872     /*
873     *---------------------------------------------------------------------
874     * Output page-end information, such as commands to print the page
875     * and document trailer stuff.
876     *---------------------------------------------------------------------
877     */
878    
879     if (psInfo.prolog) {
880     Tcl_AppendResult(interp, "restore showpage\n\n",
881     "%%Trailer\nend\n%%EOF\n", (char *) NULL);
882     }
883     if (psInfo.chan != NULL) {
884     Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1);
885     Tcl_ResetResult(canvasPtr->interp);
886     }
887    
888     /*
889     * Clean up psInfo to release malloc'ed stuff.
890     */
891    
892     cleanup:
893     if (psInfo.pageXString != NULL) {
894     ckfree(psInfo.pageXString);
895     }
896     if (psInfo.pageYString != NULL) {
897     ckfree(psInfo.pageYString);
898     }
899     if (psInfo.pageWidthString != NULL) {
900     ckfree(psInfo.pageWidthString);
901     }
902     if (psInfo.pageHeightString != NULL) {
903     ckfree(psInfo.pageHeightString);
904     }
905     if (psInfo.fontVar != NULL) {
906     ckfree(psInfo.fontVar);
907     }
908     if (psInfo.colorVar != NULL) {
909     ckfree(psInfo.colorVar);
910     }
911     if (psInfo.colorMode != NULL) {
912     ckfree(psInfo.colorMode);
913     }
914     if (psInfo.fileName != NULL) {
915     ckfree(psInfo.fileName);
916     }
917     if ((psInfo.chan != NULL) && (psInfo.channelName == NULL)) {
918     Tcl_Close(interp, psInfo.chan);
919     }
920     if (psInfo.channelName != NULL) {
921     ckfree(psInfo.channelName);
922     }
923     Tcl_DeleteHashTable(&psInfo.fontTable);
924     canvasPtr->psInfo = (Tk_PostscriptInfo) oldInfoPtr;
925     return result;
926     }
927    
928     /*
929     *--------------------------------------------------------------
930     *
931     * Tk_PostscriptColor --
932     *
933     * This procedure is called by individual canvas items when
934     * they want to set a color value for output. Given information
935     * about an X color, this procedure will generate Postscript
936     * commands to set up an appropriate color in Postscript.
937     *
938     * Results:
939     * Returns a standard Tcl return value. If an error occurs
940     * then an error message will be left in the interp's result.
941     * If no error occurs, then additional Postscript will be
942     * appended to the interp's result.
943     *
944     * Side effects:
945     * None.
946     *
947     *--------------------------------------------------------------
948     */
949    
950     int
951     Tk_PostscriptColor(interp, psInfo, colorPtr)
952     Tcl_Interp *interp;
953     Tk_PostscriptInfo psInfo; /* Postscript info. */
954     XColor *colorPtr; /* Information about color. */
955     {
956     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
957     int tmp;
958     double red, green, blue;
959     char string[200];
960    
961     if (psInfoPtr->prepass) {
962     return TCL_OK;
963     }
964    
965     /*
966     * If there is a color map defined, then look up the color's name
967     * in the map and use the Postscript commands found there, if there
968     * are any.
969     */
970    
971     if (psInfoPtr->colorVar != NULL) {
972     char *cmdString;
973    
974     cmdString = Tcl_GetVar2(interp, psInfoPtr->colorVar,
975     Tk_NameOfColor(colorPtr), 0);
976     if (cmdString != NULL) {
977     Tcl_AppendResult(interp, cmdString, "\n", (char *) NULL);
978     return TCL_OK;
979     }
980     }
981    
982     /*
983     * No color map entry for this color. Grab the color's intensities
984     * and output Postscript commands for them. Special note: X uses
985     * a range of 0-65535 for intensities, but most displays only use
986     * a range of 0-255, which maps to (0, 256, 512, ... 65280) in the
987     * X scale. This means that there's no way to get perfect white,
988     * since the highest intensity is only 65280 out of 65535. To
989     * work around this problem, rescale the X intensity to a 0-255
990     * scale and use that as the basis for the Postscript colors. This
991     * scheme still won't work if the display only uses 4 bits per color,
992     * but most diplays use at least 8 bits.
993     */
994    
995     tmp = colorPtr->red;
996     red = ((double) (tmp >> 8))/255.0;
997     tmp = colorPtr->green;
998     green = ((double) (tmp >> 8))/255.0;
999     tmp = colorPtr->blue;
1000     blue = ((double) (tmp >> 8))/255.0;
1001     sprintf(string, "%.3f %.3f %.3f setrgbcolor AdjustColor\n",
1002     red, green, blue);
1003     Tcl_AppendResult(interp, string, (char *) NULL);
1004     return TCL_OK;
1005     }
1006    
1007     /*
1008     *--------------------------------------------------------------
1009     *
1010     * Tk_PostscriptFont --
1011     *
1012     * This procedure is called by individual canvas items when
1013     * they want to output text. Given information about an X
1014     * font, this procedure will generate Postscript commands
1015     * to set up an appropriate font in Postscript.
1016     *
1017     * Results:
1018     * Returns a standard Tcl return value. If an error occurs
1019     * then an error message will be left in the interp's result.
1020     * If no error occurs, then additional Postscript will be
1021     * appended to the interp's result.
1022     *
1023     * Side effects:
1024     * The Postscript font name is entered into psInfoPtr->fontTable
1025     * if it wasn't already there.
1026     *
1027     *--------------------------------------------------------------
1028     */
1029    
1030     int
1031     Tk_PostscriptFont(interp, psInfo, tkfont)
1032     Tcl_Interp *interp;
1033     Tk_PostscriptInfo psInfo; /* Postscript Info. */
1034     Tk_Font tkfont; /* Information about font in which text
1035     * is to be printed. */
1036     {
1037     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
1038     char *end;
1039     char pointString[TCL_INTEGER_SPACE];
1040     Tcl_DString ds;
1041     int i, points;
1042    
1043     /*
1044     * First, look up the font's name in the font map, if there is one.
1045     * If there is an entry for this font, it consists of a list
1046     * containing font name and size. Use this information.
1047     */
1048    
1049     Tcl_DStringInit(&ds);
1050    
1051     if (psInfoPtr->fontVar != NULL) {
1052     char *list, **argv;
1053     int argc;
1054     double size;
1055     char *name;
1056    
1057     name = Tk_NameOfFont(tkfont);
1058     list = Tcl_GetVar2(interp, psInfoPtr->fontVar, name, 0);
1059     if (list != NULL) {
1060     if (Tcl_SplitList(interp, list, &argc, &argv) != TCL_OK) {
1061     badMapEntry:
1062     Tcl_ResetResult(interp);
1063     Tcl_AppendResult(interp, "bad font map entry for \"", name,
1064     "\": \"", list, "\"", (char *) NULL);
1065     return TCL_ERROR;
1066     }
1067     if (argc != 2) {
1068     goto badMapEntry;
1069     }
1070     size = strtod(argv[1], &end);
1071     if ((size <= 0) || (*end != 0)) {
1072     goto badMapEntry;
1073     }
1074    
1075     Tcl_DStringAppend(&ds, argv[0], -1);
1076     points = (int) size;
1077    
1078     ckfree((char *) argv);
1079     goto findfont;
1080     }
1081     }
1082    
1083     points = Tk_PostscriptFontName(tkfont, &ds);
1084    
1085     findfont:
1086     sprintf(pointString, "%d", points);
1087     Tcl_AppendResult(interp, "/", Tcl_DStringValue(&ds), " findfont ",
1088     pointString, " scalefont ", (char *) NULL);
1089     if (strncasecmp(Tcl_DStringValue(&ds), "Symbol", 7) != 0) {
1090     Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL);
1091     }
1092     Tcl_AppendResult(interp, "setfont\n", (char *) NULL);
1093     Tcl_CreateHashEntry(&psInfoPtr->fontTable, Tcl_DStringValue(&ds), &i);
1094     Tcl_DStringFree(&ds);
1095    
1096     return TCL_OK;
1097     }
1098    
1099     /*
1100     *--------------------------------------------------------------
1101     *
1102     * Tk_PostscriptBitmap --
1103     *
1104     * This procedure is called to output the contents of a
1105     * sub-region of a bitmap in proper image data format for
1106     * Postscript (i.e. data between angle brackets, one bit
1107     * per pixel).
1108     *
1109     * Results:
1110     * Returns a standard Tcl return value. If an error occurs
1111     * then an error message will be left in the interp's result.
1112     * If no error occurs, then additional Postscript will be
1113     * appended to the interp's result.
1114     *
1115     * Side effects:
1116     * None.
1117     *
1118     *--------------------------------------------------------------
1119     */
1120    
1121     int
1122     Tk_PostscriptBitmap(interp, tkwin, psInfo, bitmap, startX, startY, width,
1123     height)
1124     Tcl_Interp *interp;
1125     Tk_Window tkwin;
1126     Tk_PostscriptInfo psInfo; /* Postscript info. */
1127     Pixmap bitmap; /* Bitmap for which to generate
1128     * Postscript. */
1129     int startX, startY; /* Coordinates of upper-left corner
1130     * of rectangular region to output. */
1131     int width, height; /* Height of rectangular region. */
1132     {
1133     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
1134     XImage *imagePtr;
1135     int charsInLine, x, y, lastX, lastY, value, mask;
1136     unsigned int totalWidth, totalHeight;
1137     char string[100];
1138     Window dummyRoot;
1139     int dummyX, dummyY;
1140     unsigned dummyBorderwidth, dummyDepth;
1141    
1142     if (psInfoPtr->prepass) {
1143     return TCL_OK;
1144     }
1145    
1146     /*
1147     * The following call should probably be a call to Tk_SizeOfBitmap
1148     * instead, but it seems that we are occasionally invoked by custom
1149     * item types that create their own bitmaps without registering them
1150     * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but
1151     * it shouldn't matter here.
1152     */
1153    
1154     XGetGeometry(Tk_Display(tkwin), bitmap, &dummyRoot,
1155     (int *) &dummyX, (int *) &dummyY, (unsigned int *) &totalWidth,
1156     (unsigned int *) &totalHeight, &dummyBorderwidth, &dummyDepth);
1157     imagePtr = XGetImage(Tk_Display(tkwin), bitmap, 0, 0,
1158     totalWidth, totalHeight, 1, XYPixmap);
1159     Tcl_AppendResult(interp, "<", (char *) NULL);
1160     mask = 0x80;
1161     value = 0;
1162     charsInLine = 0;
1163     lastX = startX + width - 1;
1164     lastY = startY + height - 1;
1165     for (y = lastY; y >= startY; y--) {
1166     for (x = startX; x <= lastX; x++) {
1167     if (XGetPixel(imagePtr, x, y)) {
1168     value |= mask;
1169     }
1170     mask >>= 1;
1171     if (mask == 0) {
1172     sprintf(string, "%02x", value);
1173     Tcl_AppendResult(interp, string, (char *) NULL);
1174     mask = 0x80;
1175     value = 0;
1176     charsInLine += 2;
1177     if (charsInLine >= 60) {
1178     Tcl_AppendResult(interp, "\n", (char *) NULL);
1179     charsInLine = 0;
1180     }
1181     }
1182     }
1183     if (mask != 0x80) {
1184     sprintf(string, "%02x", value);
1185     Tcl_AppendResult(interp, string, (char *) NULL);
1186     mask = 0x80;
1187     value = 0;
1188     charsInLine += 2;
1189     }
1190     }
1191     Tcl_AppendResult(interp, ">", (char *) NULL);
1192     XDestroyImage(imagePtr);
1193     return TCL_OK;
1194     }
1195    
1196     /*
1197     *--------------------------------------------------------------
1198     *
1199     * Tk_PostscriptStipple --
1200     *
1201     * This procedure is called by individual canvas items when
1202     * they have created a path that they'd like to be filled with
1203     * a stipple pattern. Given information about an X bitmap,
1204     * this procedure will generate Postscript commands to fill
1205     * the current clip region using a stipple pattern defined by the
1206     * bitmap.
1207     *
1208     * Results:
1209     * Returns a standard Tcl return value. If an error occurs
1210     * then an error message will be left in the interp's result.
1211     * If no error occurs, then additional Postscript will be
1212     * appended to the interp's result.
1213     *
1214     * Side effects:
1215     * None.
1216     *
1217     *--------------------------------------------------------------
1218     */
1219    
1220     int
1221     Tk_PostscriptStipple(interp, tkwin, psInfo, bitmap)
1222     Tcl_Interp *interp;
1223     Tk_Window tkwin;
1224     Tk_PostscriptInfo psInfo; /* Interpreter for returning Postscript
1225     * or error message. */
1226     Pixmap bitmap; /* Bitmap to use for stippling. */
1227     {
1228     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
1229     int width, height;
1230     char string[TCL_INTEGER_SPACE * 2];
1231     Window dummyRoot;
1232     int dummyX, dummyY;
1233     unsigned dummyBorderwidth, dummyDepth;
1234    
1235     if (psInfoPtr->prepass) {
1236     return TCL_OK;
1237     }
1238    
1239     /*
1240     * The following call should probably be a call to Tk_SizeOfBitmap
1241     * instead, but it seems that we are occasionally invoked by custom
1242     * item types that create their own bitmaps without registering them
1243     * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but
1244     * it shouldn't matter here.
1245     */
1246    
1247     XGetGeometry(Tk_Display(tkwin), bitmap, &dummyRoot,
1248     (int *) &dummyX, (int *) &dummyY, (unsigned *) &width,
1249     (unsigned *) &height, &dummyBorderwidth, &dummyDepth);
1250     sprintf(string, "%d %d ", width, height);
1251     Tcl_AppendResult(interp, string, (char *) NULL);
1252     if (Tk_PostscriptBitmap(interp, tkwin, psInfo, bitmap, 0, 0,
1253     width, height) != TCL_OK) {
1254     return TCL_ERROR;
1255     }
1256     Tcl_AppendResult(interp, " StippleFill\n", (char *) NULL);
1257     return TCL_OK;
1258     }
1259    
1260     /*
1261     *--------------------------------------------------------------
1262     *
1263     * Tk_PostscriptY --
1264     *
1265     * Given a y-coordinate in local coordinates, this procedure
1266     * returns a y-coordinate to use for Postscript output.
1267     *
1268     * Results:
1269     * Returns the Postscript coordinate that corresponds to
1270     * "y".
1271     *
1272     * Side effects:
1273     * None.
1274     *
1275     *--------------------------------------------------------------
1276     */
1277    
1278     double
1279     Tk_PostscriptY(y, psInfo)
1280     double y; /* Y-coordinate in canvas coords. */
1281     Tk_PostscriptInfo psInfo; /* Postscript info */
1282     {
1283     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
1284    
1285     return psInfoPtr->y2 - y;
1286     }
1287    
1288     /*
1289     *--------------------------------------------------------------
1290     *
1291     * Tk_PostscriptPath --
1292     *
1293     * Given an array of points for a path, generate Postscript
1294     * commands to create the path.
1295     *
1296     * Results:
1297     * Postscript commands get appended to what's in the interp's result.
1298     *
1299     * Side effects:
1300     * None.
1301     *
1302     *--------------------------------------------------------------
1303     */
1304    
1305     void
1306     Tk_PostscriptPath(interp, psInfo, coordPtr, numPoints)
1307     Tcl_Interp *interp;
1308     Tk_PostscriptInfo psInfo; /* Canvas on whose behalf Postscript
1309     * is being generated. */
1310     double *coordPtr; /* Pointer to first in array of
1311     * 2*numPoints coordinates giving
1312     * points for path. */
1313     int numPoints; /* Number of points at *coordPtr. */
1314     {
1315     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
1316     char buffer[200];
1317    
1318     if (psInfoPtr->prepass) {
1319     return;
1320     }
1321     sprintf(buffer, "%.15g %.15g moveto\n", coordPtr[0],
1322     Tk_PostscriptY(coordPtr[1], psInfo));
1323     Tcl_AppendResult(interp, buffer, (char *) NULL);
1324     for (numPoints--, coordPtr += 2; numPoints > 0;
1325     numPoints--, coordPtr += 2) {
1326     sprintf(buffer, "%.15g %.15g lineto\n", coordPtr[0],
1327     Tk_PostscriptY(coordPtr[1], psInfo));
1328     Tcl_AppendResult(interp, buffer, (char *) NULL);
1329     }
1330     }
1331    
1332     /*
1333     *--------------------------------------------------------------
1334     *
1335     * GetPostscriptPoints --
1336     *
1337     * Given a string, returns the number of Postscript points
1338     * corresponding to that string.
1339     *
1340     * Results:
1341     * The return value is a standard Tcl return result. If
1342     * TCL_OK is returned, then everything went well and the
1343     * screen distance is stored at *doublePtr; otherwise
1344     * TCL_ERROR is returned and an error message is left in
1345     * the interp's result.
1346     *
1347     * Side effects:
1348     * None.
1349     *
1350     *--------------------------------------------------------------
1351     */
1352    
1353     static int
1354     GetPostscriptPoints(interp, string, doublePtr)
1355     Tcl_Interp *interp; /* Use this for error reporting. */
1356     char *string; /* String describing a screen distance. */
1357     double *doublePtr; /* Place to store converted result. */
1358     {
1359     char *end;
1360     double d;
1361    
1362     d = strtod(string, &end);
1363     if (end == string) {
1364     error:
1365     Tcl_AppendResult(interp, "bad distance \"", string,
1366     "\"", (char *) NULL);
1367     return TCL_ERROR;
1368     }
1369     while ((*end != '\0') && isspace(UCHAR(*end))) {
1370     end++;
1371     }
1372     switch (*end) {
1373     case 'c':
1374     d *= 72.0/2.54;
1375     end++;
1376     break;
1377     case 'i':
1378     d *= 72.0;
1379     end++;
1380     break;
1381     case 'm':
1382     d *= 72.0/25.4;
1383     end++;
1384     break;
1385     case 0:
1386     break;
1387     case 'p':
1388     end++;
1389     break;
1390     default:
1391     goto error;
1392     }
1393     while ((*end != '\0') && isspace(UCHAR(*end))) {
1394     end++;
1395     }
1396     if (*end != 0) {
1397     goto error;
1398     }
1399     *doublePtr = d;
1400     return TCL_OK;
1401     }
1402    
1403     /*
1404     *--------------------------------------------------------------
1405     *
1406     * TkImageGetColor --
1407     *
1408     * This procedure converts a pixel value to three floating
1409     * point numbers, representing the amount of red, green, and
1410     * blue in that pixel on the screen. It makes use of colormap
1411     * data passed as an argument, and should work for all Visual
1412     * types.
1413     *
1414     * Results:
1415     * Returns red, green, and blue color values in the range
1416     * 0 to 1. There are no error returns.
1417     *
1418     * Side effects:
1419     * None.
1420     *
1421     *--------------------------------------------------------------
1422     */
1423    
1424     static void
1425     TkImageGetColor(cdata, pixel, red, green, blue)
1426     TkColormapData *cdata; /* Colormap data */
1427     unsigned long pixel; /* Pixel value to look up */
1428     double *red, *green, *blue; /* Color data to return */
1429     {
1430     if (cdata->separated) {
1431     int r = (pixel & cdata->red_mask) >> cdata->red_shift;
1432     int g = (pixel & cdata->green_mask) >> cdata->green_shift;
1433     int b = (pixel & cdata->blue_mask) >> cdata->blue_shift;
1434     *red = cdata->colors[r].red / 65535.0;
1435     *green = cdata->colors[g].green / 65535.0;
1436     *blue = cdata->colors[b].blue / 65535.0;
1437     } else {
1438     *red = cdata->colors[pixel].red / 65535.0;
1439     *green = cdata->colors[pixel].green / 65535.0;
1440     *blue = cdata->colors[pixel].blue / 65535.0;
1441     }
1442     }
1443    
1444     /*
1445     *--------------------------------------------------------------
1446     *
1447     * TkPostscriptImage --
1448     *
1449     * This procedure is called to output the contents of an
1450     * image in Postscript, using a format appropriate for the
1451     * current color mode (i.e. one bit per pixel in monochrome,
1452     * one byte per pixel in gray, and three bytes per pixel in
1453     * color).
1454     *
1455     * Results:
1456     * Returns a standard Tcl return value. If an error occurs
1457     * then an error message will be left in interp->result.
1458     * If no error occurs, then additional Postscript will be
1459     * appended to interp->result.
1460     *
1461     * Side effects:
1462     * None.
1463     *
1464     *--------------------------------------------------------------
1465     */
1466    
1467     int
1468     TkPostscriptImage(interp, tkwin, psInfo, ximage, x, y, width, height)
1469     Tcl_Interp *interp;
1470     Tk_Window tkwin;
1471     Tk_PostscriptInfo psInfo; /* postscript info */
1472     XImage *ximage; /* Image to draw */
1473     int x, y; /* First pixel to output */
1474     int width, height; /* Width and height of area */
1475     {
1476     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
1477     char buffer[256];
1478     int xx, yy, band, maxRows;
1479     double red, green, blue;
1480     int bytesPerLine=0, maxWidth=0;
1481     int level = psInfoPtr->colorLevel;
1482     Colormap cmap;
1483     int i, depth, ncolors;
1484     Visual *visual;
1485     TkColormapData cdata;
1486    
1487     if (psInfoPtr->prepass) {
1488     return TCL_OK;
1489     }
1490    
1491     cmap = Tk_Colormap(tkwin);
1492     depth = Tk_Depth(tkwin);
1493     visual = Tk_Visual(tkwin);
1494    
1495     /*
1496     * Obtain information about the colormap, ie the mapping between
1497     * pixel values and RGB values. The code below should work
1498     * for all Visual types.
1499     */
1500    
1501     ncolors = visual->map_entries;
1502     cdata.colors = (XColor *) ckalloc(sizeof(XColor) * ncolors);
1503     cdata.ncolors = ncolors;
1504    
1505     if (visual->class == DirectColor || visual->class == TrueColor) {
1506     cdata.separated = 1;
1507     cdata.red_mask = visual->red_mask;
1508     cdata.green_mask = visual->green_mask;
1509     cdata.blue_mask = visual->blue_mask;
1510     cdata.red_shift = 0;
1511     cdata.green_shift = 0;
1512     cdata.blue_shift = 0;
1513     while ((0x0001 & (cdata.red_mask >> cdata.red_shift)) == 0)
1514     cdata.red_shift ++;
1515     while ((0x0001 & (cdata.green_mask >> cdata.green_shift)) == 0)
1516     cdata.green_shift ++;
1517     while ((0x0001 & (cdata.blue_mask >> cdata.blue_shift)) == 0)
1518     cdata.blue_shift ++;
1519     for (i = 0; i < ncolors; i ++)
1520     cdata.colors[i].pixel =
1521     ((i << cdata.red_shift) & cdata.red_mask) |
1522     ((i << cdata.green_shift) & cdata.green_mask) |
1523     ((i << cdata.blue_shift) & cdata.blue_mask);
1524     } else {
1525     cdata.separated=0;
1526     for (i = 0; i < ncolors; i ++)
1527     cdata.colors[i].pixel = i;
1528     }
1529     if (visual->class == StaticGray || visual->class == GrayScale)
1530     cdata.color = 0;
1531     else
1532     cdata.color = 1;
1533    
1534    
1535     XQueryColors(Tk_Display(tkwin), cmap, cdata.colors, ncolors);
1536    
1537     /*
1538     * Figure out which color level to use (possibly lower than the
1539     * one specified by the user). For example, if the user specifies
1540     * color with monochrome screen, use gray or monochrome mode instead.
1541     */
1542    
1543     if (!cdata.color && level == 2) {
1544     level = 1;
1545     }
1546    
1547     if (!cdata.color && cdata.ncolors == 2) {
1548     level = 0;
1549     }
1550    
1551     /*
1552     * Check that at least one row of the image can be represented
1553     * with a string less than 64 KB long (this is a limit in the
1554     * Postscript interpreter).
1555     */
1556    
1557     switch (level)
1558     {
1559     case 0: bytesPerLine = (width + 7) / 8; maxWidth = 240000; break;
1560     case 1: bytesPerLine = width; maxWidth = 60000; break;
1561     case 2: bytesPerLine = 3 * width; maxWidth = 20000; break;
1562     }
1563    
1564     if (bytesPerLine > 60000) {
1565     Tcl_ResetResult(interp);
1566     sprintf(buffer,
1567     "Can't generate Postscript for images more than %d pixels wide",
1568     maxWidth);
1569     Tcl_AppendResult(interp, buffer, (char *) NULL);
1570     ckfree((char *) cdata.colors);
1571     return TCL_ERROR;
1572     }
1573    
1574     maxRows = 60000 / bytesPerLine;
1575    
1576     for (band = height-1; band >= 0; band -= maxRows) {
1577     int rows = (band >= maxRows) ? maxRows : band + 1;
1578     int lineLen = 0;
1579     switch (level) {
1580     case 0:
1581     sprintf(buffer, "%d %d 1 matrix {\n<", width, rows);
1582     Tcl_AppendResult(interp, buffer, (char *) NULL);
1583     break;
1584     case 1:
1585     sprintf(buffer, "%d %d 8 matrix {\n<", width, rows);
1586     Tcl_AppendResult(interp, buffer, (char *) NULL);
1587     break;
1588     case 2:
1589     sprintf(buffer, "%d %d 8 matrix {\n<",
1590     width, rows);
1591     Tcl_AppendResult(interp, buffer, (char *) NULL);
1592     break;
1593     }
1594     for (yy = band; yy > band - rows; yy--) {
1595     switch (level) {
1596     case 0: {
1597     /*
1598     * Generate data for image in monochrome mode.
1599     * No attempt at dithering is made--instead, just
1600     * set a threshold.
1601     */
1602     unsigned char mask=0x80;
1603     unsigned char data=0x00;
1604     for (xx = x; xx< x+width; xx++) {
1605     TkImageGetColor(&cdata, XGetPixel(ximage, xx, yy),
1606     &red, &green, &blue);
1607     if (0.30 * red + 0.59 * green + 0.11 * blue > 0.5)
1608     data |= mask;
1609     mask >>= 1;
1610     if (mask == 0) {
1611     sprintf(buffer, "%02X", data);
1612     Tcl_AppendResult(interp, buffer, (char *) NULL);
1613     lineLen += 2;
1614     if (lineLen > 60) {
1615     lineLen = 0;
1616     Tcl_AppendResult(interp, "\n", (char *) NULL);
1617     }
1618     mask=0x80;
1619     data=0x00;
1620     }
1621     }
1622     if ((width % 8) != 0) {
1623     sprintf(buffer, "%02X", data);
1624     Tcl_AppendResult(interp, buffer, (char *) NULL);
1625     mask=0x80;
1626     data=0x00;
1627     }
1628     break;
1629     }
1630     case 1: {
1631     /*
1632     * Generate data in gray mode--in this case, take a
1633     * weighted sum of the red, green, and blue values.
1634     */
1635     for (xx = x; xx < x+width; xx ++) {
1636     TkImageGetColor(&cdata, XGetPixel(ximage, xx, yy),
1637     &red, &green, &blue);
1638     sprintf(buffer, "%02X", (int) floor(0.5 + 255.0 *
1639     (0.30 * red +
1640     0.59 * green +
1641     0.11 * blue)));
1642     Tcl_AppendResult(interp, buffer, (char *) NULL);
1643     lineLen += 2;
1644     if (lineLen > 60) {
1645     lineLen = 0;
1646     Tcl_AppendResult(interp, "\n", (char *) NULL);
1647     }
1648     }
1649     break;
1650     }
1651     case 2: {
1652     /*
1653     * Finally, color mode. Here, just output the red, green,
1654     * and blue values directly.
1655     */
1656     for (xx = x; xx < x+width; xx++) {
1657     TkImageGetColor(&cdata, XGetPixel(ximage, xx, yy),
1658     &red, &green, &blue);
1659     sprintf(buffer, "%02X%02X%02X",
1660     (int) floor(0.5 + 255.0 * red),
1661     (int) floor(0.5 + 255.0 * green),
1662     (int) floor(0.5 + 255.0 * blue));
1663     Tcl_AppendResult(interp, buffer, (char *) NULL);
1664     lineLen += 6;
1665     if (lineLen > 60) {
1666     lineLen = 0;
1667     Tcl_AppendResult(interp, "\n", (char *) NULL);
1668     }
1669     }
1670     break;
1671     }
1672     }
1673     }
1674     switch (level) {
1675     case 0: sprintf(buffer, ">\n} image\n"); break;
1676     case 1: sprintf(buffer, ">\n} image\n"); break;
1677     case 2: sprintf(buffer, ">\n} false 3 colorimage\n"); break;
1678     }
1679     Tcl_AppendResult(interp, buffer, (char *) NULL);
1680     sprintf(buffer, "0 %d translate\n", rows);
1681     Tcl_AppendResult(interp, buffer, (char *) NULL);
1682     }
1683     ckfree((char *) cdata.colors);
1684     return TCL_OK;
1685     }
1686    
1687     /*
1688     *--------------------------------------------------------------
1689     *
1690     * Tk_PostscriptPhoto --
1691     *
1692     * This procedure is called to output the contents of a
1693     * photo image in Postscript, using a format appropriate for
1694     * the requested postscript color mode (i.e. one byte per pixel
1695     * in gray, and three bytes per pixel in color).
1696     *
1697     * Results:
1698     * Returns a standard Tcl return value. If an error occurs
1699     * then an error message will be left in interp->result.
1700     * If no error occurs, then additional Postscript will be
1701     * appended to the interpreter's result.
1702     *
1703     * Side effects:
1704     * None.
1705     *
1706     *--------------------------------------------------------------
1707     */
1708     int
1709     Tk_PostscriptPhoto(interp, blockPtr, psInfo, width, height)
1710     Tcl_Interp *interp;
1711     Tk_PhotoImageBlock *blockPtr;
1712     Tk_PostscriptInfo psInfo;
1713     int width, height;
1714     {
1715     TkPostscriptInfo *psInfoPtr = (TkPostscriptInfo *) psInfo;
1716     int colorLevel = psInfoPtr->colorLevel;
1717     static int codeIncluded = 0;
1718    
1719     unsigned char *pixelPtr;
1720     char buffer[256], cspace[40], decode[40];
1721     int bpc;
1722     int xx, yy, lineLen;
1723     float red, green, blue;
1724     int alpha;
1725     int bytesPerLine=0, maxWidth=0;
1726    
1727     unsigned char opaque = 255;
1728     unsigned char *alphaPtr;
1729     int alphaOffset, alphaPitch, alphaIncr;
1730    
1731     if (psInfoPtr->prepass) {
1732     codeIncluded = 0;
1733     return TCL_OK;
1734     }
1735    
1736     /*
1737     * Define the "TkPhoto" function, which is a modified version
1738     * of the original "transparentimage" function posted
1739     * by ian@five-d.com (Ian Kemmish) to comp.lang.postscript.
1740     * For a monochrome colorLevel this is a slightly different
1741     * version that uses the imagemask command instead of image.
1742     */
1743    
1744     if( !codeIncluded && (colorLevel != 0) ) {
1745     /*
1746     * Color and gray-scale code.
1747     */
1748    
1749     codeIncluded = !0;
1750     Tcl_AppendResult( interp,
1751     "/TkPhoto { \n",
1752     " gsave \n",
1753     " 32 dict begin \n",
1754     " /tinteger exch def \n",
1755     " /transparent 1 string def \n",
1756     " transparent 0 tinteger put \n",
1757     " /olddict exch def \n",
1758     " olddict /DataSource get dup type /filetype ne { \n",
1759     " olddict /DataSource 3 -1 roll \n",
1760     " 0 () /SubFileDecode filter put \n",
1761     " } { \n",
1762     " pop \n",
1763     " } ifelse \n",
1764     " /newdict olddict maxlength dict def \n",
1765     " olddict newdict copy pop \n",
1766     " /w newdict /Width get def \n",
1767     " /crpp newdict /Decode get length 2 idiv def \n",
1768     " /str w string def \n",
1769     " /pix w crpp mul string def \n",
1770     " /substrlen 2 w log 2 log div floor exp cvi def \n",
1771     " /substrs [ \n",
1772     " { \n",
1773     " substrlen string \n",
1774     " 0 1 substrlen 1 sub { \n",
1775     " 1 index exch tinteger put \n",
1776     " } for \n",
1777     " /substrlen substrlen 2 idiv def \n",
1778     " substrlen 0 eq {exit} if \n",
1779     " } loop \n",
1780     " ] def \n",
1781     " /h newdict /Height get def \n",
1782     " 1 w div 1 h div matrix scale \n",
1783     " olddict /ImageMatrix get exch matrix concatmatrix \n",
1784     " matrix invertmatrix concat \n",
1785     " newdict /Height 1 put \n",
1786     " newdict /DataSource pix put \n",
1787     " /mat [w 0 0 h 0 0] def \n",
1788     " newdict /ImageMatrix mat put \n",
1789     " 0 1 h 1 sub { \n",
1790     " mat 5 3 -1 roll neg put \n",
1791     " olddict /DataSource get str readstring pop pop \n",
1792     " /tail str def \n",
1793     " /x 0 def \n",
1794     " olddict /DataSource get pix readstring pop pop \n",
1795     " { \n",
1796     " tail transparent search dup /done exch not def \n",
1797     " {exch pop exch pop} if \n",
1798     " /w1 exch length def \n",
1799     " w1 0 ne { \n",
1800     " newdict /DataSource ",
1801     " pix x crpp mul w1 crpp mul getinterval put \n",
1802     " newdict /Width w1 put \n",
1803     " mat 4 x neg put \n",
1804     " /x x w1 add def \n",
1805     " newdict image \n",
1806     " /tail tail w1 tail length w1 sub getinterval def \n",
1807     " } if \n",
1808     " done {exit} if \n",
1809     " tail substrs { \n",
1810     " anchorsearch {pop} if \n",
1811     " } forall \n",
1812     " /tail exch def \n",
1813     " tail length 0 eq {exit} if \n",
1814     " /x w tail length sub def \n",
1815     " } loop \n",
1816     " } for \n",
1817     " end \n",
1818     " grestore \n",
1819     "} bind def \n\n\n", (char *) NULL);
1820     } else if( !codeIncluded && (colorLevel == 0) ) {
1821     /*
1822     * Monochrome-only code
1823     */
1824    
1825     codeIncluded = !0;
1826     Tcl_AppendResult( interp,
1827     "/TkPhoto { \n",
1828     " gsave \n",
1829     " 32 dict begin \n",
1830     " /dummyInteger exch def \n",
1831     " /olddict exch def \n",
1832     " olddict /DataSource get dup type /filetype ne { \n",
1833     " olddict /DataSource 3 -1 roll \n",
1834     " 0 () /SubFileDecode filter put \n",
1835     " } { \n",
1836     " pop \n",
1837     " } ifelse \n",
1838     " /newdict olddict maxlength dict def \n",
1839     " olddict newdict copy pop \n",
1840     " /w newdict /Width get def \n",
1841     " /pix w 7 add 8 idiv string def \n",
1842     " /h newdict /Height get def \n",
1843     " 1 w div 1 h div matrix scale \n",
1844     " olddict /ImageMatrix get exch matrix concatmatrix \n",
1845     " matrix invertmatrix concat \n",
1846     " newdict /Height 1 put \n",
1847     " newdict /DataSource pix put \n",
1848     " /mat [w 0 0 h 0 0] def \n",
1849     " newdict /ImageMatrix mat put \n",
1850     " 0 1 h 1 sub { \n",
1851     " mat 5 3 -1 roll neg put \n",
1852     " 0.000 0.000 0.000 setrgbcolor \n",
1853     " olddict /DataSource get pix readstring pop pop \n",
1854     " newdict /DataSource pix put \n",
1855     " newdict imagemask \n",
1856     " 1.000 1.000 1.000 setrgbcolor \n",
1857     " olddict /DataSource get pix readstring pop pop \n",
1858     " newdict /DataSource pix put \n",
1859     " newdict imagemask \n",
1860     " } for \n",
1861     " end \n",
1862     " grestore \n",
1863     "} bind def \n\n\n", (char *) NULL);
1864     }
1865    
1866     /*
1867     * Check that at least one row of the image can be represented
1868     * with a string less than 64 KB long (this is a limit in the
1869     * Postscript interpreter).
1870     */
1871    
1872     switch (colorLevel)
1873     {
1874     case 0: bytesPerLine = (width + 7) / 8; maxWidth = 240000; break;
1875     case 1: bytesPerLine = width; maxWidth = 60000; break;
1876     case 2: bytesPerLine = 3 * width; maxWidth = 20000; break;
1877     }
1878     if (bytesPerLine > 60000) {
1879     Tcl_ResetResult(interp);
1880     sprintf(buffer,
1881     "Can't generate Postscript for images more than %d pixels wide",
1882     maxWidth);
1883     Tcl_AppendResult(interp, buffer, (char *) NULL);
1884     return TCL_ERROR;
1885     }
1886    
1887     /*
1888     * Set up the postscript code except for the image-data stream.
1889     */
1890    
1891     switch (colorLevel) {
1892     case 0:
1893     strcpy( cspace, "/DeviceGray");
1894     strcpy( decode, "[1 0]");
1895     bpc = 1;
1896     break;
1897     case 1:
1898     strcpy( cspace, "/DeviceGray");
1899     strcpy( decode, "[0 1]");
1900     bpc = 8;
1901     break;
1902     default:
1903     strcpy( cspace, "/DeviceRGB");
1904     strcpy( decode, "[0 1 0 1 0 1]");
1905     bpc = 8;
1906     break;
1907     }
1908    
1909    
1910     Tcl_AppendResult(interp,
1911     cspace, " setcolorspace\n\n", (char *) NULL);
1912    
1913     sprintf(buffer,
1914     " /Width %d\n /Height %d\n /BitsPerComponent %d\n",
1915     width, height, bpc);
1916     Tcl_AppendResult(interp,
1917     "<<\n /ImageType 1\n", buffer,
1918     " /DataSource currentfile",
1919     " /ASCIIHexDecode filter\n", (char *) NULL);
1920    
1921    
1922     sprintf(buffer,
1923     " /ImageMatrix [1 0 0 -1 0 %d]\n", height);
1924     Tcl_AppendResult(interp, buffer,
1925     " /Decode ", decode, "\n>>\n1 TkPhoto\n", (char *) NULL);
1926    
1927    
1928     /*
1929     * Check the PhotoImageBlock information.
1930     * We assume that:
1931     * if pixelSize is 1,2 or 4, the image is R,G,B,A;
1932     * if pixelSize is 3, the image is R,G,B and offset[3] is bogus.
1933     */
1934    
1935     if (blockPtr->pixelSize == 3) {
1936     /*
1937     * No alpha information: the whole image is opaque.
1938     */
1939    
1940     alphaPtr = &opaque;
1941     alphaPitch = alphaIncr = alphaOffset = 0;
1942     } else {
1943     /*
1944     * Set up alpha handling.
1945     */
1946    
1947     alphaPtr = blockPtr->pixelPtr;
1948     alphaPitch = blockPtr->pitch;
1949     alphaIncr = blockPtr->pixelSize;
1950     alphaOffset = blockPtr->offset[3];
1951     }
1952    
1953    
1954     for (yy = 0, lineLen=0; yy < height; yy++) {
1955     switch (colorLevel) {
1956     case 0: {
1957     /*
1958     * Generate data for image in monochrome mode.
1959     * No attempt at dithering is made--instead, just
1960     * set a threshold.
1961     * To handle transparecies we need to output two lines:
1962     * one for the black pixels, one for the white ones.
1963     */
1964    
1965     unsigned char mask=0x80;
1966     unsigned char data=0x00;
1967     for (xx = 0; xx< width; xx ++) {
1968     pixelPtr = blockPtr->pixelPtr
1969     + (yy * blockPtr->pitch)
1970     + (xx *blockPtr->pixelSize);
1971    
1972     red = pixelPtr[blockPtr->offset[0]];
1973     green = pixelPtr[blockPtr->offset[1]];
1974     blue = pixelPtr[blockPtr->offset[2]];
1975    
1976     alpha = *(alphaPtr + (yy * alphaPitch)
1977     + (xx * alphaIncr) + alphaOffset);
1978    
1979     /*
1980     * If pixel is less than threshold, then it is black.
1981     */
1982    
1983     if ((alpha != 0) &&
1984     ( 0.3086 * red
1985     + 0.6094 * green
1986     + 0.082 * blue < 128)) {
1987     data |= mask;
1988     }
1989     mask >>= 1;
1990     if (mask == 0) {
1991     sprintf(buffer, "%02X", data);
1992     Tcl_AppendResult(interp, buffer, (char *) NULL);
1993     lineLen += 2;
1994     if (lineLen >= 60) {
1995     lineLen = 0;
1996     Tcl_AppendResult(interp, "\n", (char *) NULL);
1997     }
1998     mask=0x80;
1999     data=0x00;
2000     }
2001     }
2002     if ((width % 8) != 0) {
2003     sprintf(buffer, "%02X", data);
2004     Tcl_AppendResult(interp, buffer, (char *) NULL);
2005     mask=0x80;
2006     data=0x00;
2007     }
2008    
2009     mask=0x80;
2010     data=0x00;
2011     for (xx = 0; xx< width; xx ++) {
2012     pixelPtr = blockPtr->pixelPtr
2013     + (yy * blockPtr->pitch)
2014     + (xx *blockPtr->pixelSize);
2015    
2016     red = pixelPtr[blockPtr->offset[0]];
2017     green = pixelPtr[blockPtr->offset[1]];
2018     blue = pixelPtr[blockPtr->offset[2]];
2019    
2020     alpha = *(alphaPtr + (yy * alphaPitch)
2021     + (xx * alphaIncr) + alphaOffset);
2022    
2023     /*
2024     * If pixel is greater than threshold, then it is white.
2025     */
2026    
2027     if ((alpha != 0) &&
2028     ( 0.3086 * red
2029     + 0.6094 * green
2030     + 0.082 * blue >= 128)) {
2031     data |= mask;
2032     }
2033     mask >>= 1;
2034     if (mask == 0) {
2035     sprintf(buffer, "%02X", data);
2036     Tcl_AppendResult(interp, buffer, (char *) NULL);
2037     lineLen += 2;
2038     if (lineLen >= 60) {
2039     lineLen = 0;
2040     Tcl_AppendResult(interp, "\n", (char *) NULL);
2041     }
2042     mask=0x80;
2043     data=0x00;
2044     }
2045     }
2046     if ((width % 8) != 0) {
2047     sprintf(buffer, "%02X", data);
2048     Tcl_AppendResult(interp, buffer, (char *) NULL);
2049     mask=0x80;
2050     data=0x00;
2051     }
2052     break;
2053     }
2054     case 1: {
2055     /*
2056     * Generate transparency data.
2057     * We must prevent a transparent value of 0
2058     * because of a bug in some HP printers.
2059     */
2060    
2061     for (xx = 0; xx < width; xx ++) {
2062     alpha = *(alphaPtr + (yy * alphaPitch)
2063     + (xx * alphaIncr) + alphaOffset);
2064     sprintf(buffer, "%02X", alpha | 0x01);
2065     Tcl_AppendResult(interp, buffer, (char *) NULL);
2066     lineLen += 2;
2067     if (lineLen >= 60) {
2068     lineLen = 0;
2069     Tcl_AppendResult(interp, "\n", (char *) NULL);
2070     }
2071     }
2072    
2073    
2074     /*
2075     * Generate data in gray mode--in this case, take a
2076     * weighted sum of the red, green, and blue values.
2077     */
2078    
2079     for (xx = 0; xx < width; xx ++) {
2080     pixelPtr = blockPtr->pixelPtr
2081     + (yy * blockPtr->pitch)
2082     + (xx *blockPtr->pixelSize);
2083    
2084     red = pixelPtr[blockPtr->offset[0]];
2085     green = pixelPtr[blockPtr->offset[1]];
2086     blue = pixelPtr[blockPtr->offset[2]];
2087    
2088     sprintf(buffer, "%02X", (int) floor(0.5 +
2089     ( 0.3086 * red + 0.6094 * green + 0.0820 * blue)));
2090     Tcl_AppendResult(interp, buffer, (char *) NULL);
2091     lineLen += 2;
2092     if (lineLen >= 60) {
2093     lineLen = 0;
2094     Tcl_AppendResult(interp, "\n", (char *) NULL);
2095     }
2096     }
2097     break;
2098     }
2099     default: {
2100     /*
2101     * Generate transparency data.
2102     * We must prevent a transparent value of 0
2103     * because of a bug in some HP printers.
2104     */
2105    
2106     for (xx = 0; xx < width; xx ++) {
2107     alpha = *(alphaPtr + (yy * alphaPitch)
2108     + (xx * alphaIncr) + alphaOffset);
2109     sprintf(buffer, "%02X", alpha | 0x01);
2110     Tcl_AppendResult(interp, buffer, (char *) NULL);
2111     lineLen += 2;
2112     if (lineLen >= 60) {
2113     lineLen = 0;
2114     Tcl_AppendResult(interp, "\n", (char *) NULL);
2115     }
2116     }
2117    
2118    
2119     /*
2120     * Finally, color mode. Here, just output the red, green,
2121     * and blue values directly.
2122     */
2123    
2124     for (xx = 0; xx < width; xx ++) {
2125     pixelPtr = blockPtr->pixelPtr
2126     + (yy * blockPtr->pitch)
2127     + (xx *blockPtr->pixelSize);
2128    
2129     sprintf(buffer, "%02X%02X%02X",
2130     pixelPtr[blockPtr->offset[0]],
2131     pixelPtr[blockPtr->offset[1]],
2132     pixelPtr[blockPtr->offset[2]]);
2133     Tcl_AppendResult(interp, buffer, (char *) NULL);
2134     lineLen += 6;
2135     if (lineLen >= 60) {
2136     lineLen = 0;
2137     Tcl_AppendResult(interp, "\n", (char *) NULL);
2138     }
2139     }
2140     break;
2141     }
2142     }
2143     }
2144    
2145     Tcl_AppendResult(interp, ">\n", (char *) NULL);
2146     return TCL_OK;
2147     }
2148    
2149    
2150     /* $History: tkCanvPs.c $
2151     *
2152     * ***************** Version 1 *****************
2153     * User: Dtashley Date: 1/02/01 Time: 2:35a
2154     * Created in $/IjuScripter, IjuConsole/Source/Tk Base
2155     * Initial check-in.
2156     */
2157    
2158     /* End of TKCANVPS.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25