Logo Search packages:      
Sourcecode: tcltk8.0-ja version File versions  Download package

tkCanvPs.c

/* 
 * tkCanvPs.c --
 *
 *    This module provides Postscript output support for canvases,
 *    including the "postscript" widget command plus a few utility
 *    procedures used for generating Postscript.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tkCanvPs.c,v 1.9 1998/12/05 08:37:16 m-hirano Exp $
 */

#ifdef KANJI
#define TK_KANJI_OK
#endif /* KANJI */

#include "tkInt.h"
#include "tkCanvas.h"
#include "tkPort.h"

/*
 * See tkCanvas.h for key data structures used to implement canvases.
 */

/*
 * One of the following structures is created to keep track of Postscript
 * output being generated.  It consists mostly of information provided on
 * the widget command line.
 */

typedef struct TkPostscriptInfo {
    int x, y, width, height;  /* Area to print, in canvas pixel
                         * coordinates. */
    int x2, y2;               /* x+width and y+height. */
    char *pageXString;        /* String value of "-pagex" option or NULL. */
    char *pageYString;        /* String value of "-pagey" option or NULL. */
    double pageX, pageY;      /* Postscript coordinates (in points)
                         * corresponding to pageXString and
                         * pageYString. Don't forget that y-values
                         * grow upwards for Postscript! */
    char *pageWidthString;    /* Printed width of output. */
    char *pageHeightString;   /* Printed height of output. */
    double scale;       /* Scale factor for conversion: each pixel
                         * maps into this many points. */
    Tk_Anchor pageAnchor;     /* How to anchor bbox on Postscript page. */
    int rotate;               /* Non-zero means output should be rotated
                         * on page (landscape mode). */
    char *fontVar;            /* If non-NULL, gives name of global variable
                         * containing font mapping information.
                         * Malloc'ed. */
    char *colorVar;           /* If non-NULL, give name of global variable
                         * containing color mapping information.
                         * Malloc'ed. */
    char *colorMode;          /* Mode for handling colors:  "monochrome",
                         * "gray", or "color".  Malloc'ed. */
    int colorLevel;           /* Numeric value corresponding to colorMode:
                         * 0 for mono, 1 for gray, 2 for color. */
    char *fileName;           /* Name of file in which to write Postscript;
                         * NULL means return Postscript info as
                         * result. Malloc'ed. */
    char *channelName;        /* If -channel is specified, the name of
                                 * the channel to use. */
    Tcl_Channel chan;         /* Open channel corresponding to fileName. */
    Tcl_HashTable fontTable;  /* Hash table containing names of all font
                         * families used in output.  The hash table
                         * values are not used. */
    int prepass;        /* Non-zero means that we're currently in
                         * the pre-pass that collects font information,
                         * so the Postscript generated isn't
                         * relevant. */
} TkPostscriptInfo;

/*
 * The table below provides a template that's used to process arguments
 * to the canvas "postscript" command and fill in TkPostscriptInfo
 * structures.
 */

static Tk_ConfigSpec configSpecs[] = {
    {TK_CONFIG_STRING, "-colormap", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, colorVar), 0},
    {TK_CONFIG_STRING, "-colormode", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, colorMode), 0},
    {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, fileName), 0},
    {TK_CONFIG_STRING, "-channel", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, channelName), 0},
    {TK_CONFIG_STRING, "-fontmap", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, fontVar), 0},
    {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, height), 0},
    {TK_CONFIG_ANCHOR, "-pageanchor", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, pageAnchor), 0},
    {TK_CONFIG_STRING, "-pageheight", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, pageHeightString), 0},
    {TK_CONFIG_STRING, "-pagewidth", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, pageWidthString), 0},
    {TK_CONFIG_STRING, "-pagex", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, pageXString), 0},
    {TK_CONFIG_STRING, "-pagey", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, pageYString), 0},
    {TK_CONFIG_BOOLEAN, "-rotate", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, rotate), 0},
    {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, width), 0},
    {TK_CONFIG_PIXELS, "-x", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, x), 0},
    {TK_CONFIG_PIXELS, "-y", (char *) NULL, (char *) NULL,
      "", Tk_Offset(TkPostscriptInfo, y), 0},
    {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
      (char *) NULL, 0, 0}
};

/*
 * The prolog data. Generated by str2c from prolog.ps
 * This was split in small chunks by str2c because
 * some C compiler have limitations on the size of static strings.
 */
