[comp.fonts] Fontasy 1.06 font definition

nelson@sun.soe.clarkson.edu (Russ Nelson) (04/09/90)

In article <1721@sparko.gwu.edu> sc155113@seas.gwu.edu (Timur Tabi) writes:

   Can anyone tell me what the bitmap definition is for Fontasy's font files?
   Better yet, does anyone have a conversion program?  I have over unique
   fonts which I want to convert to HP's .SFP format.

Here is a program that I wrote to convert Fontasy fonts to Painter's
Apprentice fonts.  The program isn't well-commented, but you ought to
be able to figure it out given a few Fontasy fonts:

{ History:173 }
const
  charset : set of char = [' '..'~'];
  max_font_size = 400;
type
  str255 = string[255];
  byte_array = array[0..max_font_size] of byte;
var
  font_name : str255;
  font_header : record
    ascent    : integer;
    descent   : integer;
    maxWid    : integer;
    leading   : integer;
    num_char  : integer
    end;
  font_index : array[' '..'~'] of record
    exist      : boolean;
    width      : byte;
    definition : byte_array;
    end;
  missing : byte_array;
  misswid : byte;


procedure write_font(fn : str255);
var
  out_file : file;
  ch : char;
  height : integer;
begin
  with font_header do begin
    num_char := 0;
    for ch := ' ' to '~' do if font_index[ch].exist then num_char := num_char + 1;
    end;

  with font_header do begin
    height := ascent + descent;
    end;

  { get file set up }
  if pos('.', fn)=0 then fn := fn + '.FNT';
  assign(out_file, fn);
  rewrite(out_file, 1);

  { write font name }
  blockwrite(out_file, font_name[1], length(font_name));
  ch := #0;
  blockwrite(out_file, ch, 1);

  font_header.leading := height div 8 + 1;
  blockwrite(out_file, font_header, sizeof(font_header));

  misswid := font_header.maxWid - 2;

  fillchar(missing[0], ((misswid + 7) div 8) * height, $ff);
  blockwrite(out_file, misswid, 1);
  blockwrite(out_file, missing[0], height * ((misswid + 7) div 8));

  for ch := ' ' to '~' do with font_index[ch] do begin
    if exist then begin
      blockwrite(out_file, ch, 1);
      blockwrite(out_file, width, 1);
      blockwrite(out_file, definition[0], height * ((width + 7) div 8));
      end;
    end;
  close(out_file);
  end;

procedure adjust_ascent;
const
  sizes : array[1..9] of integer = (9, 10, 12, 14, 18, 24, 36, 48, 72);
var
  i : integer;
begin
  i := 1;
  while font_header.ascent >= sizes[i] do i := i + 1;
  if i > 1 then i := i - 1;
  font_header.descent := font_header.ascent - sizes[i];
  font_header.ascent := sizes[i];
  end;


const
  code_str : str255 = '(C)1984WKMASON';
var
  inf : file;
  code_i : integer;

function getch : byte;
var
  by : byte;
begin
  blockread(inf, by, 1);
  by := by xor (ord(code_str[code_i]) or $80);
  if code_i=length(code_str) then code_i := 1 else code_i := code_i + 1;
  getch := by;
  end;

var
  repeating : boolean;
  repeat_count : integer;
  repeat_byte : byte;
function getbyte : byte;
var
  by : byte;
begin
  if repeating then begin
    repeat_count := repeat_count - 1;
    if repeat_count=0 then repeating := false;
    getbyte := repeat_byte;
    end
  else begin
    by := getch;
    if by<>$55 then getbyte := by
    else begin
      repeating := true;
      repeat_count := getch;
      repeat_byte := getch;
      getbyte := getbyte;
      end;
    end;
  end;


{$U+}
function real_width(ch : char) : integer;
var
  i, wid, ptr : integer;
  bit : byte;
  bytes : integer;
  columns : array[0..20] of byte;
begin
  with font_index[ch] do begin
    bytes := (width + 7) shr 3;
    fillchar(columns, sizeof(columns), 0);
    for ptr := 0 to bytes - 1 do begin
      for i := 0 to font_header.ascent + font_header.descent - 1 do begin
        columns[ptr] := columns[ptr] or definition[i*bytes + ptr];
        end;
      end;
    wid := width;
    bit := 1;
    ptr := bytes - 1;
    while (wid>0) and ((columns[ptr] and bit) = 0) do begin
      if bit=$80 then begin
        bit := 1;
        ptr := ptr - 1;
        end
      else bit := bit shl 1;
      wid := wid - 1;
      end;
    end;
  real_width := wid - 1;
  end;
{$U-}


type
  rect = record
    left : integer;
    top : integer;
    right : integer;
    bot : integer;
    end;
  verbs = (pset_verb, and_not_verb, or_verb, xor_verb);
  bitmap = record
    bounds : rect;
    bytes : integer;
    pointer : ^byte;
    end;

