summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlgs/lib/bdftops.ps
blob: bf310c529de8ee023b00567034c5c22aead2c7c4 (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
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
%    Copyright (C) 1990, 1995, 1996 Aladdin Enterprises.  All rights reserved.
% 
% This software is provided AS-IS with no warranty, either express or
% implied.
% 
% This software is distributed under license and may not be copied,
% modified or distributed except as expressly authorized under the terms
% of the license contained in the file LICENSE in this distribution.
% 
% For more information about licensing, please refer to
% http://www.ghostscript.com/licensing/. For information on
% commercial licensing, go to http://www.artifex.com/licensing/ or
% contact Artifex Software, Inc., 101 Lucas Valley Road #110,
% San Rafael, CA  94903, U.S.A., +1(415)492-9861.

% $Id: bdftops.ps 6300 2005-12-28 19:56:24Z giles $
% bdftops.ps
% Convert a BDF file (possibly with (an) associated AFM file(s))
% to a PostScript Type 1 font (without eexec encryption).
% The resulting font will work with any PostScript language interpreter,
% but not with ATM or other font rasterizers lacking a complete interpreter.

/envBDF 120 dict def
envBDF begin

% "Import" the image-to-path package.
% This also brings in the Type 1 opcodes (type1ops.ps).
   (impath.ps) runlibfile

% "Import" the font-writing package.
   (wrfont.ps) runlibfile
   wrfont_dict begin
     /binary_CharStrings false def
     /binary_tokens false def
     /encrypt_CharStrings true def
     /standard_only true def
   end
   /lenIV 0 def

% Invert the StandardEncoding vector.
   256 dict dup begin
   0 1 255 { dup StandardEncoding exch get exch def } for
   end /StandardDecoding exch def

% Define the properties copied to FontInfo.
   mark
     (COPYRIGHT) /Notice
     (FAMILY_NAME) /FamilyName
     (FULL_NAME) /FullName
     (WEIGHT_NAME) /Weight
   .dicttomark /properties exch def

% Define the character sequences for synthesizing missing composite
% characters in the standard encoding.
   mark
     /AE [/A /E]
     /OE [/O /E]
     /ae [/a /e]
     /ellipsis [/period /period /period]
     /emdash [/hyphen /hyphen /hyphen]
     /endash [/hyphen /hyphen]
     /fi [/f /i]
     /fl [/f /l]
     /germandbls [/s /s]
     /guillemotleft [/less /less]
     /guillemotright [/greater /greater]
     /oe [/o /e]
     /quotedblbase [/comma /comma]
   .dicttomark /composites exch def

% Define the procedure for synthesizing composites.
% This must not be bound.
   /compose
    { exch pop
      FontMatrix Private /composematrix get invertmatrix concat
      0 0 moveto
      dup gsave false charpath pathbbox currentpoint grestore
      6 2 roll setcachedevice show
    } def
% Define the CharString procedure that calls compose, with the string
% on the stack.  This too must remain unbound.
   /compose_proc
    { Private /compose get exec
    } def

% Define aliases for missing characters similarly.
   mark
     /acute /quoteright
     /bullet /asterisk
     /cedilla /comma
     /circumflex /asciicircum
     /dieresis /quotedbl
     /dotlessi /i
     /exclamdown /exclam
     /florin /f
     /fraction /slash
     /grave /quoteleft
     /guilsinglleft /less
     /guilsinglright /greater
     /hungarumlaut /quotedbl
     /periodcentered /asterisk
     /questiondown /question
     /quotedblleft /quotedbl
     /quotedblright /quotedbl
     /quotesinglbase /comma
     /quotesingle /quoteright
     /tilde /asciitilde
   .dicttomark /aliases exch def

% Define overstruck characters that can be synthesized with seac.
   mark
    [ /Aacute /Acircumflex /Adieresis /Agrave /Aring /Atilde
      /Ccedilla
      /Eacute /Ecircumflex /Edieresis /Egrave
      /Iacute /Icircumflex /Idieresis /Igrave
      /Lslash
      /Ntilde
      /Oacute /Ocircumflex /Odieresis /Ograve /Otilde
      /Scaron
      /Uacute /Ucircumflex /Udieresis /Ugrave
      /Yacute /Ydieresis
      /Zcaron
      /aacute /acircumflex /adieresis /agrave /aring /atilde
      /ccedilla
      /eacute /ecircumflex /edieresis /egrave
      /iacute /icircumflex /idieresis /igrave
      /lslash
      /ntilde
      /oacute /ocircumflex /odieresis /ograve /otilde
      /scaron
      /uacute /ucircumflex /udieresis /ugrave
      /yacute /ydieresis
      /zcaron
    ]
    { dup =string cvs
      [ exch dup 0 1 getinterval cvn
	exch dup length 1 sub 1 exch getinterval cvn
      ]
    } forall
     /cent [/c /slash]
     /daggerdbl [/bar /equal]
     /divide [/colon /hyphen]
     /sterling [/L /hyphen]
     /yen [/Y /equal]
   .dicttomark /accentedchars exch def

% ------ Output utilities ------ %

   /ws {psfile exch writestring} bind def
   /wl {ws (\n) ws} bind def
   /wt {=string cvs ws ( ) ws} bind def

% ------ BDF file parsing utilities ------ %

% Define a buffer for reading the BDF file.
   /buffer 400 string def

% Read a line from the BDF file into the buffer.
% Ignore empty (zero-length) lines.
% Define /keyword as the first word on the line.
% Define /args as the remainder of the line.
% If the keyword is equal to commentword, skip the line.
% (If commentword is equal to a space, never skip.)
   /nextline
    {  { bdfile buffer readline not
	  { (Premature EOF\n) print stop } if
	 dup length 0 ne { exit } if pop	 
       }
      loop
      ( ) search
       { /keyword exch def pop }
       { /keyword exch def () }
      ifelse
      /args exch def
      keyword commentword eq { nextline } if
    } bind def

% Get a word argument from args.  We do *not* copy the string.
   /warg		% warg -> string
    { args ( ) search
       { exch pop exch }
       { () }
      ifelse  /args exch def
    } bind def

% Get an integer argument from args.
   /iarg		% iarg -> int
    { warg cvi
    } bind def

% Get a numeric argument from args.
   /narg		% narg -> int|real
    { warg cvr
      dup dup cvi eq { cvi } if
    } bind def

% Convert the remainder of args into a string.
   /remarg		% remarg -> string
    { args copystring
    } bind def

% Get a string argument that occupies the remainder of args.
   /sarg		% sarg -> string
    { args (") anchorsearch
       { pop /args exch def } { pop } ifelse
      args args length 1 sub get (") 0 get eq
       { args 0 args length 1 sub getinterval /args exch def } if
      args copystring
    } bind def

% Check that the keyword is the expected one.
   /checkline		% (EXPECTED-KEYWORD) checkline ->
    { dup keyword ne
       { (Expected ) print =
         (Line=) print keyword print ( ) print args print (\n) print stop
       } if
      pop
    } bind def

% Read a line and check its keyword.
   /getline		% (EXPECTED-KEYWORD) getline ->
    { nextline checkline
    } bind def

% Find the first/last non-zero bit of a non-zero byte.
   /fnzb
    { 0 { exch dup 128 ge { pop exit } { dup add exch 1 add } ifelse }
      loop
    } bind def
   /lnzb
    { 7 { exch dup 1 and 0 ne { pop exit } { -1 bitshift exch 1 sub } ifelse }
      loop
    } bind def

% ------ Type 1 encoding utilities ------ %

% Parse the side bearing and width information that begins a CharString.
% Arguments: charstring.  Result: sbx sby wx wy substring.
   /parsesbw
    { mark exch lenIV
       {		% stack: mark ... string dropcount
         dup 2 index length exch sub getinterval
	 dup 0 get dup 32 lt { pop exit } if
	 dup 246 le
	  { 139 sub exch 1 }
	  { dup 250 le
	     { 247 sub 8 bitshift 108 add 1 index 1 get add exch 2 }
	     { dup 254 le
		{ 251 sub 8 bitshift 108 add 1 index 1 get add neg exch 2 }
		{ pop dup 1 get 128 xor 128 sub
		  8 bitshift 1 index 2 get add
		  8 bitshift 1 index 3 get add
		  8 bitshift 1 index 4 get add exch 5
		} ifelse
	     } ifelse
	  } ifelse
       } loop
      counttomark 3 eq { 0 3 1 roll 0 exch } if
      6 -1 roll pop
    } bind def 

% Find the side bearing and width information that begins a CharString.
% Arguments: charstring.  Result: charstring sizethroughsbw.
   /findsbw
    { dup parsesbw 4 { exch pop } repeat skipsbw
    } bind def
   /skipsbw		% charstring sbwprefix -> sizethroughsbw
    { length 1 index length exch sub
      2 copy get 12 eq { 2 } { 1 } ifelse add
    } bind def

% Encode a number, and append it to a string.
% Arguments: str num.  Result: newstr.
   /concatnum
    { dup dup -107 ge exch 107 le and
       { 139 add 1 string dup 0 3 index put }
       { dup dup -1131 ge exch 1131 le and
          { dup 0 ge { 16#f694 } { neg 16#fa94 } ifelse add
	    2 string dup 0 3 index -8 bitshift put
	    dup 1 3 index 255 and put
	  }
	  { 5 string dup 0 255 put exch
	    2 copy 1 exch -24 bitshift 255 and put
	    2 copy 2 exch -16 bitshift 255 and put
	    2 copy 3 exch -8 bitshift 255 and put
	    2 copy 4 exch 255 and put
	    exch
	  }
	 ifelse
       }
      ifelse exch pop concatstrings
    } bind def

% ------ Point arithmetic utilities ------ %

   /ptadd { exch 4 -1 roll add 3 1 roll add } bind def
   /ptexch { 4 2 roll } bind def
   /ptneg { neg exch neg exch } bind def
   /ptpop { pop pop } bind def
   /ptsub { ptneg ptadd } bind def

% ------ The main program ------ %

   /readBDF		% <infilename> <outfilename> <fontname>
			%   <encodingname> <uniqueID> <xuid> readBDF -> <font>
    { /xuid exch def		% may be null
      /uniqueID exch def	% may be -1
      /encodingname exch def
	/encoding encodingname cvx exec def
      /fontname exch def
      /psname exch def
      /bdfname exch def
      gsave		% so we can set the CTM to the font matrix

%  Open the input files.  We don't open the output file until
%  we've done a minimal validity check on the input.
      bdfname (r) file /bdfile exch def
      /commentword ( ) def

%  Check for the STARTFONT.
      (STARTFONT) getline
      args (2.1) ne { (Not version 2.1\n) print stop } if

%  Initialize the font.
      /Font 20 dict def
      Font begin
      /FontName fontname def
      /PaintType 0 def
      /FontType 1 def
      uniqueID 0 gt { /UniqueID uniqueID def } if
      xuid null ne { /XUID xuid def } if
      /Encoding encoding def
      /FontInfo 20 dict def
      /Private 20 dict def
      currentdict end currentdict end
      exch begin begin		% insert font above environment

%  Initialize the Private dictionary in the font.
      Private begin
      /-! {string currentfile exch readhexstring pop} readonly def
      /-| {string currentfile exch readstring pop} readonly def
      /|- {readonly def} readonly def
      /| {readonly put} readonly def
      /BlueValues [] def
      /lenIV lenIV def
      /MinFeature {16 16} def
      /password 5839 def
      /UniqueID uniqueID def
      end		% Private

%  Invert the Encoding, for synthesizing composite characters.
      /decoding encoding length dict def
      0 1 encoding length 1 sub
       { dup encoding exch get exch decoding 3 1 roll put }
      for

%  Now open the output file.
      psname (w) file /psfile exch def

%  Put out a header compatible with the Adobe "standard".
      (%!FontType1-1.0: ) ws fontname wt (000.000) wl
      (% This is a font description converted from ) ws
	bdfname wl
      (%   by bdftops running on ) ws
      statusdict /product get ws ( revision ) ws
      revision =string cvs ws (.) wl

%  Copy the initial comments, up to FONT.
      true
       { nextline
	 keyword (COMMENT) ne {exit} if
	  { (% Here are the initial comments from the BDF file:\n%) wl
	  } if false
	 (%) ws remarg wl
       } loop pop
      () wl
      /commentword (COMMENT) def	% do skip comments from now on

%  Read and process the FONT, SIZE, and FONTBOUNDINGBOX.
      % If we cared about FONT, we'd use it here.  If the BDF files
      % from MIT had PostScript names rather than X names, we would
      % care; but what's there is unusable, so we discard FONT.
      % The FONTBOUNDINGBOX may not be reliable, so we discard it too.
      (FONT) checkline
      (SIZE) getline
	/pointsize iarg def   /xres iarg def   /yres iarg def
      (FONTBOUNDINGBOX) getline
      nextline

%  Initialize the font bounding box bookeeping.
      /fbbxo 1000 def
      /fbbyo 1000 def
      /fbbxe -1000 def
      /fbbye -1000 def

%  Read and process the properties.  We only care about a few of them.
      keyword (STARTPROPERTIES) eq
       { iarg
          { nextline
	    properties keyword known
	     { FontInfo properties keyword get sarg readonly put
	     } if
	  } repeat
         (ENDPROPERTIES) getline
	 nextline
       } if

%  Compute and set the FontMatrix.
      Font /FontMatrix
       [ 0.001 0 0 0.001 xres mul yres div 0 0 ] readonly
      dup setmatrix put

%  Read and process the header for the bitmaps.
      (CHARS) checkline
	/ccount iarg def

%  Initialize the CharStrings dictionary.
      /charstrings ccount
	composites length add
	aliases length add
	accentedchars length add
	1 add dict def		% 1 add for .notdef
      /isfixedwidth true def
      /fixedwidth null def
      /subrcount 0 def
      /subrs [] def

%  Read the bitmap data.  This reads the remainder of the file.
%  We do this before processing the bitmaps so that we can compute
%  the correct FontBBox first.
      /chardata ccount dict def
      ccount -1 1
       { (STARTCHAR) getline
           /charname remarg def
	 (ENCODING) getline
	   /eindex iarg def
	   eindex dup 0 ge exch 255 le and
	    { charname /charname StandardEncoding eindex get def
	      charname /.notdef eq eindex 0 gt and
	       { /charname (A) eindex =string cvs concatstrings cvn def
	       }
	      if
	      (/) print charname =string cvs print (,) print print
	    }
	    { (/) print charname print
	    }
	   ifelse
	   10 mod 1 eq { (\n) print flush } if
	 (SWIDTH) getline
	   /swx iarg pointsize mul 1000 div xres mul 72 div def
	   /swy iarg pointsize mul 1000 div xres mul 72 div def
	 (DWIDTH) getline		% Ignore, use SWIDTH instead
	 (BBX) getline
	   /bbw iarg def  /bbh iarg def  /bbox iarg def  /bboy iarg def
	 nextline
	 keyword (ATTRIBUTES) eq
	  { nextline
	  } if
	 (BITMAP) checkline

% Update the font bounding box.
	 /fbbxo fbbxo bbox .min def
	 /fbbyo fbbyo bboy .min def
	 /fbbxe fbbxe bbox bbw add .max def
	 /fbbye fbbye bboy bbh add .max def

% Read the bits for this character.
	 /raster bbw 7 add 8 idiv def
	 /cbits raster bbh mul string def
	 cbits length 0 gt
	  { 0 raster cbits length raster sub
	      { cbits exch raster getinterval
	        bdfile buffer readline not
	         { (EOF in bitmap\n) print stop } if
		    % stack has <cbits.interval> <buffer.interval>
	        0 () /SubFileDecode filter
	        exch 2 copy readhexstring pop pop pop closefile
	      } for
	  } if

         (ENDCHAR) getline

% Save the character data.
	 chardata charname [swx swy bbw bbh bbox bboy cbits] put
       } for

      (ENDFONT) getline

% Allocate the buffers for the bitmap and the outline,
% according to the font bounding box.
      /fbbw fbbxe fbbxo sub def
      /fbbh fbbye fbbyo sub def
      /fraster fbbw 7 add 8 idiv def
      /bits fraster fbbh mul 200 .max 65535 .min string def
      /outline bits length 16 mul 65535 .min string def

%  Process the characters.
      chardata
       { exch /charname exch def  aload pop
	 /cbits exch def
	 /bboy exch def   /bbox exch def
	 /bbh exch def   /bbw exch def
	 /swy exch def   /swx exch def

% The bitmap handed to type1imagepath must have the correct height,
% because type1imagepath uses this to compute the scale factor,
% so we have to clear the unused parts of it.
	 /raster bbw 7 add 8 idiv def
	 bits dup 0 1 raster fbbh mul 1 sub
	  { 0 put dup } for
	 pop pop
	 bits raster fbbh bbh sub mul cbits putinterval

%  Compute the font entry, converting the bitmap to an outline.
	 bits 0 raster fbbh mul getinterval	% the bitmap image
	 bbw   fbbh				% bitmap width & height
	 swx   swy				% width x & y
	 bbox neg   bboy neg			% origin x & y
	 	% Account for lenIV when converting the outline.
	 outline  lenIV  outline length lenIV sub  getinterval
         type1imagepath
         length lenIV add
	 outline exch 0 exch getinterval

% Check for a fixed width font.
	 isfixedwidth
	  { fixedwidth null eq
	     { /fixedwidth swx def }
	     { fixedwidth swx ne { /isfixedwidth false def } if }
	    ifelse
	  } if

% Finish up the character.
	 copystring
	 charname exch charstrings 3 1 roll put
       } forall

%  Add CharStrings entries for aliases.
      aliases
       { charstrings 2 index known not charstrings 2 index known and
          { charstrings exch get charstrings 3 1 roll put
	  }
	  { pop pop
	  }
	 ifelse
       }
      forall

%  If this is not a fixed-width font, synthesize missing characters
%  out of available ones.
      isfixedwidth not
       { false composites
	  { 1 index charstrings exch known not
	    1 index { decoding exch known and } forall
	     { ( /) print 1 index bits cvs print
	       /combine exch def
	       0 1 combine length 1 sub
		{ dup combine exch get decoding exch get
		  bits 3 1 roll put
		} for
	       bits 0 combine length getinterval copystring
	       [ exch /compose_proc load aload pop ] cvx
	       charstrings 3 1 roll put
	       pop true
	     }
	     { pop pop }
	    ifelse
	  }
	 forall flush
	  { Private /composematrix matrix put
	    Private /compose /compose load put
	  }
	 if
       }
      if

%  Synthesize accented characters with seac if needed and possible.
      accentedchars
       { aload pop /accent exch def /base exch def
         buffer cvs /accented exch def
	 charstrings accented known not
	 charstrings base known and
	 charstrings accent known and
	 StandardDecoding base known and
	 StandardDecoding accent known and
	 encoding StandardDecoding base get get base eq and
	 encoding StandardDecoding accent get get accent eq and
	  { ( /) print accented print
	    charstrings base get findsbw 0 exch getinterval
	    /acstring exch def		% start with sbw of base
	    charstrings accent get parsesbw
	    4 { pop } repeat		% just leave sbx
	    acstring exch concatnum
	    0 concatnum 0 concatnum		% adx ady
	    decoding base get concatnum		% bchar
	    decoding accent get concatnum	% achar
	    s_seac concatstrings
	    charstrings exch accented copystring exch put
	  } if
       } forall

%  Make a CharStrings entry for .notdef.
      outline lenIV <8b8b0d0e> putinterval	% 0 0 hsbw endchar
      charstrings /.notdef outline 0 lenIV 4 add getinterval copystring put

%  Encrypt the CharStrings and Subrs (in place).
      charstrings
       {	% Be careful not to encrypt aliased characters twice,
		% since they share their CharString.
	 aliases 2 index known
	  { charstrings aliases 3 index get .knownget
	     { 1 index ne }
	     { true }
	    ifelse
	  }
	  { true
	  }
	 ifelse
	 1 index type /stringtype eq and
          { 4330 exch dup .type1encrypt exch pop
	    readonly charstrings 3 1 roll put
	  }
	  { pop pop
	  }
	 ifelse
       }
      forall
      0 1 subrcount 1 sub
       { dup subrs exch get
	 4330 exch dup .type1encrypt exch pop
	 subrs 3 1 roll put
       }
      for

%  Make most of the remaining entries in the font dictionaries.

% The Type 1 font machinery really only works with a 1000 unit
% character coordinate system.  Set this up here, by computing the factor
% to make the X entry in the FontMatrix come out at exactly 0.001.
      /fontscale 1000 fbbh div yres mul xres div def
      Font /FontBBox
       [ fbbxo fontscale mul
	 fbbyo fontscale mul
	 fbbxe fontscale mul
	 fbbye fontscale mul
       ] cvx readonly put
      Font /CharStrings charstrings readonly put
      FontInfo /FullName known not
       { % Some programs insist on FullName being present.
         FontInfo /FullName FontName dup length string cvs put
       }
      if
      FontInfo /isFixedPitch isfixedwidth put
      subrcount 0 gt
       { Private /Subrs subrs 0 subrcount getinterval readonly put
       } if

%  Determine the italic angle and underline position
%  by actually installing the font.
      save
      /_temp_ Font definefont setfont
      [1000 0 0 1000 0 0] setmatrix		% mitigate rounding problems
% The italic angle is the multiple of -5 degrees
% that minimizes the width of the 'I'.
      0 9999 0 5 85
       { dup rotate
         newpath 0 0 moveto (I) false charpath
	 dup neg rotate
         pathbbox pop exch pop exch sub
	 dup 3 index lt { 4 -2 roll } if
	 pop pop
       }
      for pop
% The underline position is halfway between the bottom of the 'A'
% and the bottom of the FontBBox.
      newpath 0 0 moveto (A) false charpath
      FontMatrix concat
      pathbbox pop pop exch pop
%  Put the values in FontInfo.
      3 -1 roll
      restore
      Font /FontBBox get 1 get add 2 div cvi
      dup FontInfo /UnderlinePosition 3 -1 roll put
      2 div abs FontInfo /UnderlineThickness 3 -1 roll put
      FontInfo /ItalicAngle 3 -1 roll put

%  Clean up and finish.
      grestore
      bdfile closefile
      Font currentdict end end begin		% remove font from dict stack
      (\n) print flush

    } bind def

% ------ Reader for AFM files ------ %

% Dictionary for looking up character keywords
   /cmdict 6 dict dup begin
      /C { /c iarg def } def
      /N { /n warg copystring def } def
      /WX { /w narg def } def
      /W0X /WX load def
      /W /WX load def
      /W0 /WX load def
   end def

   /readAFM		% fontdict afmfilename readAFM -> fontdict
    { (r) file /bdfile exch def
      /Font exch def
      /commentword (Comment) def

%  Check for the StartFontMetrics.
      (StartFontMetrics) getline
      args cvr 2.0 lt { (Not version 2.0 or greater\n) print stop } if

%  Look for StartCharMetrics, then parse the character metrics.
%  The only information we care about is the X width.
      /metrics 0 dict def
       { nextline
         keyword (EndFontMetrics) eq { exit } if
	 keyword (StartCharMetrics) eq
	  { iarg dup dict /metrics exch def
	     { /c -1 def /n null def /w null def
	       nextline buffer
		{ token not { exit } if
		  dup cmdict exch known
		   { exch /args exch def   cmdict exch get exec   args }
		   { pop }
		  ifelse
		} loop
	       c 0 ge n null ne or w null ne and
		{ n null eq { /n Font /Encoding get c get def } if
		  metrics n w put
		}
	       if
	     }
	    repeat
	    (EndCharMetrics) getline
	  } if
       } loop

%  Insert the metrics in the font.
       metrics length 0 ne
	{ Font /Metrics metrics readonly put
	} if
      Font
    } bind def

end		% envBDF

% Enter the main program in the current dictionary.
/bdfafmtops		% infilename afmfilename* outfilename fontname
			%   encodingname uniqueID xuid
 { envBDF begin
     7 -2 roll exch 7 2 roll	% afm* in out fontname encodingname uniqueID xuid
     readBDF		% afm* font
     exch { readAFM } forall
     save exch
     dup /FontName get exch definefont
     setfont
     psfile writefont
     restore
     psfile closefile
   end
 } bind def

% If the program was invoked from the command line, run it now.
[ shellarguments
 { counttomark 4 ge
    { dup 0 get
      dup 48 ge exch 57 le and		% last arg starts with a digit?
       { /StandardEncoding }		% no encodingname
       { cvn }				% have encodingname
      ifelse
      exch (.) search			% next-to-last arg has . in it?
       { mark 4 1 roll			% have xuid
          { cvi exch pop exch (.) search not { exit } if }
	 loop cvi ]
	 3 -1 roll cvi exch
       }
       { cvi null			% no xuid
       }
      ifelse
      counttomark 5 roll
      counttomark 6 sub array astore
      7 -2 roll cvn 7 -3 roll		% make sure fontname is a name
      bdfafmtops
    }
    { cleartomark
      (Usage:\n  bdftops xx.bdf [yy1.afm ...] zz.gsf fontname uniqueID [xuid] [encodingname]\n) print flush
      mark
    }
   ifelse
 }
if pop