static CONST char * CONST  prolog[]= {
      /* Start of part 1 (2000 characters) */
      "%%BeginProlog\n\
50 dict begin\n\
\n\
% This is a standard prolog for Postscript generated by Tk's canvas\n\
% widget.\n\
% RCS: @(#) $Id: tkCanvPs.c,v 1.4 1998/09/22 18:57:16 stanton Exp $\n\
\n\
% The definitions below just define all of the variables used in\n\
% any of the procedures here.  This is needed for obscure reasons\n\
% explained on p. 716 of the Postscript manual (Section H.2.7,\n\
% \"Initializing Variables,\" in the section on Encapsulated Postscript).\n\
\n\
/baseline 0 def\n\
/stipimage 0 def\n\
/height 0 def\n\
/justify 0 def\n\
/lineLength 0 def\n\
/spacing 0 def\n\
/stipple 0 def\n\
/strings 0 def\n\
/xoffset 0 def\n\
/yoffset 0 def\n\
/tmpstip null def\n\
\n\
% Define the array ISOLatin1Encoding (which specifies how characters are\n\
% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript\n\
% level 2 is supposed to define it, but level 1 doesn't).\n\
\n\
systemdict /ISOLatin1Encoding known not {\n\
    /ISOLatin1Encoding [\n\
      /space /space /space /space /space /space /space /space\n\
      /space /space /space /space /space /space /space /space\n\
      /space /space /space /space /space /space /space /space\n\
      /space /space /space /space /space /space /space /space\n\
      /space /exclam /quotedbl /numbersign /dollar /percent /ampersand\n\
          /quoteright\n\
      /parenleft /parenright /asterisk /plus /comma /minus /period /slash\n\
      /zero /one /two /three /four /five /six /seven\n\
      /eight /nine /colon /semicolon /less /equal /greater /question\n\
      /at /A /B /C /D /E /F /G\n\
      /H /I /J /K /L /M /N /O\n\
      /P /Q /R /S /T /U /V /W\n\
      /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore\n\
      /quoteleft /a /b /c /d /e /f /g\n\
      /h /i /j /k /l /m /n /o\n\
      /p /q /r /s /t /u /v /w\n\
      /x /y /z /braceleft /bar /braceright /asciitilde /space\n\
      /space /space /space /space /space /space /space /space\n\
      /space /space /space /space /space /space /space /space\n\
      /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent\n\
      /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron\n\
      /space /exclamdown /cent /sterling /currency /yen /brokenbar /section\n\
      /dieresis /copyright /ordfem",
      /* End of part 1 */

      /* Start of part 2 (2000 characters) */
      "inine /guillemotleft /logicalnot /hyphen\n\
          /registered /macron\n\
      /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph\n\
          /periodcentered\n\
      /cedillar /onesuperior /ordmasculine /guillemotright /onequarter\n\
          /onehalf /threequarters /questiondown\n\
      /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla\n\
      /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex\n\
          /Idieresis\n\
      /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply\n\
      /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn\n\
          /germandbls\n\
      /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla\n\
      /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex\n\
          /idieresis\n\
      /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide\n\
      /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn\n\
          /ydieresis\n\
    ] def\n\
} if\n\
\n\
% font ISOEncode font\n\
% This procedure changes the encoding of a font from the default\n\
% Postscript encoding to ISOLatin1.  It's typically invoked just\n\
% before invoking \"setfont\".  The body of this procedure comes from\n\
% Section 5.6.1 of the Postscript book.\n\
\n\
/ISOEncode {\n\
    dup length dict begin\n\
      {1 index /FID ne {def} {pop pop} ifelse} forall\n\
      /Encoding ISOLatin1Encoding def\n\
      currentdict\n\
    end\n\
\n\
    % I'm not sure why it's necessary to use \"definefont\" on this new\n\
    % font, but it seems to be important; just use the name \"Temporary\"\n\
    % for the font.\n\
\n\
    /Temporary exch definefont\n\
} bind def\n\
\n\
% StrokeClip\n\
%\n\
% This procedure converts the current path into a clip area under\n\
% the assumption of stroking.  It's a bit tricky because some Postscript\n\
% interpreters get errors during strokepath for dashed lines.  If\n\
% this happens then turn off dashes and try again.\n\
\n\
/StrokeClip {\n\
    {strokepath} stopped {\n\
      (This Postscript printer gets limitcheck overflows when) =\n\
      (stippling dashed lines;  lines will be printed solid instead.) =\n\
      [] 0 setdash strokepath} if\n\
    clip\n\
} bind def\n\
\n\
% d",
      /* End of part 2 */

      /* Start of part 3 (2000 characters) */
      "esiredSize EvenPixels closestSize\n\
%\n\
% The procedure below is used for stippling.  Given the optimal size\n\
% of a dot in a stipple pattern in the current user coordinate system,\n\
% compute the closest size that is an exact multiple of the device's\n\
% pixel size.  This allows stipple patterns to be displayed without\n\
% aliasing effects.\n\
\n\
/EvenPixels {\n\
    % Compute exact number of device pixels per stipple dot.\n\
    dup 0 matrix currentmatrix dtransform\n\
    dup mul exch dup mul add sqrt\n\
\n\
    % Round to an integer, make sure the number is at least 1, and compute\n\
    % user coord distance corresponding to this.\n\
    dup round dup 1 lt {pop 1} if\n\
    exch div mul\n\
} bind def\n\
\n\
% width height string StippleFill --\n\
%\n\
% Given a path already set up and a clipping region generated from\n\
% it, this procedure will fill the clipping region with a stipple\n\
% pattern.  \"String\" contains a proper image description of the\n\
% stipple pattern and \"width\" and \"height\" give its dimensions.  Each\n\
% stipple dot is assumed to be about one unit across in the current\n\
% user coordinate system.  This procedure trashes the graphics state.\n\
\n\
/StippleFill {\n\
    % The following code is needed to work around a NeWSprint bug.\n\
\n\
    /tmpstip 1 index def\n\
\n\
    % Change the scaling so that one user unit in user coordinates\n\
    % corresponds to the size of one stipple dot.\n\
    1 EvenPixels dup scale\n\
\n\
    % Compute the bounding box occupied by the path (which is now\n\
    % the clipping region), and round the lower coordinates down\n\
    % to the nearest starting point for the stipple pattern.  Be\n\
    % careful about negative numbers, since the rounding works\n\
    % differently on them.\n\
\n\
    pathbbox\n\
    4 2 roll\n\
    5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll\n\
    6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll\n\
\n\
    % Stack now: width height string y1 y2 x1 x2\n\
    % Below is a doubly-nested for loop to iterate across this area\n\
    % in units of the stipple pattern size, going up columns then\n\
    % acr",
      /* End of part 3 */

      /* Start of part 4 (2000 characters) */
      "oss rows, blasting out a stipple-pattern-sized rectangle at\n\
    % each position\n\
\n\
    6 index exch {\n\
      2 index 5 index 3 index {\n\
          % Stack now: width height string y1 y2 x y\n\
\n\
          gsave\n\
          1 index exch translate\n\
          5 index 5 index true matrix tmpstip imagemask\n\
          grestore\n\
      } for\n\
      pop\n\
    } for\n\
    pop pop pop pop pop\n\
} bind def\n\
\n\
% -- AdjustColor --\n\
% Given a color value already set for output by the caller, adjusts\n\
% that value to a grayscale or mono value if requested by the CL\n\
% variable.\n\
\n\
/AdjustColor {\n\
    CL 2 lt {\n\
      currentgray\n\
      CL 0 eq {\n\
          .5 lt {0} {1} ifelse\n\
      } if\n\
      setgray\n\
    } if\n\
} bind def\n\
\n\
% x y strings spacing xoffset yoffset justify stipple DrawText --\n\
% This procedure does all of the real work of drawing text.  The\n\
% color and font must already have been set by the caller, and the\n\
% following arguments must be on the stack:\n\
%\n\
% x, y -    Coordinates at which to draw text.\n\
% strings - An array of strings, one for each line of the text item,\n\
%           in order from top to bottom.\n\
% spacing - Spacing between lines.\n\
% xoffset - Horizontal offset for text bbox relative to x and y: 0 for\n\
%           nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.\n\
% yoffset - Vertical offset for text bbox relative to x and y: 0 for\n\
%           nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.\n\
% justify - 0 for left justification, 0.5 for center, 1 for right justify.\n\
% stipple - Boolean value indicating whether or not text is to be\n\
%           drawn in stippled fashion.  If text is stippled,\n\
%           procedure StippleText must have been defined to call\n\
%           StippleFill in the right way.\n\
%\n\
% Also, when this procedure is invoked, the color and font must already\n\
% have been set for the text.\n\
\n\
/DrawText {\n\
    /stipple exch def\n\
    /justify exch def\n\
    /yoffset exch def\n\
    /xoffset exch def\n\
    /spacing exch def\n\
    /strings exch def\n\
\n\
    % First scan through all of the text to find the widest line.\n\
\n\
    /lineLength 0 def\n\
    strings {\n\
      stringwidth pop\n\
      dup lineLength gt {/lineLength exch def}",
      /* End of part 4 */

#ifdef TK_KANJI_OK
      /* Start of part 5 (1546 characters) */
      " {pop} ifelse\n\
      newpath\n\
    } forall\n\
\n\
    % Compute the baseline offset and the actual font height.\n\
\n\
    0 0 moveto (TXygqPZ) false charpath\n\
    pathbbox dup /baseline exch def\n\
    exch pop exch sub /height exch def pop\n\
    newpath\n\
\n\
    % Translate coordinates first so that the origin is at the upper-left\n\
    % corner of the text's bounding box. Remember that x and y for\n\
    % positioning are still on the stack.\n\
\n\
    translate\n\
    lineLength xoffset mul\n\
    strings length 1 sub spacing mul height add yoffset mul translate\n\
\n\
    % Now use the baseline and justification information to translate so\n\
    % that the origin is at the baseline and positioning point for the\n\
    % first line of text.\n\
\n\
    justify lineLength mul baseline neg translate\n\
\n\
    % Iterate over each of the lines to output it.  For each line,\n\
    % compute its width again so it can be properly justified, then\n\
    % display it.\n\
\n\
    strings {\n\
      dup stringwidth pop\n\
      justify neg mul 0 moveto\n\
      stipple {\n\
\n\
          % The text is stippled, so turn it into a path and print\n\
          % by calling StippledText, which in turn calls StippleFill.\n\
          % Unfortunately, many Postscript interpreters will get\n\
          % overflow errors if we try to do the whole string at\n\
          % once, so do it a character at a time.\n\
\n\
          gsave\n\
          /char (X) def\n\
          {\n\
            char 0 3 -1 roll put\n\
            currentpoint\n\
            gsave\n\
            char true charpath clip StippleText\n\
            grestore\n\
            char stringwidth translate\n\
            moveto\n\
          } forall\n\
          grestore\n\
      } {show} ifelse\n\
      0 spacing neg translate\n\
    } forall\n\
} bind def\n\
\n\
",
      /* Start of part 6 */
      "% Japanization stuff.\n\
\n\
% This eucfont came from fixeucfont-1.2 by Mr. Norio Katayama\n\
% (katayama@rd.nacsis.ac.jp). Thank you :)\n\
\n\
/CIDeucfont {\n\
    userdict /fixeucfont_dict known not {\n\
      userdict begin\n\
          /fixeucfont_dict 2 dict begin\n\
            /UpperByteEncoding [\n\
                16#00 1 16#20 { pop 0 } for\n\
                16#21 1 16#28 { 16#20 sub } for\n\
                16#29 1 16#2F { pop 0 } for\n\
                16#30 1 16#74 { 16#27 sub } for\n\
                16#75 1 16#FF { pop 0 } for\n\
            ] def\n\
              /LowerByteEncoding [\n\
                16#00 1 16#A0 { pop /.notdef } for\n\
                16#A1 1 16#FE { 16#80 sub 16 2 string cvrs\n\
                            (cXX) dup 1 4 -1 roll\n\
                            putinterval cvn } for\n\
                /.notdef\n\
            ] def\n\
            currentdict\n\
          end def\n\
      end\n\
    } if\n\
    12 dict begin\n\
      dup type /nametype eq { findfont } if\n\
      dup /WMode known {\n\
          dup /WMode get /WMode exch def\n\
          WMode 1 eq {\n\
            [0.0 1.0 -1.0 0.0 0.0 0.30] makefont\n\
          } if\n\
      } if\n\
      %\n\
      % 7+8 bit EUC font\n\
      %\n\
      12 dict begin\n\
          /EUCFont exch def\n\
          /FontInfo (7+8 bit EUC font) readonly def\n\
          /PaintType 0 def\n\
          /FontType 0 def\n\
          /FontMatrix matrix def\n\
          % /FontName\n\
          /Encoding fixeucfont_dict /UpperByteEncoding get def\n\
          /FMapType 2 def\n\
          EUCFont /WMode known\n\
          { EUCFont /WMode get /WMode exch def }\n\
          { /WMode 0 def } ifelse\n\
          /FDepVector [\n\
            EUCFont /FDepVector get 0 get\n\
            [ 16#21 1 16#28 {} for 16#30 1 16#74 {} for ]\n\
            {\n\
                13 dict begin\n\
                  /EUCFont EUCFont def\n\
                  /UpperByte exch 16#80 add def \n\
                  % /FontName\n\
                  /FontInfo (EUC lower byte font) readonly def\n\
                  /PaintType 0 def\n\
                  /FontType 3 def\n\
                  /FontMatrix matrix def\n\
                  /FontBBox {0 0 0 0} def\n\
                  /Encoding fixeucfont_dict /LowerByteEncoding get def\n\
                  % /UniqueID\n\
                  % /WMode\n\
",
      /* End of part 6 */
      /* Start of part 7 */

         "              /BuildChar {\n\
                      gsave\n\
                      exch dup /EUCFont get setfont\n\
                      /UpperByte get\n\
                      2 string\n\
                      dup 0 4 -1 roll put\n\
                      dup 1 4 -1 roll put\n\
                      dup stringwidth setcharwidth\n\
                      0 0 moveto show\n\
                      grestore\n\
                  } bind def\n\
                  currentdict\n\
                end\n\
                /lowerbytefont exch definefont\n\
            } forall\n\
          ] def\n\
          currentdict\n\
      end\n\
      /kanjifont exch definefont\n\
      exch\n\
\n\
      dup type /nametype eq { findfont } if\n\
      exch\n\
\n\
      /FDepVector [ 4 2 roll ] def\n\
      /FontType 0 def\n\
      /FMapType 4 def\n\
      /FontMatrix matrix def\n\
      /Encoding [ 0 1 ] def\n\
      /FontBBox {0 0 0 0} def\n\
      dup /FontName exch def\n\
      currentdict\n\
    end\n\
    definefont pop\n\
} def\n\
\n\
/eucfont {\n\
    2 index FontDirectory exch known not {\n\
        CIDeucfont\n\
    } { pop pop pop } ifelse\n\
} def\n\
\n\
%%EndProlog\n\
\n\
",
      /* End of part 7 */
#else
      /* Start of part 5 (1546 characters) */
      " {pop} ifelse\n\
      newpath\n\
    } forall\n\
\n\
    % Compute the baseline offset and the actual font height.\n\
\n\
    0 0 moveto (TXygqPZ) false charpath\n\
    pathbbox dup /baseline exch def\n\
    exch pop exch sub /height exch def pop\n\
    newpath\n\
\n\
    % Translate coordinates first so that the origin is at the upper-left\n\
    % corner of the text's bounding box. Remember that x and y for\n\
    % positioning are still on the stack.\n\
\n\
    translate\n\
    lineLength xoffset mul\n\
    strings length 1 sub spacing mul height add yoffset mul translate\n\
\n\
    % Now use the baseline and justification information to translate so\n\
    % that the origin is at the baseline and positioning point for the\n\
    % first line of text.\n\
\n\
    justify lineLength mul baseline neg translate\n\
\n\
    % Iterate over each of the lines to output it.  For each line,\n\
    % compute its width again so it can be properly justified, then\n\
    % display it.\n\
\n\
    strings {\n\
      dup stringwidth pop\n\
      justify neg mul 0 moveto\n\
      stipple {\n\
\n\
          % The text is stippled, so turn it into a path and print\n\
          % by calling StippledText, which in turn calls StippleFill.\n\
          % Unfortunately, many Postscript interpreters will get\n\
          % overflow errors if we try to do the whole string at\n\
          % once, so do it a character at a time.\n\
\n\
          gsave\n\
          /char (X) def\n\
          {\n\
            char 0 3 -1 roll put\n\
            currentpoint\n\
            gsave\n\
            char true charpath clip StippleText\n\
            grestore\n\
            char stringwidth translate\n\
            moveto\n\
          } forall\n\
          grestore\n\
      } {show} ifelse\n\
      0 spacing neg translate\n\
    } forall\n\
} bind def\n\
\n\
%%EndProlog\n\
",
      /* End of part 5 */
#endif /* TK_KANJI_OK */
      NULL  /* End of data marker */
};

