aboutsummaryrefslogtreecommitdiff
path: root/src/cmd/postscript/printfont/printfont.ps
blob: 7a881a4d43649f1987b90315aa21e66c655dd527 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
%
% Formatted font dump. Assumes all fonts include valid FontBBox arrays.
%

/#copies 1 store
/aspectratio 1 def
/landscape false def
/magnification 1 def
/margin 10 def
/orientation 0 def
/rotation 1 def
/xoffset 0 def
/yoffset 0 def

/axescount 0 def
/charwidth false def
/graynotdef 0.85 def
/hireslinewidth 0.2 def
/longnames false def
/maxsize 6.0 def
/minsize 4.5 def
/numbercell true def
/radix 16 def
/labelfont /Helvetica def
/labelspace 36 def
/zerocell 0 def

/roundpage true def
/useclippath true def
/pagebbox [0 0 612 792] def

/inch {72 mul} def
/min {2 copy gt {exch} if pop} def
/max {2 copy lt {exch} if pop} def

/LLx {0 get} bind def
/LLy {1 get} bind def
/URx {2 get} bind def
/URy {3 get} bind def
/BBoxHeight {dup URy exch LLy sub} bind def
/BBoxWidth {dup URx exch LLx sub} bind def

/setup {
	/graylevels [1 0 0] def
	/scratchstring 512 string def
	/Product statusdict begin /product where {pop product}{(Unknown)} ifelse end def
	/Resolution 0 72 dtransform dup mul exch dup mul add sqrt cvi def
	/Version /version where {pop version}{(???)} ifelse def

	landscape {/orientation 90 orientation add def} if

	pagedimensions
	xcenter ycenter translate
	orientation rotation mul rotate
	width 2 div neg height 2 div translate
	xoffset inch yoffset inch neg translate
	margin dup neg translate
	0 labelspace .75 mul neg translate
	magnification dup aspectratio mul scale
	0 0 transform round exch round exch itransform translate

	currentdict /linewidth known not {
		/linewidth Resolution 400 le {0}{hireslinewidth} ifelse def
	} if
} def

/pagedimensions {
	useclippath {
		/pagebbox [clippath pathbbox newpath] def
		roundpage currentdict /roundpagebbox known and {roundpagebbox} if
	} if
	pagebbox aload pop
	4 -1 roll exch 4 1 roll 4 copy
	landscape {4 2 roll} if
	sub /width exch def
	sub /height exch def
	add 2 div /xcenter exch def
	add 2 div /ycenter exch def
} def

/CharSetup {
	/chcode exch def
	/chname Encoding chcode get def
	/chstring ( ) dup 0 chcode put def
	/chknown true def

	graylevels 0 1 put	% initial cell fill
	graylevels 1 0 put	% cell text
	graylevels 2 0 put	% cell border

	FontDict /CharStrings known {
		FontDict /CharStrings get chname known not {
			/chknown false def
			graylevels 0 0 put
			graylevels 1 1 put
		} if
	} if

	chname /.notdef eq {
		/chknown false def
		graylevels 0 graynotdef put
		graylevels 1 graynotdef put
	} if

	/chwid chknown
		{FontDict 1 scalefont setfont chstring stringwidth pop}
		{0}
	ifelse def
} bind def

/CellSetup {
	/gridwidth width margin 2 mul sub def
	/gridheight height labelspace sub margin 2 mul sub def
	/cellwidth gridwidth radix div def
	/cellheight gridheight Entries radix div ceiling div def

	cellwidth cellheight dtransform truncate exch truncate exch idtransform
	/cellheight exch def
	/cellwidth exch def

	labelfont findfont 1 scalefont setfont
	/LabelBBox currentfont /FontBBox get TransformBBox def

	LabelBBox 2 0 Encoding {
		scratchstring cvs stringwidth pop
		2 copy lt {exch} if
		pop
	} forall put

	/CellLabelSize
		cellheight .20 mul cellwidth .90 mul LabelBBox BestFit
		minsize max
		maxsize min
	def
	zerocell CellOrigin cellheight add neg exch neg exch translate
} bind def

/FontSetup {
	FontName findfont 1 scalefont setfont
	/BBox currentfont /FontBBox get TransformBBox def
	/PointSize cellheight .5 mul cellwidth .8 mul BBox BestFit def
	BBox {PointSize mul} forall BBox astore pop

	/xorigin cellwidth BBox BBoxWidth sub 2 div BBox LLx sub def
	/yorigin cellheight BBox BBoxHeight sub 2 div BBox LLy sub def
} bind def

/BestFit {
	/bbox exch def
	bbox BBoxWidth div exch
	bbox BBoxHeight div min
} bind def