procedure blit(src, dest : bitmap; mode : verbs); external 'blit.com';


procedure copy_char(ch : char; old_width, new_width : integer);
var
  src, dest : bitmap;
  new_char : byte_array;
begin
  with font_index[ch] do begin
    src.bounds.top := 0;
    src.bounds.left := 0;
    src.bounds.bot := font_header.ascent + font_header.descent;
    src.bounds.right := new_width;
    src.bytes := (old_width + 7) shr 3;
    src.pointer := addr(definition);

    dest.bounds.top := 0;
    dest.bounds.left := 0;
    dest.bytes := (new_width + 7) shr 3;
    dest.pointer := addr(new_char);

    blit(src, dest, pset_verb);
    definition := new_char;
    end;
  end;


var
  ch : char;
  bit, by : byte;
  ptr : integer;
  bytes : integer;
  fnt_idx : integer;
  fnt_char : char;
  header : record
    fy_bytes : integer;
    fy_width : byte;
    fy_height : byte;
    fy_count : byte;
    fy_unk1 : byte;
    fy_unk2 : byte;
    fy_unk3 : byte;
    end;
  header_array : array[1..10] of byte absolute header;
  i, j, k : integer;
  new_width : byte;
  in_file_name : str255;
begin
  if paramcount<1 then begin
    writeln('usage: fy2fnt fyname[.FY] [fntname[.FNT]]');
    halt(2);
    end;
  if paramcount < 2 then font_name := paramstr(1)
  else font_name := paramstr(2);
  i := pos('.', font_name);
  if i<>0 then font_name := copy(font_name, 1, i-1);
  i := pos(':', font_name);
  if i<>0 then font_name := copy(font_name, 3, 255);

  in_file_name := paramstr(1);
  if pos('.', in_file_name)=0 then in_file_name := in_file_name + '.FY';

  assign(inf, in_file_name);
  reset(inf, 1);
  code_i := 1;
  repeating := false;
  for i := 1 to sizeof(header) do header_array[i] := getch;

  writeln('bytes = ',header.fy_bytes);
  writeln('width = ',header.fy_width);
  writeln('height= ',header.fy_height);
  writeln('count = ',header.fy_count);
  writeln('unk1  = ',header.fy_unk1);
  writeln('unk2  = ',header.fy_unk2);
  writeln('unk3  = ',header.fy_unk3);


  for ch := ' ' to '~' do font_index[ch].exist := false;
  font_header.maxWid := 0;
  font_header.ascent := 0;
  font_header.descent := 0;

  fillchar(font_index[' '].definition, max_font_size, 0);
  font_index[' '].exist := true;
  font_index[' '].width := 8;

  bytes := (header.fy_width+7) shr 3;
  for fnt_char := '!' to chr(ord(' ') + header.fy_count) do
      if not (fnt_char in charset) then begin
    for i := 1 to header.fy_bytes do by := getbyte;
    end
      else with font_index[fnt_char] do begin
    exist := true;
    fillchar(definition, max_font_size, 0);
    for i := 0 to header.fy_height-1 do begin
      bit := $80;
      ptr := 0;
      for j := 0 to header.fy_width-1 do begin
        by := getbyte;
        for k := 7 downto 0 do begin
          fnt_idx := (i*8+k)*bytes + ptr;
          if (by and 1)<>0 then definition[fnt_idx] := definition[fnt_idx] or bit;
          by := by shr 1;
          end;
        if bit=1 then begin
          ptr := ptr + 1;
          bit := $80
          end
        else bit := bit shr 1;
        end;
      end;
    end;

  font_header.maxWid := header.fy_width;
  font_header.ascent := header.fy_bytes div (header.fy_width shr 3);
  font_header.descent := 0;

  for fnt_char := '!' to chr(ord(' ') + header.fy_count) do
      if fnt_char in charset then with font_index[fnt_char] do if exist then begin
    width := getch;
{
    new_width := real_width(fnt_char);
    writeln(fnt_char,' ',width,' ',new_width);
}
    if width=0 then exist := false
    else copy_char(fnt_char, header.fy_width, width);
    end;
  adjust_ascent;

  writeln('ascent of font = ',font_header.ascent);
  writeln('descent of font = ',font_header.descent);

  if font_header.descent<0 then font_header.descent := 0;

  close(inf);
  if paramcount < 2 then write_font(paramstr(1))
  else write_font(paramstr(2));

  end.

--
--russ (nelson@clutx [.bitnet | .clarkson.edu])  Russ.Nelson@$315.268.6667
Violence never solves problems, it just changes them into more subtle problems
Clarkson will be featured on PBS's Computer Chronicles this week.