/*
 * Forward declarations for procedures defined later in this file:
 */

static int        GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp,
                      char *string, double *doublePtr));

/*
 *--------------------------------------------------------------
 *
 * TkCanvPostscriptCmd --
 *
 *    This procedure is invoked to process the "postscript" options
 *    of the widget command for canvas widgets. See the user
 *    documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *--------------------------------------------------------------
 */

    /* ARGSUSED */
int
TkCanvPostscriptCmd(canvasPtr, interp, argc, argv)
    TkCanvas *canvasPtr;            /* Information about canvas widget. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int argc;                       /* Number of arguments. */
    char **argv;              /* Argument strings.  Caller has
                               * already parsed this command enough
                               * to know that argv[1] is
                               * "postscript". */
{
    TkPostscriptInfo psInfo, *oldInfoPtr;
    int result;
    Tk_Item *itemPtr;
#define STRING_LENGTH 400
    char string[STRING_LENGTH+1], *p;
    time_t now;
    size_t length;
    int deltaX = 0, deltaY = 0;           /* Offset of lower-left corner of
                               * area to be marked up, measured
                               * in canvas units from the positioning
                               * point on the page (reflects
                               * anchor position).  Initial values
                               * needed only to stop compiler
                               * warnings. */
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    Tcl_DString buffer;
    CONST char * CONST *chunk;

    /*
     *----------------------------------------------------------------
     * Initialize the data structure describing Postscript generation,
     * then process all the arguments to fill the data structure in.
     *----------------------------------------------------------------
     */

    oldInfoPtr = canvasPtr->psInfoPtr;
    canvasPtr->psInfoPtr = &psInfo;
    psInfo.x = canvasPtr->xOrigin;
    psInfo.y = canvasPtr->yOrigin;
    psInfo.width = -1;
    psInfo.height = -1;
    psInfo.pageXString = NULL;
    psInfo.pageYString = NULL;
    psInfo.pageX = 72*4.25;
    psInfo.pageY = 72*5.5;
    psInfo.pageWidthString = NULL;
    psInfo.pageHeightString = NULL;
    psInfo.scale = 1.0;
    psInfo.pageAnchor = TK_ANCHOR_CENTER;
    psInfo.rotate = 0;
    psInfo.fontVar = NULL;
    psInfo.colorVar = NULL;
    psInfo.colorMode = NULL;
    psInfo.colorLevel = 0;
    psInfo.fileName = NULL;
    psInfo.channelName = NULL;
    psInfo.chan = NULL;
    psInfo.prepass = 0;
    Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS);
    result = Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin,
          configSpecs, argc-2, argv+2, (char *) &psInfo,
          TK_CONFIG_ARGV_ONLY);
    if (result != TCL_OK) {
      goto cleanup;
    }

    if (psInfo.width == -1) {
      psInfo.width = Tk_Width(canvasPtr->tkwin);
    }
    if (psInfo.height == -1) {
      psInfo.height = Tk_Height(canvasPtr->tkwin);
    }
    psInfo.x2 = psInfo.x + psInfo.width;
    psInfo.y2 = psInfo.y + psInfo.height;

    if (psInfo.pageXString != NULL) {
      if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageXString,
            &psInfo.pageX) != TCL_OK) {
          goto cleanup;
      }
    }
    if (psInfo.pageYString != NULL) {
      if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageYString,
            &psInfo.pageY) != TCL_OK) {
          goto cleanup;
      }
    }
    if (psInfo.pageWidthString != NULL) {
      if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageWidthString,
            &psInfo.scale) != TCL_OK) {
          goto cleanup;
      }
      psInfo.scale /= psInfo.width;
    } else if (psInfo.pageHeightString != NULL) {
      if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageHeightString,
            &psInfo.scale) != TCL_OK) {
          goto cleanup;
      }
      psInfo.scale /= psInfo.height;
    } else {
      psInfo.scale = (72.0/25.4)*WidthMMOfScreen(Tk_Screen(canvasPtr->tkwin));
      psInfo.scale /= WidthOfScreen(Tk_Screen(canvasPtr->tkwin));
    }
    switch (psInfo.pageAnchor) {
      case TK_ANCHOR_NW:
      case TK_ANCHOR_W:
      case TK_ANCHOR_SW:
          deltaX = 0;
          break;
      case TK_ANCHOR_N:
      case TK_ANCHOR_CENTER:
      case TK_ANCHOR_S:
          deltaX = -psInfo.width/2;
          break;
      case TK_ANCHOR_NE:
      case TK_ANCHOR_E:
      case TK_ANCHOR_SE:
          deltaX = -psInfo.width;
          break;
    }
    switch (psInfo.pageAnchor) {
      case TK_ANCHOR_NW:
      case TK_ANCHOR_N:
      case TK_ANCHOR_NE:
          deltaY = - psInfo.height;
          break;
      case TK_ANCHOR_W:
      case TK_ANCHOR_CENTER:
      case TK_ANCHOR_E:
          deltaY = -psInfo.height/2;
          break;
      case TK_ANCHOR_SW:
      case TK_ANCHOR_S:
      case TK_ANCHOR_SE:
          deltaY = 0;
          break;
    }

    if (psInfo.colorMode == NULL) {
      psInfo.colorLevel = 2;
    } else {
      length = strlen(psInfo.colorMode);
      if (strncmp(psInfo.colorMode, "monochrome", length) == 0) {
          psInfo.colorLevel = 0;
      } else if (strncmp(psInfo.colorMode, "gray", length) == 0) {
          psInfo.colorLevel = 1;
      } else if (strncmp(psInfo.colorMode, "color", length) == 0) {
          psInfo.colorLevel = 2;
      } else {
          Tcl_AppendResult(canvasPtr->interp, "bad color mode \"",
                psInfo.colorMode, "\": must be monochrome, ",
                "gray, or color", (char *) NULL);
          goto cleanup;
      }
    }

    if (psInfo.fileName != NULL) {

        /*
         * Check that -file and -channel are not both specified.
         */

        if (psInfo.channelName != NULL) {
            Tcl_AppendResult(canvasPtr->interp, "can't specify both -file",
                    " and -channel", (char *) NULL);
            result = TCL_ERROR;
            goto cleanup;
        }

        /*
         * Check that we are not in a safe interpreter. If we are, disallow
         * the -file specification.
         */

        if (Tcl_IsSafe(canvasPtr->interp)) {
            Tcl_AppendResult(canvasPtr->interp, "can't specify -file in a",
                    " safe interpreter", (char *) NULL);
            result = TCL_ERROR;
            goto cleanup;
        }
        
      p = Tcl_TranslateFileName(canvasPtr->interp, psInfo.fileName, &buffer);
      if (p == NULL) {
          goto cleanup;
      }
      psInfo.chan = Tcl_OpenFileChannel(canvasPtr->interp, p, "w", 0666);
      Tcl_DStringFree(&buffer);
      if (psInfo.chan == NULL) {
          goto cleanup;
      }
    }

    if (psInfo.channelName != NULL) {
        int mode;
        
        /*
         * Check that the channel is found in this interpreter and that it
         * is open for writing.
         */

        psInfo.chan = Tcl_GetChannel(canvasPtr->interp, psInfo.channelName,
                &mode);
        if (psInfo.chan == (Tcl_Channel) NULL) {
            result = TCL_ERROR;
            goto cleanup;
        }
        if ((mode & TCL_WRITABLE) == 0) {
            Tcl_AppendResult(canvasPtr->interp, "channel \"",
                    psInfo.channelName, "\" wasn't opened for writing",
                    (char *) NULL);
            result = TCL_ERROR;
            goto cleanup;
        }
    }
    
    /*
     *--------------------------------------------------------
     * Make a pre-pass over all of the items, generating Postscript
     * and then throwing it away.  The purpose of this pass is just
     * to collect information about all the fonts in use, so that
     * we can output font information in the proper form required
     * by the Document Structuring Conventions.
     *--------------------------------------------------------
     */

    psInfo.prepass = 1;
    for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
          itemPtr = itemPtr->nextPtr) {
      if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
            || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
          continue;
      }
      if (itemPtr->typePtr->postscriptProc == NULL) {
          continue;
      }
      result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp,
            (Tk_Canvas) canvasPtr, itemPtr, 1);
      Tcl_ResetResult(canvasPtr->interp);
      if (result != TCL_OK) {
          /*
           * An error just occurred.  Just skip out of this loop.
           * There's no need to report the error now;  it can be
           * reported later (errors can happen later that don't
           * happen now, so we still have to check for errors later
           * anyway).
           */
          break;
      }
    }
    psInfo.prepass = 0;

    /*
     *--------------------------------------------------------
     * Generate the header and prolog for the Postscript.
     *--------------------------------------------------------
     */

    Tcl_AppendResult(canvasPtr->interp, "%!PS-Adobe-3.0 EPSF-3.0\n",
          "%%Creator: Tk Canvas Widget\n", (char *) NULL);
