3 # This file generates the postscript prolog used by Tk.
6 # Creates Postscript encoding vector for ISO-8859-1 (could theoretically
7 # handle any 8-bit encoding, but Tk never generates characters outside
10 proc CreatePostscriptEncoding {} {
12 # Now check for known. Even if it is known, it can be other than we
13 # need. GhostScript seems to be happy with such approach
15 for {set i 0} {$i<256} {incr i 8} {
16 for {set j 0} {$j<8} {incr j} {
17 set enc [encoding convertfrom "iso8859-1" \
18 [format %c [expr {$i+$j}]]]
21 set hexcode [format %04X [scan $enc %c]]
23 if {[info exists psglyphs($hexcode)]} {
24 append result "/$psglyphs($hexcode)"
26 append result "/space"
35 # List of adobe glyph names. Converted from glyphlist.txt, downloaded from
402 0390 iotadieresistonos
433 03B0 upsilondieresistonos
736 207D parenleftsuperior
737 207E parenrightsuperior
749 208D parenleftinferior
750 208E parenrightinferior
942 F6DE threequartersemdash
968 F6F8 Hungarumlautsmall
1017 F7A1 exclamdownsmall
1023 F7BF questiondownsmall
1026 F7E2 Acircumflexsmall
1034 F7EA Ecircumflexsmall
1038 F7EE Icircumflexsmall
1044 F7F4 Ocircumflexsmall
1050 F7FB Ucircumflexsmall
1093 variable ps_preamble {}
1096 namespace ensemble create
1097 namespace export {[a-z]*}
1098 proc literal {string} {
1099 upvar 0 ::tk::ps_preamble preamble
1100 foreach line [split $string \n] {
1101 set line [string trim $line]
1102 if {$line eq ""} continue
1103 append preamble $line \n
1107 proc variable {name value} {
1108 upvar 0 ::tk::ps_preamble preamble
1109 append preamble "/$name $value def\n"
1112 proc function {name body} {
1113 upvar 0 ::tk::ps_preamble preamble
1114 append preamble "/$name \{"
1115 foreach line [split $body \n] {
1116 set line [string trim $line]
1117 # Strip blank lines and comments from the bodies of functions
1118 if {$line eq "" } continue
1119 if {[string match {[%#]*} $line]} continue
1120 append preamble $line " "
1122 append preamble "\} bind def\n"
1129 % This is a standard prolog for Postscript generated by Tk's canvas
1132 ps variable CurrentEncoding [CreatePostscriptEncoding]
1133 ps literal {50 dict begin}
1135 # The definitions below just define all of the variables used in any of
1136 # the procedures here. This is needed for obscure reasons explained on
1137 # p. 716 of the Postscript manual (Section H.2.7, "Initializing
1138 # Variables," in the section on Encapsulated Postscript).
1139 ps variable baseline 0
1140 ps variable stipimage 0
1141 ps variable height 0
1142 ps variable justify 0
1143 ps variable lineLength 0
1144 ps variable spacing 0
1145 ps variable stipple 0
1146 ps variable strings 0
1147 ps variable xoffset 0
1148 ps variable yoffset 0
1149 ps variable tmpstip null
1150 ps variable baselineSampler "( TXygqPZ)"
1151 # Put an extra-tall character in; done this way to avoid encoding trouble
1152 ps literal {baselineSampler 0 196 put}
1154 ps function cstringshow {
1156 dup type /stringtype eq
1157 { show } { glyphshow }
1162 ps function cstringwidth {
1165 dup type /stringtype eq
1167 currentfont /Encoding get exch 1 exch put (\001)
1171 exch 3 1 roll add 3 1 roll add exch
1175 # font ISOEncode font
1177 # This procedure changes the encoding of a font from the default
1178 # Postscript encoding to current system encoding. It's typically invoked
1179 # just before invoking "setfont". The body of this procedure comes from
1180 # Section 5.6.1 of the Postscript book.
1181 ps function ISOEncode {
1182 dup length dict begin
1183 {1 index /FID ne {def} {pop pop} ifelse} forall
1184 /Encoding CurrentEncoding def
1187 % I'm not sure why it's necessary to use "definefont" on this new
1188 % font, but it seems to be important; just use the name "Temporary"
1190 /Temporary exch definefont
1195 # This procedure converts the current path into a clip area under the
1196 # assumption of stroking. It's a bit tricky because some Postscript
1197 # interpreters get errors during strokepath for dashed lines. If this
1198 # happens then turn off dashes and try again.
1199 ps function StrokeClip {
1200 {strokepath} stopped {
1201 (This Postscript printer gets limitcheck overflows when) =
1202 (stippling dashed lines; lines will be printed solid instead.) =
1203 [] 0 setdash strokepath} if
1207 # desiredSize EvenPixels closestSize
1209 # The procedure below is used for stippling. Given the optimal size of a
1210 # dot in a stipple pattern in the current user coordinate system, compute
1211 # the closest size that is an exact multiple of the device's pixel
1212 # size. This allows stipple patterns to be displayed without aliasing
1214 ps function EvenPixels {
1215 % Compute exact number of device pixels per stipple dot.
1216 dup 0 matrix currentmatrix dtransform
1217 dup mul exch dup mul add sqrt
1218 % Round to an integer, make sure the number is at least 1, and
1219 % compute user coord distance corresponding to this.
1220 dup round dup 1 lt {pop 1} if
1224 # width height string StippleFill --
1226 # Given a path already set up and a clipping region generated from it,
1227 # this procedure will fill the clipping region with a stipple pattern.
1228 # "String" contains a proper image description of the stipple pattern and
1229 # "width" and "height" give its dimensions. Each stipple dot is assumed to
1230 # be about one unit across in the current user coordinate system. This
1231 # procedure trashes the graphics state.
1232 ps function StippleFill {
1233 % The following code is needed to work around a NeWSprint bug.
1234 /tmpstip 1 index def
1235 % Change the scaling so that one user unit in user coordinates
1236 % corresponds to the size of one stipple dot.
1237 1 EvenPixels dup scale
1238 % Compute the bounding box occupied by the path (which is now the
1239 % clipping region), and round the lower coordinates down to the
1240 % nearest starting point for the stipple pattern. Be careful about
1241 % negative numbers, since the rounding works differently on them.
1244 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll
1245 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll
1246 % Stack now: width height string y1 y2 x1 x2
1247 % Below is a doubly-nested for loop to iterate across this area
1248 % in units of the stipple pattern size, going up columns then
1249 % across rows, blasting out a stipple-pattern-sized rectangle at
1252 2 index 5 index 3 index {
1253 % Stack now: width height string y1 y2 x y
1255 1 index exch translate
1256 5 index 5 index true matrix tmpstip imagemask
1266 # Given a color value already set for output by the caller, adjusts that
1267 # value to a grayscale or mono value if requested by the CL variable.
1268 ps function AdjustColor {
1272 .5 lt {0} {1} ifelse
1278 # x y strings spacing xoffset yoffset justify stipple DrawText --
1280 # This procedure does all of the real work of drawing text. The color and
1281 # font must already have been set by the caller, and the following
1282 # arguments must be on the stack:
1284 # x, y - Coordinates at which to draw text.
1285 # strings - An array of strings, one for each line of the text item, in
1286 # order from top to bottom.
1287 # spacing - Spacing between lines.
1288 # xoffset - Horizontal offset for text bbox relative to x and y: 0 for
1289 # nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.
1290 # yoffset - Vertical offset for text bbox relative to x and y: 0 for
1291 # nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.
1292 # justify - 0 for left justification, 0.5 for center, 1 for right justify.
1293 # stipple - Boolean value indicating whether or not text is to be drawn in
1294 # stippled fashion. If text is stippled, function StippleText
1295 # must have been defined to call StippleFill in the right way.
1297 # Also, when this procedure is invoked, the color and font must already
1298 # have been set for the text.
1299 ps function DrawText {
1306 % First scan through all of the text to find the widest line.
1310 dup lineLength gt {/lineLength exch def} {pop} ifelse
1313 % Compute the baseline offset and the actual font height.
1314 0 0 moveto baselineSampler false charpath
1315 pathbbox dup /baseline exch def
1316 exch pop exch sub /height exch def pop
1318 % Translate and rotate coordinates first so that the origin is at
1319 % the upper-left corner of the text's bounding box. Remember that
1320 % angle for rotating, and x and y for positioning are still on the
1324 lineLength xoffset mul
1325 strings length 1 sub spacing mul height add yoffset mul translate
1326 % Now use the baseline and justification information to translate
1327 % so that the origin is at the baseline and positioning point for
1328 % the first line of text.
1329 justify lineLength mul baseline neg translate
1330 % Iterate over each of the lines to output it. For each line,
1331 % compute its width again so it can be properly justified, then
1334 dup cstringwidth pop
1335 justify neg mul 0 moveto
1337 % The text is stippled, so turn it into a path and print
1338 % by calling StippledText, which in turn calls
1339 % StippleFill. Unfortunately, many Postscript interpreters
1340 % will get overflow errors if we try to do the whole
1341 % string at once, so do it a character at a time.
1345 dup type /stringtype eq {
1346 % This segment is a string.
1348 char 0 3 -1 roll put
1351 char true charpath clip StippleText
1353 char stringwidth translate
1357 % This segment is glyph name
1358 % Temporary override
1359 currentfont /Encoding get exch 1 exch put
1361 gsave (\001) true charpath clip StippleText
1363 (\001) stringwidth translate
1368 } {cstringshow} ifelse
1369 0 spacing neg translate
1373 # Define the "TkPhoto" function variants, which are modified versions
1374 # of the original "transparentimage" function posted by ian@five-d.com
1375 # (Ian Kemmish) to comp.lang.postscript. For a monochrome colorLevel
1376 # this is a slightly different version that uses the imagemask command
1379 ps function TkPhotoColor {
1383 /transparent 1 string def
1384 transparent 0 tinteger put
1386 olddict /DataSource get dup type /filetype ne {
1387 olddict /DataSource 3 -1 roll
1388 0 () /SubFileDecode filter put
1392 /newdict olddict maxlength dict def
1393 olddict newdict copy pop
1394 /w newdict /Width get def
1395 /crpp newdict /Decode get length 2 idiv def
1397 /pix w crpp mul string def
1398 /substrlen 2 w log 2 log div floor exp cvi def
1401 0 1 substrlen 1 sub {
1402 1 index exch tinteger put
1404 /substrlen substrlen 2 idiv def
1405 substrlen 0 eq {exit} if
1407 /h newdict /Height get def
1408 1 w div 1 h div matrix scale
1409 olddict /ImageMatrix get exch matrix concatmatrix
1410 matrix invertmatrix concat
1411 newdict /Height 1 put
1412 newdict /DataSource pix put
1413 /mat [w 0 0 h 0 0] def
1414 newdict /ImageMatrix mat put
1416 mat 5 3 -1 roll neg put
1417 olddict /DataSource get str readstring pop pop
1420 olddict /DataSource get pix readstring pop pop
1422 tail transparent search dup /done exch not def
1423 {exch pop exch pop} if
1427 pix x crpp mul w1 crpp mul getinterval put
1428 newdict /Width w1 put
1432 /tail tail w1 tail length w1 sub getinterval def
1436 anchorsearch {pop} if
1439 tail length 0 eq {exit} if
1440 /x w tail length sub def
1446 ps function TkPhotoMono {
1449 /dummyInteger exch def
1451 olddict /DataSource get dup type /filetype ne {
1452 olddict /DataSource 3 -1 roll
1453 0 () /SubFileDecode filter put
1457 /newdict olddict maxlength dict def
1458 olddict newdict copy pop
1459 /w newdict /Width get def
1460 /pix w 7 add 8 idiv string def
1461 /h newdict /Height get def
1462 1 w div 1 h div matrix scale
1463 olddict /ImageMatrix get exch matrix concatmatrix
1464 matrix invertmatrix concat
1465 newdict /Height 1 put
1466 newdict /DataSource pix put
1467 /mat [w 0 0 h 0 0] def
1468 newdict /ImageMatrix mat put
1470 mat 5 3 -1 roll neg put
1471 0.000 0.000 0.000 setrgbcolor
1472 olddict /DataSource get pix readstring pop pop
1473 newdict /DataSource pix put
1475 1.000 1.000 1.000 setrgbcolor
1476 olddict /DataSource get pix readstring pop pop
1477 newdict /DataSource pix put
1484 ps literal %%EndProlog
1487 proc tk::ensure_psenc_is_loaded {} {
OSDN Git Service