/TransformBBox {	% font bbox to user space
	aload pop
	currentfont /FontMatrix get dtransform 4 2 roll
	currentfont /FontMatrix get dtransform 4 2 roll
	4 array astore	% should build user space bbox if all zeros
} bind def

/CellOrigin {
	dup
	exch radix mod cellwidth mul
	exch radix idiv 1 add neg cellheight mul
} bind def

/CellOutline {
	newpath
	CellOrigin moveto
	cellwidth 0 rlineto
	0 cellheight rlineto
	cellwidth neg 0 rlineto
	closepath
} bind def

/LabelCell {
	gsave
	chcode CellOrigin translate
	linewidth .5 mul setlinewidth
	labelfont findfont CellLabelSize scalefont setfont

	numbercell {
		cellwidth .025 mul cellheight .05 mul moveto
		chcode radix scratchstring cvrs show
	} if

	charwidth chknown and {
		/wid chwid 0.0005 add scratchstring cvs 0 5 getinterval def
		cellwidth wid stringwidth pop 1.10 mul sub cellheight .05 mul moveto
		wid show
	} if

	longnames chknown not or {
		cellwidth .025 mul
		cellheight LabelBBox URy CellLabelSize mul sub .05 sub moveto
		Encoding chcode get scratchstring cvs show
	} if

	axescount 1 ge chknown and {	% gsave/grestore if not last
		newpath
		xorigin yorigin translate

		BBox LLx 0 moveto	% baseline
		BBox URx 0 lineto stroke

		axescount 2 ge {	% vertical through current origin
			0 BBox LLy moveto
			0 BBox URy lineto stroke
		} if

		axescount 3 ge {	% vertical through next origin
			chwid PointSize mul BBox LLy
			dtransform round exch round exch idtransform moveto
			0 BBox BBoxHeight rlineto stroke
			%chwid PointSize mul BBox URy lineto stroke
		} if
	} if
	grestore
} bind def

/PlaceChar {
	FontName findfont PointSize scalefont setfont
	chcode CellOrigin moveto
	xorigin yorigin rmoveto
	( ) dup 0 chcode put show
} bind def

/LabelPage {
	labelfont findfont labelspace .75 mul .75 mul 18 min scalefont setfont
	0 labelspace .75 mul .25 mul moveto
	FontName scratchstring cvs show

	labelfont findfont labelspace .25 mul .75 mul 9 min scalefont setfont
	0 gridheight neg moveto
	0 labelspace .25 mul .75 mul neg rmoveto
	Product show ( Version ) show Version show
	( \() show Resolution scratchstring cvs show (dpi\)) show

	gridwidth gridheight neg moveto
        0 labelspace .25 mul .75 mul neg rmoveto
	(size=, ) stringwidth pop neg 0 rmoveto
	PointSize cvi scratchstring cvs stringwidth pop neg 0 rmoveto
	(gray=, ) stringwidth pop neg 0 rmoveto
	graynotdef scratchstring cvs stringwidth pop neg 0 rmoveto
	(linewidth=) stringwidth pop neg 0 rmoveto
	linewidth scratchstring cvs stringwidth pop neg 0 rmoveto
	(size=) show PointSize cvi scratchstring cvs show (, ) show
	(gray=) show graynotdef scratchstring cvs show (, ) show
	(linewidth=) show linewidth scratchstring cvs show
} bind def

%
% Formatted dump of the encoded characters in a single font.
%

/PrintFont {
	/saveobj save def
	/FontName exch def
	/FontDict FontName findfont def
	/Encoding FontDict /Encoding get def
	/Entries Encoding length def

	CellSetup
	FontSetup
	LabelPage
	zerocell 1 Entries 1 sub {
		CharSetup
		graylevels 0 get setgray
		chcode CellOutline fill
		graylevels 1 get setgray
		LabelCell
		PlaceChar
		graylevels 2 get setgray
		linewidth setlinewidth
		chcode CellOutline stroke
	} for
	showpage
	saveobj restore
} bind def

%
% Dump of all ROM and disk fonts - in alphabetical order.
%

/AllFonts {
	/AllFontNames FontDirectory maxlength array def
	AllFontNames 0 0 put

	FontDirectory {pop AllFontNames Insert} forall

	/filenameforall where {
		pop
		(fonts/*)
		{(fonts/) search pop pop pop AllFontNames Insert}
		200 string
		filenameforall
	} if

	1 1 AllFontNames 0 get {
		AllFontNames exch get cvn PrintFont
	} for
} bind def

/Insert {		% name in a sorted list
	/List exch def
	/Name exch 128 string cvs def

	/Slot 1 def
	List 0 get {
		Name List Slot get le {exit} if
		/Slot Slot 1 add def
	} repeat

	List 0 get -1 Slot {
		dup List exch get
		List 3 1 roll exch 1 add exch put
	} for
	List Slot Name put
	List 0 List 0 get 1 add put
} bind def