#if !(defined(__WIN32__) || defined(MAC_TCL))
    if (!Tcl_IsSafe(interp)) {
      struct passwd *pwPtr = getpwuid(getuid());
      Tcl_AppendResult(canvasPtr->interp, "%%For: ",
            (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n",
            (char *) NULL);
      endpwent();
    }
#endif /* __WIN32__ || MAC_TCL */
    Tcl_AppendResult(canvasPtr->interp, "%%Title: Window ",
          Tk_PathName(canvasPtr->tkwin), "\n", (char *) NULL);
    time(&now);
    Tcl_AppendResult(canvasPtr->interp, "%%CreationDate: ",
          ctime(&now), (char *) NULL);
    if (!psInfo.rotate) {
      sprintf(string, "%d %d %d %d",
            (int) (psInfo.pageX + psInfo.scale*deltaX),
            (int) (psInfo.pageY + psInfo.scale*deltaY),
            (int) (psInfo.pageX + psInfo.scale*(deltaX + psInfo.width)
                  + 1.0),
            (int) (psInfo.pageY + psInfo.scale*(deltaY + psInfo.height)
                  + 1.0));
    } else {
      sprintf(string, "%d %d %d %d",
            (int) (psInfo.pageX - psInfo.scale*(deltaY + psInfo.height)),
            (int) (psInfo.pageY + psInfo.scale*deltaX),
            (int) (psInfo.pageX - psInfo.scale*deltaY + 1.0),
            (int) (psInfo.pageY + psInfo.scale*(deltaX + psInfo.width)
                  + 1.0));
    }
    Tcl_AppendResult(canvasPtr->interp, "%%BoundingBox: ", string,
          "\n", (char *) NULL);
    Tcl_AppendResult(canvasPtr->interp, "%%Pages: 1\n", 
          "%%DocumentData: Clean7Bit\n", (char *) NULL);
    Tcl_AppendResult(canvasPtr->interp, "%%Orientation: ",
          psInfo.rotate ? "Landscape\n" : "Portrait\n", (char *) NULL);
    p = "%%DocumentNeededResources: font ";
    for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
          hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
      Tcl_AppendResult(canvasPtr->interp, p,
            Tcl_GetHashKey(&psInfo.fontTable, hPtr),
            "\n", (char *) NULL);
      p = "%%+ font ";
    }
    Tcl_AppendResult(canvasPtr->interp, "%%EndComments\n\n", (char *) NULL);

    /*
     * Insert the prolog
     */
    for (chunk=prolog; *chunk; chunk++) {
      Tcl_AppendResult(interp, *chunk, (char *) NULL);
    }

    if (psInfo.chan != NULL) {
      Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
      Tcl_ResetResult(canvasPtr->interp);
    }

    /*
     *-----------------------------------------------------------
     * Document setup:  set the color level and include fonts.
     *-----------------------------------------------------------
     */

    sprintf(string, "/CL %d def\n", psInfo.colorLevel);
    Tcl_AppendResult(canvasPtr->interp, "%%BeginSetup\n", string,
          (char *) NULL);
    for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
          hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
      Tcl_AppendResult(canvasPtr->interp, "%%IncludeResource: font ",
            Tcl_GetHashKey(&psInfo.fontTable, hPtr), "\n", (char *) NULL);
    }
    Tcl_AppendResult(canvasPtr->interp, "%%EndSetup\n\n", (char *) NULL);

    /*
     *-----------------------------------------------------------
     * Page setup:  move to page positioning point, rotate if
     * needed, set scale factor, offset for proper anchor position,
     * and set clip region.
     *-----------------------------------------------------------
     */

    Tcl_AppendResult(canvasPtr->interp, "%%Page: 1 1\n", "save\n",
          (char *) NULL);
    sprintf(string, "%.1f %.1f translate\n", psInfo.pageX, psInfo.pageY);
    Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
    if (psInfo.rotate) {
      Tcl_AppendResult(canvasPtr->interp, "90 rotate\n", (char *) NULL);
    }
    sprintf(string, "%.4g %.4g scale\n", psInfo.scale, psInfo.scale);
    Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
    sprintf(string, "%d %d translate\n", deltaX - psInfo.x, deltaY);
    Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
    sprintf(string, "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g",
          psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y),
          psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y),
          psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2),
          psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2));
    Tcl_AppendResult(canvasPtr->interp, string,
      " lineto closepath clip newpath\n", (char *) NULL);
    if (psInfo.chan != NULL) {
      Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
      Tcl_ResetResult(canvasPtr->interp);
    }

    /*
     *---------------------------------------------------------------------
     * Iterate through all the items, having each relevant one draw itself.
     * Quit if any of the items returns an error.
     *---------------------------------------------------------------------
     */

    result = TCL_OK;
    for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
          itemPtr = itemPtr->nextPtr) {
      if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
            || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
          continue;
      }
      if (itemPtr->typePtr->postscriptProc == NULL) {
          continue;
      }
      Tcl_AppendResult(canvasPtr->interp, "gsave\n", (char *) NULL);
      result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp,
            (Tk_Canvas) canvasPtr, itemPtr, 0);
      if (result != TCL_OK) {
          char msg[100];

          sprintf(msg, "\n    (generating Postscript for item %d)",
                itemPtr->id);
          Tcl_AddErrorInfo(canvasPtr->interp, msg);
          goto cleanup;
      }
      Tcl_AppendResult(canvasPtr->interp, "grestore\n", (char *) NULL);
      if (psInfo.chan != NULL) {
          Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
          Tcl_ResetResult(canvasPtr->interp);
      }
    }

    /*
     *---------------------------------------------------------------------
     * Output page-end information, such as commands to print the page
     * and document trailer stuff.
     *---------------------------------------------------------------------
     */

    Tcl_AppendResult(canvasPtr->interp, "restore showpage\n\n",
          "%%Trailer\nend\n%%EOF\n", (char *) NULL);
    if (psInfo.chan != NULL) {
      Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
      Tcl_ResetResult(canvasPtr->interp);
    }

    /*
     * Clean up psInfo to release malloc'ed stuff.
     */

    cleanup:
    if (psInfo.pageXString != NULL) {
      ckfree(psInfo.pageXString);
    }
    if (psInfo.pageYString != NULL) {
      ckfree(psInfo.pageYString);
    }
    if (psInfo.pageWidthString != NULL) {
      ckfree(psInfo.pageWidthString);
    }
    if (psInfo.pageHeightString != NULL) {
      ckfree(psInfo.pageHeightString);
    }
    if (psInfo.fontVar != NULL) {
      ckfree(psInfo.fontVar);
    }
    if (psInfo.colorVar != NULL) {
      ckfree(psInfo.colorVar);
    }
    if (psInfo.colorMode != NULL) {
      ckfree(psInfo.colorMode);
    }
    if (psInfo.fileName != NULL) {
      ckfree(psInfo.fileName);
    }
    if ((psInfo.chan != NULL) && (psInfo.channelName == NULL)) {
      Tcl_Close(canvasPtr->interp, psInfo.chan);
    }
    if (psInfo.channelName != NULL) {
        ckfree(psInfo.channelName);
    }
    Tcl_DeleteHashTable(&psInfo.fontTable);
    canvasPtr->psInfoPtr = oldInfoPtr;
    return result;
}

