⟦5206e43c9⟧

TextFile

{$C+} {Enable subrange checking.}
program pxtogf( output );
{-----------------------------------------------------------------
	This reads .pxl files and writes out an equivalent .gf file.
        It was ported to Unix by Karl Berry (me), who got it from
        Barbara Beeton at the American Mathematical Society. I
        don't know whom she got it from.
-----------------------------------------------------------------}
\f

const
	pxlid = 1001;		{input as a long word}
	gfid = 131;		{output is a single byte}
	sig = 223;		{gf files finish with 4 or more of these}
	asciimax = 127;		{128 characters maximum in pxl files}
	pxlendbytes = 2068;	{512 + 5 longwords, fixed at end of pxl files}
	ppi = 72.27;		{points per inch, as in tex}
	stringmax = 32;	{length of character strings, a 1 byte quantity}
	pxlbufsize = 99; {bytes allowed per a row in pxl file minus one (=3 mod 4)}

	commentstring = 'PXtoGF output 7/4/1776.';
	headerstring =  'This is PXtoGF, version 0.99 for Berkeley Unix.';

	black = true;
	white = false;
	allwhite = 0;		{encodings of solid color bytes in pxl files}
	allblack = 255;

	two16 = 65536;		{for scaling scaled integers, especially hppp/vppp}
	fix = 1048576;		{Knuth's scaling scheme}

	pre = 247;		{these are all gf opcodes}
	boc = 67;
	boc1 = 68;
	eoc = 69;
	post = 248;
	postpost = 249;
	charloc = 245;
	charloc0 = 246;
	paint0 = 0;
	paint1 = 1;
	paintone =  64;
	painttwo =  65;
	paintthr =  66;
	skip0 = 70;
	skipone = 71;
	skiptwo = 72;
	skipthr = 73;
	newrow0 = 74;
{	xxx1 = 239;}

	bigint = 1073741824;	{31 bits or so}
	maxnewrow = 164;	{last new row opcode is newrow0 + maxnewrow}
	maxpaint = 63;		{last no parameter paint command is
				 paint0 + maxpaint}
\f

type
	byte = 0..255;
	longword = array[1..4] of byte;
	bitpos = 0..8;
	bytestobits = array[byte] of bitpos;
	bitstobytes = array[bitpos] of byte;

	string = packed array[1..stringmax] of char;

	fontfile = packed file of -128..127;

	charrec = record
	    code: 0..asciimax;
	    pixelwidth,
	    pixelheight,
	    xoffset,
	    yoffset,
	    pxlrasterptr,
	    gfbocptr,
	    tfmwidth {a real fraction * fix}
		:integer;
	end;
	fontarray = array[0..asciimax] of charrec;
	    {corresponds roughly to pxl's font directory}
	pxlbufarray = array[0..pxlbufsize] of byte;
\f

var
	gfcomment: string;

	pxlfile,gffile: fontfile;
        pxlfilename,gffilename: string;
        
	fileok: boolean;
	i: integer;
        charcount: integer;
        
	font: fontarray;

	gfbytes, {bytes "put" to date, also an index to byte about to be put}
	specials,	{number of bytes of specials before next boc}
	postptr,	{index of the post byte in the gf file}
	postminm,	{font-wide extremes: }
	postmaxm,
	postminn,
	postmaxn,
	sum,		{pxl's checksum exactly}
	mag,		{pxl's magnification exactly}
	dsize 		{pxl's design size exactly}
	    : integer;

	firstblack: bytestobits;	{constant arrays initialized by init}
	blackleftof: bitstobytes;

	pxlbuf:  pxlbufarray;		{holds current row from pxl file}
	pxlbyte, pxlbuflimit: integer;	{current and final byte number in pxlbuf}
	pxlbufend: integer;		{total number of bytes read into pxlbuf}
	pxlbit: integer;		{bit position in current byte}
	pxlcolor: boolean;		{color that we are ready to paint at pxlbit}
\f

{ simple arithmetics: }
 
{function max(m,n:integer):integer;
begin
    if m > n then max := m else max := n;
end;
 
function min(m,n:integer):integer;
begin
    if m < n then min := m else min := n;
end;
} 
function ceiling(n,d:integer):integer;
begin
    ceiling := (n+d-1) div d;
end;
 
\f

{ special reset/rewrite }


procedure resetfontfile
{----------------------------------------------------------------}
(   var	xfile: fontfile;
    var fileexists: boolean );
{-----------------------------------------------------------------
	all special switching done here, also check for existence
-----------------------------------------------------------------}
begin
    reset(xfile,pxlfilename);
    fileexists := true; {can't check on unix.}
    if not fileexists then writeln('error: reset non-existent file.');
end;
 
 
procedure rewritefontfile
{----------------------------------------------------------------}
(   var	xfile: fontfile );
{-----------------------------------------------------------------
	All special switching done here, also check for existence. On
Unix, just write over an existing file.
-----------------------------------------------------------------}
begin
{commented out for Unix:    reset(xfile,'','/o');
    if not eof(xfile) then begin
	write('warning: gffile already exists. type <cr> to continue.');
	read(ch);
    end;}
    rewrite(xfile,gffilename);
end;
\f

{ read 1,2,4 bytes }

function read1byte
{----------------------------------------------------------------}
(   var	xfile: fontfile ): integer;
{-----------------------------------------------------------------
	gets an 8 bit number out of a file of bytes.
	obviously advances xfile^ by 1 byte.
        Unix Pascal bytes are -128..127; we convert.
-----------------------------------------------------------------}
var	a: byte;
b:-128..127;
begin
    b := xfile^; get(xfile);
    if b < 0 then a := b + 256
    else a := b;
    
    read1byte := a;
end;


{Here is a more efficient way to read a row of pixels, one byte at a time. }

procedure readpxlbuf;
var i: integer;
b: -128..127;
begin
    for i := 0 to pxlbufend
	 do begin
            b := pxlfile^; get(pxlfile);
            if b < 0 then pxlbuf[i]:=b+256
            else pxlbuf[i]:=b;
	    end;
    pxlbyte := 0;
    pxlbit := 0;
    pxlcolor := white;
end;


function read2bytes
{----------------------------------------------------------------}
(   var	xfile: fontfile ): integer;
{-----------------------------------------------------------------
	gets a 16 bit number out of a file of bytes.
	obviously advances xfile^ by 2 bytes.
-----------------------------------------------------------------}
var	a,b: byte;
begin
    a := read1byte( xfile );
    b := read1byte( xfile );
    read2bytes := a * 256 + b;
end;

function readsigned2bytes
{----------------------------------------------------------------}
(   var	xfile: fontfile ): integer;
{-----------------------------------------------------------------
	gets a 16 bit number out of a file of bytes.
	obviously advances xfile^ by 2 bytes.
-----------------------------------------------------------------}
var	a,b: byte;
begin
    a := read1byte( xfile );
    b := read1byte( xfile );
    if a < 128 then begin
	readsigned2bytes := a * 256 + b;
    end else begin
	readsigned2bytes := (a-256)*256 + b;
    end;
end;

function read4bytes
{----------------------------------------------------------------}
(   var	xfile: fontfile ): integer;
{-----------------------------------------------------------------
	gets a 32 bit number out of a file of bytes.
	obviously advances xfile^ by 4 bytes.
-----------------------------------------------------------------}
var	a,b,c,d: byte;
begin
    a := read1byte( xfile ); 
    b := read1byte( xfile );
    c := read1byte( xfile ); 
    d := read1byte( xfile );
    if a < 128 then begin
	read4bytes := ((a*256+b)*256+c)*256+d;
    end else begin
	read4bytes := (((a-256)*256+b)*256+c)*256+d;
    end;
end;
\f

{ write 1,2,4 bytes }

procedure write1byte
{----------------------------------------------------------------}
(   var	xfile: fontfile;
	i: integer );
{-----------------------------------------------------------------
	0 <= i <= 2^8 - 1
-----------------------------------------------------------------}
var b:-128..127;{convert back to unix pascal bytes.}

begin
{*** 	if (i < 0) or (i > 255) then begin
***	    writeln('error: write1byte: ',i:0);
***	end else begin }
    if i>127
    then b := i - 256
    else b := i;
    xfile^ := b; put(xfile);
    gfbytes := gfbytes + 1;
{***	end;}
end;

procedure write2bytes
{----------------------------------------------------------------}
(   var	xfile: fontfile;
	i: integer );
{-----------------------------------------------------------------
	0 <= i <= 2^16 - 1
-----------------------------------------------------------------}
begin
{***	if (i<0) or (i>65535) then begin
***	    writeln('error: write2bytes: ',i:0);
***	end else begin}
    write1byte( xfile, i div 256 );
    write1byte( xfile, i mod 256 );
{***	end;}
end;

procedure write3bytes
{----------------------------------------------------------------}
(   var	xfile: fontfile;
	i: integer );
{-----------------------------------------------------------------
	0 <= i <= 2^24 - 1
-----------------------------------------------------------------}
{var	b1,b2,b3: byte;}
begin
{***}	if (i<0) or (i>16777216) then begin
{***}	    writeln('error: write2bytes: ',i:0);
{***}	end else begin
    write1byte( xfile, i div 65536 );
    i := i mod 65536;
    write1byte( xfile, i div 256 );
    write1byte( xfile, i mod 256 );
{***}	end;
end;

procedure write4bytes
{----------------------------------------------------------------}
(   var	xfile: fontfile;
	i: integer );
{-----------------------------------------------------------------
	outputs four bytes in two's complement notation,
	without risking arithmetic overflow.
-----------------------------------------------------------------}
{var	b1,b2,b3,b4: byte;}
begin
    if i >= 0 then begin
	write1byte( xfile, i div 16777216 );
    end else begin
	i := i + 1073741824; i := i + 1073741824;
	write1byte( xfile, (i div 16777216) + 128 );
    end;
    i := i mod 16777216; write1byte( xfile, i div 65536 );
    i := i mod 65536; write1byte( xfile, i div 256 );
    write1byte( xfile, i mod 256 );
end;

\f

procedure initbittable
{----------------------------------------------------------------}
(   var	xtable: bytestobits );
{-----------------------------------------------------------------
-----------------------------------------------------------------}
var	i: integer;
begin
    xtable[0] := 8;
    xtable[1] := 7;
    for i := 2 to 3 do xtable[i] := 6;
    for i := 4 to 7 do xtable[i] := 5;
    for i := 8 to 15 do xtable[i] := 4;
    for i := 16 to 31 do xtable[i] := 3;
    for i := 32 to 63 do xtable[i] := 2;
    for i := 64 to 127 do xtable[i] := 1;
    for i := 128 to 255 do xtable[i] := 0;
end;
\f

procedure init
{----------------------------------------------------------------}
(   var gfcomment: string;
    var postminm,postmaxm,postminn,postmaxn: integer );
{-----------------------------------------------------------------

-----------------------------------------------------------------}
begin
    gfbytes := 0;
    specials := 0;
    gfcomment := commentstring;
    postminm := bigint; 
    postminn := bigint;
    postmaxm := -bigint; 
    postmaxn := -bigint;
    initbittable( firstblack );
    blackleftof[0] := 0;
    blackleftof[1] := 128;
    blackleftof[2] := 128+64;
    blackleftof[3] := 128+64+32;
    blackleftof[4] := 128+64+32+16;
    blackleftof[5] := 128+64+32+16+8;
    blackleftof[6] := 128+64+32+16+8+4;
    blackleftof[7] := 128+64+32+16+8+4+2;
    blackleftof[8] := 128+64+32+16+8+4+2+1;
end;
\f

function  word
{----------------------------------------------------------------}
(	xword: longword;
	ptr: integer ): integer;
{-----------------------------------------------------------------
	at input, ptr is the low-order byte but it is
	immediately moved to the high-order byte.
-----------------------------------------------------------------}
var	tmp,i: integer;
begin
    tmp := 0;
    if ptr = 4 then ptr := 1 else ptr := ptr + 1;
    for i := 1 to 4 do begin
	tmp := tmp*256 + xword[ ptr ];
	if ptr = 4 then ptr := 1 else ptr := ptr + 1;
    end;
    word := tmp;
end;
\f

procedure locpxldirectory
{----------------------------------------------------------------}
(   var	pxlfile: fontfile;
    var	fileok: boolean );
{-----------------------------------------------------------------
	file verification includes these tests:
	    the file exists,
	    first and last long word = pxlid,
	    file contains at least pxlendbytes+4 bytes.
	location of directory consists of:
	    open file,
	    determine n, the number of bytes in the file,
	    reopen and move to the (n-1 - pxlendbytes)th byte.
-----------------------------------------------------------------}
var	count, ptr: integer;
	lastword: longword;
begin
    resetfontfile( pxlfile, fileok );
    lastword[1]:=0;
    lastword[2]:=0;
    lastword[3]:=0;
    lastword[4]:=0;
    if fileok then begin
	count := 0; ptr := 0;
	while not eof(pxlfile) do begin
	    count := count + 1; 
	    ptr := ptr + 1; 
	    if ptr > 4 then begin ptr := 1; end;
            
            {Print status message about number of bytes read.}
            if count mod 1000 = 0
            then begin write(count:1,'...'); flush(output); end;
            if count mod 10000 = 0 then writeln;
            
            lastword[ptr] := read1byte(pxlfile);
	end;
        writeln;
        writeln(count:1,' bytes read in all.');
        
	if count < (pxlendbytes + 4) then begin
	    fileok := false;
	    writeln('error: pxlfile is too short to be a pxl file.');
	end else if word( lastword, ptr ) <> pxlid then begin
	    fileok := false;
	    writeln('error: pxlfile does not end with pxlid (',word(lastword,
            ptr):1,' instead).');
	end else begin
	    resetfontfile( pxlfile, fileok );
	    if read4bytes( pxlfile ) <> pxlid then begin
		fileok := false;
		writeln('error: pxlfile does not begin with pxlid.');
	    end else begin
		for ptr := 1 to (count - 4 - pxlendbytes) do get(pxlfile);
	    end;
	end;
    end;
end;
\f

procedure getpxlendinfo
{----------------------------------------------------------------}
(   var pxlfile: fontfile;
    var font: fontarray;
    var	sum, mag, dsize: integer );
{-----------------------------------------------------------------
	assumes pxlfile is valid and pxlfile^ is the first
	byte of the font directory.
-----------------------------------------------------------------}
var	i: integer;
begin
    for i := 0 to asciimax do with font[i] do begin
	code := i;
	pixelwidth := read2bytes( pxlfile );
	pixelheight := read2bytes( pxlfile );
	xoffset := readsigned2bytes( pxlfile );
	yoffset := readsigned2bytes( pxlfile );
	pxlrasterptr := read4bytes( pxlfile );
	tfmwidth := read4bytes( pxlfile );  {stays in fix notation}
    end;
    sum := read4bytes( pxlfile );
    mag := read4bytes( pxlfile );
    dsize := read4bytes( pxlfile );
end;
\f

procedure swap
{----------------------------------------------------------------}
(   var c1,c2: charrec );
{-----------------------------------------------------------------
	c1 ▶17◀ c2
-----------------------------------------------------------------}
var 	tmp: charrec;
begin
    tmp := c1;
    c1 := c2;
    c2 := tmp;
end;
\f

procedure sortfont
{----------------------------------------------------------------}
( var	font: fontarray );
{-----------------------------------------------------------------
	sorts charrec's in font by .pxlrasterptr, thereby
	putting them into the order they were created (lowest
	rasterptr first).
-----------------------------------------------------------------}
var	i,j: integer;
begin
    for i := asciimax downto 1 do begin
	for j := 1 to i do begin
	    if font[ j-1 ].pxlrasterptr > font[ j ].pxlrasterptr then begin
		swap( font[j-1], font[j] );
	    end;
	end;
    end;
end;
\f

procedure locpxlrasters
{----------------------------------------------------------------}
(   var	pxlfile: fontfile );
{-----------------------------------------------------------------
	reopens the file and ditches the first long word.
-----------------------------------------------------------------}
var	b: boolean; {dummy}
begin
    resetfontfile( pxlfile, b );
    get(pxlfile);
    get(pxlfile);
    get(pxlfile);
    get(pxlfile);
end;
\f

procedure putgfpreamble
{----------------------------------------------------------------}
(   var	gffile: fontfile;
	gfcomment: string );
{-----------------------------------------------------------------
	written to file =>   pre,i[1],k[1],x[stringmax]
-----------------------------------------------------------------}
var	i: integer;
begin
    rewritefontfile( gffile );
    write1byte( gffile, pre );
    write1byte( gffile, gfid );
    write1byte( gffile, stringmax );
    for i := 1 to stringmax do write1byte( gffile, ord(gfcomment[i]) mod 256 );
end;
\f

function  charexists
{----------------------------------------------------------------}
(	ch: charrec ): boolean;
{-----------------------------------------------------------------
	definition of pxl files states that all 4 long words
	in the font directory will equal 0 if the character
	does not exist. for the moment, if the raster pointer
	equals zero, this function returns false and issues a
	warning if other values are non-zero.
-----------------------------------------------------------------}
begin
    with ch do if pxlrasterptr <> 0 then begin
	charexists := true;
    end else begin
	charexists := false;
	if (pixelwidth <> 0) or 
	(pixelheight <> 0) or
	(xoffset <> 0) or 
	(yoffset <> 0) or
	(tfmwidth <> 0) then begin
	    writeln('warning: non-zero values for non-existent character');
	end;
    end;
end;
\f

procedure putgfboc
{----------------------------------------------------------------}
(   var	gffile: fontfile;
    var ch: charrec;
    var postminm, postmaxm, 
	postminn, postmaxn: integer );
{-----------------------------------------------------------------
	one of the following options is written to file:
	    boc c[4] p[4] minm[4] maxm[4] minn[4] maxn[4]
	    boc1 c[1] delm[1] maxm[1] deln[1] maxn[4]
	also, assigns appropriate value to ch.gfbocptr
	and updates post<extremes>.
-----------------------------------------------------------------}
var	minm, maxm, minn, maxn, delm, deln: integer;
begin
    with ch do begin
	minm := 0 - xoffset;
	  if minm < postminm then postminm := minm;
	maxm := pixelwidth - xoffset;
	  if maxm > postmaxm then postmaxm := maxm;
	minn := yoffset + 1 - pixelheight;
	  if minn < postminn then postminn := minn;
	maxn := yoffset;
	  if maxn > postmaxn then postmaxn := maxn;
	delm := maxm - minm;
	deln := maxn - minn;
	gfbocptr := gfbytes-specials;
	specials := 0;
	if (0<=delm) and (delm<256) and (0<=maxm) and (maxm<256) and
	   (0<=deln) and (deln<256) and (0<=maxn) and (maxn<256)
	 then begin
	      write1byte( gffile, boc1 );
	      write1byte( gffile, code );
	      write1byte( gffile, delm );
	      write1byte( gffile, maxm );
	      write1byte( gffile, deln );
	      write1byte( gffile, maxn );
	      end
	 else begin
	      write1byte( gffile, boc );
	      write4bytes( gffile, code );
	      write4bytes( gffile, -1 ); {never any backpointers from pxl files}
	      write4bytes( gffile, minm );
	      write4bytes( gffile, maxm );
	      write4bytes( gffile, minn );
	      write4bytes( gffile, maxn );
	      end;
    end;
end;
\f

function  getpaint(var length:integer): boolean;
{----------------------------------------------------------------
	the pxlbuf array contains bytes 0, 1, .., pxlbuflimit, and each
	byte contains bits 0, 1, .., 7 numbered from the left (most
	significant position).  we are about to paint bit pxlbit of
	byte pxlbyte with color pxlcolor.  all lower numbered bits
	in the current byte also have this color.  find out how many
	bit positions we can advance before we come to a pixel of a
	different color, and set length accordingly.  the global variables
	pxlbyte and pxlbit are updated accordingly, and the leading
	bits of pxlbyte are changed to match the new pxlcolor.  the
	boolean value returned indicates whether or not we were
	successful in finding a different colored pixel.
-----------------------------------------------------------------}
label 999;				{exit label}
var	curbyte: integer;		{a byte from pxlbuf}
	newbyte, newbit: integer;	{new values for pxlbyte and pxlbit}
begin
    newbyte := pxlbyte;
    if pxlcolor=white
     then begin
	  while (newbyte<pxlbuflimit) and (pxlbuf[newbyte]=allwhite)
	   do newbyte := newbyte + 1;
	  curbyte := pxlbuf[newbyte];
	  if curbyte=allwhite
	   then begin getpaint:=false; goto 999; end;
	  end
     else begin
	  while (newbyte<pxlbuflimit) and (pxlbuf[newbyte]=allblack)
	   do newbyte := newbyte + 1;
	  curbyte := allblack - pxlbuf[newbyte];
	  end;
    newbit := firstblack[curbyte];
    length := 8*(newbyte-pxlbyte) + (newbit-pxlbit);
    pxlbyte := newbyte;
    pxlbit := newbit;
    pxlcolor := not pxlcolor;
    curbyte := curbyte + blackleftof[pxlbit];
    if pxlcolor = black  then pxlbuf[pxlbyte] := curbyte
			 else pxlbuf[pxlbyte] := allblack - curbyte;
    getpaint := true;
999:end;
\f

procedure paint(d: integer);
begin
    if d = 0 then begin
	write1byte( gffile, paint0 );
    end else if (d <= maxpaint) then begin
	write1byte( gffile, paint1 + d - 1 );
    end else if (d <= 255) then begin
	write1byte( gffile, paintone );
	write1byte( gffile, d );
    end else if (d <= 65535) then begin
	write1byte( gffile, painttwo );
	write2bytes( gffile, d );
    end else if (d <= 16777215) then begin
	write1byte( gffile, paintthr );
	write3bytes( gffile, d );
    end else begin
	write('error: huge run-length, gffile is invalid.');
    end;
end;
\f

procedure down(d: integer);
begin
    d := d-1;
    if d >= 0 then
	if d = 0 then begin
	    write1byte( gffile, skip0 );
	end else if (d <= 255) then begin
	    write1byte( gffile, skipone );
	    write1byte( gffile, d );
	end else if (d <= 65535) then begin
	    write1byte( gffile, skiptwo );
	    write2bytes( gffile, d );
	end else if (d <= 16777215) then begin
	    write1byte( gffile, skipthr );
	    write3bytes( gffile, d );
	end else begin
	    write('error: huge skip, gffile is invalid.');
	end;
end;
\f

procedure putgfpaint
{----------------------------------------------------------------}
(   var gffile: fontfile;
	ch: charrec );
{-----------------------------------------------------------------
	paints the raster beginning with pxlfile^ and 
	described by ch. uses coordinates 1..ch.pixelwidth and
	ch.pixelheight..1 .
-----------------------------------------------------------------}
var	y, pxly, paintlength: integer;
begin
    pxlbuflimit := ceiling( ch.pixelwidth, 8 ) - 1;
    pxlbufend := pxlbuflimit - (pxlbuflimit mod 4) + 3;
    if pxlbufend > pxlbufsize
     then writeln('error: pxlbufsize too small');
    y := ch.pixelheight;
    for pxly := ch.pixelheight downto 1 do begin
	readpxlbuf;
	if getpaint(paintlength) then
	    begin
	    if y=pxly then paint(paintlength)
	     else if paintlength > maxnewrow
		   then begin
			down(y-pxly);
			paint(paintlength);
			end
		   else begin
			down(y-pxly-1);
			write1byte(gffile, newrow0+paintlength);
			end;
	y := pxly;
	while getpaint(paintlength) do paint(paintlength);
	end;
    end;
    write1byte( gffile, eoc );
end;
\f

procedure putgfpost
{----------------------------------------------------------------}
(   var	gffile: fontfile;
    var	sum, mag, dsize,
	postminm, postmaxm, 
	postminn, postmaxn: integer );
{-----------------------------------------------------------------
	just the post command w/ paramaters.
-----------------------------------------------------------------}
var	ppp: integer; {pixels per point, scaled by two16}
begin
    write1byte( gffile, post );		{post:		}
    write4bytes( gffile, gfbytes - 1);	{	p[4]	}
    write4bytes( gffile, dsize );	{	ds[4]	}
    write4bytes( gffile, sum );	{	cs[4]	}
    ppp := round( ((mag/5)/ppi)*two16 );
    write4bytes( gffile, ppp );	{	hppp[4] }
    write4bytes( gffile, ppp );	{	vppp[4] }
    if postminm>postmaxm then begin
	postminm:=0;
	postmaxm:=0;
	end;
    if postminn>postmaxn then begin
	postminn:=0;
	postmaxn:=0;
	end;
    write4bytes( gffile, postminm );
    write4bytes( gffile, postmaxm );
    write4bytes( gffile, postminn );
    write4bytes( gffile, postmaxn );
end;
\f

procedure putgflocator
{----------------------------------------------------------------}
(   var	gffile: fontfile;
	ch: charrec;
	dsize, mag: integer );
{-----------------------------------------------------------------
-----------------------------------------------------------------}
var dm: integer;
begin
    with ch do begin
	dm := round( (tfmwidth/fix) * (dsize/fix) * (mag/5) / ppi );
	if (0 <= dm) and (dm < 256)
	 then begin
	      write1byte( gffile, charloc0 );
	      write1byte( gffile, code );
	      write1byte( gffile, dm );
	      write4bytes( gffile, tfmwidth );
	      write4bytes( gffile, gfbocptr );
	      end
	 else begin
	      write1byte( gffile, charloc );
	      write1byte( gffile, code );
	      write4bytes( gffile, two16*dm );
	      write4bytes( gffile, 0 );
	      write4bytes( gffile, tfmwidth );
	      write4bytes( gffile, gfbocptr );
	      end;
    end;
end;
\f

procedure putgfppost
{----------------------------------------------------------------}
(   var gffile: fontfile;
	postptr: integer );
{-----------------------------------------------------------------
-----------------------------------------------------------------}
var	i,j: integer;
begin
    write1byte( gffile, postpost );
    write4bytes( gffile, postptr );
    write1byte( gffile, gfid );
    write1byte( gffile, sig );
    write1byte( gffile, sig );
    write1byte( gffile, sig );
    write1byte( gffile, sig );
    i := gfbytes mod 4;
    if i <> 0 then begin
	for j := 1 to (4 - i) do write1byte( gffile, sig );
    end;
end;
\f

{ main } begin
   {Filenames on Unix come from the command line.}
   if argc <> 3
   then begin
      message('Usage: pxtogf <pxl file> <gf file>.');
      halt;
   end;
   
   argv(1, pxlfilename);
   argv(2, gffilename);
   
    writeln(headerstring);
    init( gfcomment,postminm,postmaxm,postminn,postmaxn );
    locpxldirectory( pxlfile, fileok );
    if not fileok then begin
	writeln('abort: bad pxl file.');
    end else begin
	getpxlendinfo( pxlfile, font, sum, mag, dsize );
	sortfont( font );
	locpxlrasters( pxlfile );

	putgfpreamble( gffile, gfcomment );
	specials := 0; charcount := 0;
	for i := 0 to asciimax do if charexists(font[i]) then begin
	    write('[',font[i].code:0);
	    putgfboc( gffile, font[i], postminm, postmaxm, postminn, postmaxn );
	    putgfpaint( gffile, font[i] );
            charcount := charcount + 1;
            write(']');
            if charcount mod 12 = 0
            then writeln
            else write(' ');
            flush(output);
 	end;
	postptr := gfbytes;
	putgfpost( gffile, sum, mag, dsize,
			  postminm, postmaxm, postminn, postmaxn );
	for i := 0 to asciimax do if charexists(font[i]) then begin
	    putgflocator( gffile, font[i], dsize, mag );
	end;
	putgfppost( gffile, postptr );
    end;
    if charcount mod 12 <> 0 then writeln;
    writeln(charcount:1,' characters output.');
end.
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦5206e43c9⟧ TextFile

Derivation

TextFile