/*
 *--------------------------------------------------------------
 *
 * Tk_CanvasPsColor --
 *
 *    This procedure is called by individual canvas items when
 *    they want to set a color value for output.  Given information
 *    about an X color, this procedure will generate Postscript
 *    commands to set up an appropriate color in Postscript.
 *
 * Results:
 *    Returns a standard Tcl return value.  If an error occurs
 *    then an error message will be left in interp->result.
 *    If no error occurs, then additional Postscript will be
 *    appended to interp->result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

int
Tk_CanvasPsColor(interp, canvas, colorPtr)
    Tcl_Interp *interp;             /* Interpreter for returning Postscript
                               * or error message. */
    Tk_Canvas canvas;               /* Information about canvas. */
    XColor *colorPtr;               /* Information about color. */
{
    TkCanvas *canvasPtr = (TkCanvas *) canvas;
    TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
    int tmp;
    double red, green, blue;
    char string[200];

    if (psInfoPtr->prepass) {
      return TCL_OK;
    }

    /*
     * If there is a color map defined, then look up the color's name
     * in the map and use the Postscript commands found there, if there
     * are any.
     */

    if (psInfoPtr->colorVar != NULL) {
      char *cmdString;

      cmdString = Tcl_GetVar2(interp, psInfoPtr->colorVar,
            Tk_NameOfColor(colorPtr), 0);
      if (cmdString != NULL) {
          Tcl_AppendResult(interp, cmdString, "\n", (char *) NULL);
          return TCL_OK;
      }
    }

    /*
     * No color map entry for this color.  Grab the color's intensities
     * and output Postscript commands for them.  Special note:  X uses
     * a range of 0-65535 for intensities, but most displays only use
     * a range of 0-255, which maps to (0, 256, 512, ... 65280) in the
     * X scale.  This means that there's no way to get perfect white,
     * since the highest intensity is only 65280 out of 65535.  To
     * work around this problem, rescale the X intensity to a 0-255
     * scale and use that as the basis for the Postscript colors.  This
     * scheme still won't work if the display only uses 4 bits per color,
     * but most diplays use at least 8 bits.
     */

    tmp = colorPtr->red;
    red = ((double) (tmp >> 8))/255.0;
    tmp = colorPtr->green;
    green = ((double) (tmp >> 8))/255.0;
    tmp = colorPtr->blue;
    blue = ((double) (tmp >> 8))/255.0;
    sprintf(string, "%.3f %.3f %.3f setrgbcolor AdjustColor\n",
          red, green, blue);
    Tcl_AppendResult(interp, string, (char *) NULL);
    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * Tk_CanvasPsFont --
 *
 *    This procedure is called by individual canvas items when
 *    they want to output text.  Given information about an X
 *    font, this procedure will generate Postscript commands
 *    to set up an appropriate font in Postscript.
 *
 * Results:
 *    Returns a standard Tcl return value.  If an error occurs
 *    then an error message will be left in interp->result.
 *    If no error occurs, then additional Postscript will be
 *    appended to the interp->result.
 *
 * Side effects:
 *    The Postscript font name is entered into psInfoPtr->fontTable
 *    if it wasn't already there.
 *
 *--------------------------------------------------------------
 */

int
Tk_CanvasPsFont(interp, canvas, tkfont)
    Tcl_Interp *interp;             /* Interpreter for returning Postscript
                               * or error message. */
    Tk_Canvas canvas;               /* Information about canvas. */
    Tk_Font tkfont;                 /* Information about font in which text
                               * is to be printed. */
{
    TkCanvas *canvasPtr = (TkCanvas *) canvas;
    TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
    char *end;
    char pointString[20];
    Tcl_DString ds;
    int i, points;
#ifdef TK_KANJI_OK
    Tk_Font ascii = NULL;
    Tk_Font kanji = NULL;
    Tk_Window tkwin = Tk_MainWindow(interp);
    int fontType = Tk_GetFontType(tkfont);
    Tk_Uid asciiName = NULL;
    Tk_Uid kanjiName = NULL;

    if (fontType == TK_FONT_COMPOUND) {
      if (Tk_GetCompoundDescendant(tkfont, &ascii, &kanji) != TCL_OK) {
          panic("compound font struct is broken??");
      }
    }
#endif /* TK_KANJI_OK */

    /*
     * First, look up the font's name in the font map, if there is one.
     * If there is an entry for this font, it consists of a list
     * containing font name and size.  Use this information.
     */

    Tcl_DStringInit(&ds);
    
    if (psInfoPtr->fontVar != NULL) {
      char *list, **argv;
      int argc;
      double size;
      char *name;

      name = Tk_NameOfFont(tkfont);
      list = Tcl_GetVar2(interp, psInfoPtr->fontVar, name, 0);
      if (list != NULL) {
          if (Tcl_SplitList(interp, list, &argc, &argv) != TCL_OK) {
            badMapEntry:
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, "bad font map entry for \"", name,
                  "\": \"", list, "\"", (char *) NULL);
            return TCL_ERROR;
          }
          if (argc != 2) {
            goto badMapEntry;
          }
          size = strtod(argv[1], &end);
          if ((size <= 0) || (*end != 0)) {
            goto badMapEntry;
          }
#ifdef TK_KANJI_OK
          if (fontType == TK_FONT_COMPOUND) {
            char **psFontNames;
            int numFonts;
            if (Tcl_SplitList(interp, argv[0], &numFonts, &psFontNames) != TCL_OK) {
                goto badMapEntry;
            }
            if (numFonts != 2) {
                ckfree((char *)psFontNames);
                goto badMapEntry;
            }
#ifdef USE_RKSJ_PSFONT
            /* ignore ascii font */
            Tcl_DStringAppend(&ds, psFontNames[1], -1);
#else
            Tcl_AppendResult(interp, "/", name,
                         " /", psFontNames[0],
                         " /", psFontNames[1],
                         " eucfont\n", NULL);
            asciiName = Tk_GetUid(psFontNames[0]);
            kanjiName = Tk_GetUid(psFontNames[1]);
            ckfree((char *)psFontNames);
            Tcl_DStringAppend(&ds, name, -1);
#endif /* USR_RKSJ_PSFONT */
          } else {
            Tcl_DStringAppend(&ds, argv[0], -1);
          }
#else
          Tcl_DStringAppend(&ds, argv[0], -1);
#endif /* TK_KANJI_OK */
          points = (int) size;
          
          ckfree((char *) argv);
          goto findfont;
      }
    }

#ifdef TK_KANJI_OK
    if (fontType == TK_FONT_COMPOUND) {
#ifdef USE_RKSJ_PSFONT
      /* ignore ascii font */
      points = Tk_PostscriptFontName(kanji, &ds);
      if (points < 0) {
          points = TkpConvertPixelToPoint(tkwin, -points);
      }
#else
      int asciiPoints;
      int kanjiPoints;
      char *name = Tk_NameOfFont(tkfont);

      Tcl_AppendResult(interp, "/", name, NULL);

      asciiPoints = Tk_PostscriptFontName(ascii, &ds);
      if (asciiPoints < 0) {
          asciiPoints = TkpConvertPixelToPoint(tkwin, -asciiPoints);
      }
      Tcl_AppendResult(interp, " /", Tcl_DStringValue(&ds), NULL);
      asciiName = Tk_GetUid(Tcl_DStringValue(&ds));
      Tcl_DStringFree(&ds);

      kanjiPoints = Tk_PostscriptFontName(kanji, &ds);
      if (kanjiPoints < 0) {
          kanjiPoints = TkpConvertPixelToPoint(tkwin, -kanjiPoints);
      }
      Tcl_AppendResult(interp, " /", Tcl_DStringValue(&ds), 
                   " eucfont\n", NULL);
      points = (asciiPoints < kanjiPoints) ? asciiPoints : kanjiPoints;
      kanjiName = Tk_GetUid(Tcl_DStringValue(&ds));
      Tcl_DStringFree(&ds);

      Tcl_DStringAppend(&ds, name, -1);
#endif /* USE_RKSJ_PSFONT */
    } else {
      points = Tk_PostscriptFontName(tkfont, &ds);
      if (points < 0) {
          points = TkpConvertPixelToPoint(tkwin, -points);
      }
    }
#else
    points = Tk_PostscriptFontName(tkfont, &ds);
#endif /* TK_KANJI_OK */

    findfont:
    sprintf(pointString, "%d", points);
    Tcl_AppendResult(interp, "/", Tcl_DStringValue(&ds), " findfont ",
          pointString, " scalefont ", (char *) NULL);
#ifdef TK_KANJI_OK
    if (strncasecmp(Tcl_DStringValue(&ds), "Symbol", 7) != 0 &&
      fontType != TK_FONT_COMPOUND && fontType != TK_FONT_2BYTES) {
#else
    if (strncasecmp(Tcl_DStringValue(&ds), "Symbol", 7) != 0) {
#endif /* TK_KANJI_OK */
      Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL);
    }
    Tcl_AppendResult(interp, "setfont\n", (char *) NULL);
#ifdef TK_KANJI_OK
    if (kanjiName != NULL && asciiName != NULL) {
      Tcl_CreateHashEntry(&psInfoPtr->fontTable, asciiName, &i);
      Tcl_CreateHashEntry(&psInfoPtr->fontTable, kanjiName, &i);
    } else {
      Tcl_CreateHashEntry(&psInfoPtr->fontTable, Tcl_DStringValue(&ds), &i);
    }
#else 
    Tcl_CreateHashEntry(&psInfoPtr->fontTable, Tcl_DStringValue(&ds), &i);
#endif /* TK_KANJI_OK */
    Tcl_DStringFree(&ds);

    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * Tk_CanvasPsBitmap --
 *
 *    This procedure is called to output the contents of a
 *    sub-region of a bitmap in proper image data format for
 *    Postscript (i.e. data between angle brackets, one bit
 *    per pixel).
 *
 * Results:
 *    Returns a standard Tcl return value.  If an error occurs
 *    then an error message will be left in interp->result.
 *    If no error occurs, then additional Postscript will be
 *    appended to interp->result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

int
Tk_CanvasPsBitmap(interp, canvas, bitmap, startX, startY, width, height)
    Tcl_Interp *interp;             /* Interpreter for returning Postscript
                               * or error message. */
    Tk_Canvas canvas;               /* Information about canvas. */
    Pixmap bitmap;                  /* Bitmap for which to generate
                               * Postscript. */
    int startX, startY;             /* Coordinates of upper-left corner
                               * of rectangular region to output. */
    int width, height;              /* Height of rectangular region. */
{
    TkCanvas *canvasPtr = (TkCanvas *) canvas;
    TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
    XImage *imagePtr;
    int charsInLine, x, y, lastX, lastY, value, mask;
    unsigned int totalWidth, totalHeight;
    char string[100];
    Window dummyRoot;
    int dummyX, dummyY;
    unsigned dummyBorderwidth, dummyDepth;

    if (psInfoPtr->prepass) {
      return TCL_OK;
    }

    /*
     * The following call should probably be a call to Tk_SizeOfBitmap
     * instead, but it seems that we are occasionally invoked by custom
     * item types that create their own bitmaps without registering them
     * with Tk.  XGetGeometry is a bit slower than Tk_SizeOfBitmap, but
     * it shouldn't matter here.
     */

    XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot,
          (int *) &dummyX, (int *) &dummyY, (unsigned int *) &totalWidth,
          (unsigned int *) &totalHeight, &dummyBorderwidth, &dummyDepth);
    imagePtr = XGetImage(Tk_Display(canvasPtr->tkwin), bitmap, 0, 0,
          totalWidth, totalHeight, 1, XYPixmap);
    Tcl_AppendResult(interp, "<", (char *) NULL);
    mask = 0x80;
    value = 0;
    charsInLine = 0;
    lastX = startX + width - 1;
    lastY = startY + height - 1;
    for (y = lastY; y >= startY; y--) {
      for (x = startX; x <= lastX; x++) {
          if (XGetPixel(imagePtr, x, y)) {
            value |= mask;
          }
          mask >>= 1;
          if (mask == 0) {
            sprintf(string, "%02x", value);
            Tcl_AppendResult(interp, string, (char *) NULL);
            mask = 0x80;
            value = 0;
            charsInLine += 2;
            if (charsInLine >= 60) {
                Tcl_AppendResult(interp, "\n", (char *) NULL);
                charsInLine = 0;
            }
          }
      }
      if (mask != 0x80) {
          sprintf(string, "%02x", value);
          Tcl_AppendResult(interp, string, (char *) NULL);
          mask = 0x80;
          value = 0;
          charsInLine += 2;
      }
    }
    Tcl_AppendResult(interp, ">", (char *) NULL);
    XDestroyImage(imagePtr);
    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * Tk_CanvasPsStipple --
 *
 *    This procedure is called by individual canvas items when
 *    they have created a path that they'd like to be filled with
 *    a stipple pattern.  Given information about an X bitmap,
 *    this procedure will generate Postscript commands to fill
 *    the current clip region using a stipple pattern defined by the
 *    bitmap.
 *
 * Results:
 *    Returns a standard Tcl return value.  If an error occurs
 *    then an error message will be left in interp->result.
 *    If no error occurs, then additional Postscript will be
 *    appended to interp->result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

int
Tk_CanvasPsStipple(interp, canvas, bitmap)
    Tcl_Interp *interp;             /* Interpreter for returning Postscript
                               * or error message. */
    Tk_Canvas canvas;               /* Information about canvas. */
    Pixmap bitmap;                  /* Bitmap to use for stippling. */
{
    TkCanvas *canvasPtr = (TkCanvas *) canvas;
    TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
    int width, height;
    char string[100];
    Window dummyRoot;
    int dummyX, dummyY;
    unsigned dummyBorderwidth, dummyDepth;

    if (psInfoPtr->prepass) {
      return TCL_OK;
    }

    /*
     * The following call should probably be a call to Tk_SizeOfBitmap
     * instead, but it seems that we are occasionally invoked by custom
     * item types that create their own bitmaps without registering them
     * with Tk.  XGetGeometry is a bit slower than Tk_SizeOfBitmap, but
     * it shouldn't matter here.
     */

    XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot,
          (int *) &dummyX, (int *) &dummyY, (unsigned *) &width,
          (unsigned *) &height, &dummyBorderwidth, &dummyDepth);
    sprintf(string, "%d %d ", width, height);
    Tcl_AppendResult(interp, string, (char *) NULL);
    if (Tk_CanvasPsBitmap(interp, (Tk_Canvas) canvasPtr, bitmap, 0, 0,
          width, height) != TCL_OK) {
      return TCL_ERROR;
    }
    Tcl_AppendResult(interp, " StippleFill\n", (char *) NULL);
    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * Tk_CanvasPsY --
 *
 *    Given a y-coordinate in canvas coordinates, this procedure
 *    returns a y-coordinate to use for Postscript output.
 *
 * Results:
 *    Returns the Postscript coordinate that corresponds to
 *    "y".
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

double
Tk_CanvasPsY(canvas, y)
    Tk_Canvas canvas;               /* Token for canvas on whose behalf
                               * Postscript is being generated. */
    double y;                       /* Y-coordinate in canvas coords. */
{
    TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr;

    return psInfoPtr->y2 - y;
}

/*
 *--------------------------------------------------------------
 *
 * Tk_CanvasPsPath --
 *
 *    Given an array of points for a path, generate Postscript
 *    commands to create the path.
 *
 * Results:
 *    Postscript commands get appended to what's in interp->result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

void
Tk_CanvasPsPath(interp, canvas, coordPtr, numPoints)
    Tcl_Interp *interp;             /* Put generated Postscript in this
                               * interpreter's result field. */
    Tk_Canvas canvas;               /* Canvas on whose behalf Postscript
                               * is being generated. */
    double *coordPtr;               /* Pointer to first in array of
                               * 2*numPoints coordinates giving
                               * points for path. */
    int numPoints;                  /* Number of points at *coordPtr. */
{
    TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr;
    char buffer[200];

    if (psInfoPtr->prepass) {
      return;
    }
    sprintf(buffer, "%.15g %.15g moveto\n", coordPtr[0],
          Tk_CanvasPsY(canvas, coordPtr[1]));
    Tcl_AppendResult(interp, buffer, (char *) NULL);
    for (numPoints--, coordPtr += 2; numPoints > 0;
          numPoints--, coordPtr += 2) {
      sprintf(buffer, "%.15g %.15g lineto\n", coordPtr[0],
            Tk_CanvasPsY(canvas, coordPtr[1]));
      Tcl_AppendResult(interp, buffer, (char *) NULL);
    }
}

/*
 *--------------------------------------------------------------
 *
 * GetPostscriptPoints --
 *
 *    Given a string, returns the number of Postscript points
 *    corresponding to that string.
 *
 * Results:
 *    The return value is a standard Tcl return result.  If
 *    TCL_OK is returned, then everything went well and the
 *    screen distance is stored at *doublePtr;  otherwise
 *    TCL_ERROR is returned and an error message is left in
 *    interp->result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

static int
GetPostscriptPoints(interp, string, doublePtr)
    Tcl_Interp *interp;       /* Use this for error reporting. */
    char *string;       /* String describing a screen distance. */
    double *doublePtr;        /* Place to store converted result. */
{
    char *end;
    double d;

    d = strtod(string, &end);
    if (end == string) {
      error:
      Tcl_AppendResult(interp, "bad distance \"", string,
            "\"", (char *) NULL);
      return TCL_ERROR;
    }
    while ((*end != '\0') && isspace(UCHAR(*end))) {
      end++;
    }
    switch (*end) {
      case 'c':
          d *= 72.0/2.54;
          end++;
          break;
      case 'i':
          d *= 72.0;
          end++;
          break;
      case 'm':
          d *= 72.0/25.4;
          end++;
          break;
      case 0:
          break;
      case 'p':
          end++;
          break;
      default:
          goto error;
    }
    while ((*end != '\0') && isspace(UCHAR(*end))) {
      end++;
    }
    if (*end != 0) {
      goto error;
    }
    *doublePtr = d;
    return TCL_OK;
}

Generated by  Doxygen 1.6.0   Back to index