{ Copyright (C) 1986 Adam Fritz, 133 Main St., Afton, N.Y. 13730 }

procedure RasterChar ( lm, rm : integer ) ;

const
     nBufferx       = 2048 ;
var
     nLines         : byte ;
     nStrokes       : byte ;
     nsBuffer       : integer ;
     nSegs          : byte ;
     Off, On        : byte ;
     OffOn          : byte ;
     iBuffer        : integer ;
     nBuffer        : integer ;
     fBuffer        : array[0..2047] of byte ;
     i, n           : integer ;
     x, xn, xx      : integer ;
     y, yn, yx      : integer ;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

procedure PutBuffer ( n : integer ) ;
     { build buffer byte by byte }
begin
   fBuffer[iBuffer] := n ;
   iBuffer := iBuffer + 1 ;
   if iBuffer = nBufferx then begin
      writeln ('Error: Font Buffer Overflow.') ;
      BIOS(0)
   end
end ;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

procedure PutFont ( n : integer ) ;
     { write font data byte by byte, record by record }
begin
   fData[dOffset] := n ;
   fOffset := fOffset + 1 ;
   dOffset := dOffset + 1 ;
   if dOffset = 128 then begin
      BlockWrite (fdID, fData, 1) ;
      if IOResult <> 0 then begin
         writeln ('Error: Unable to Write Font Data File.') ;
         BIOS(0)
      end
      else
         dOffset := 0
   end
end ;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

begin
                                { reset font buffer }
   iBuffer := 0 ;
                                { extend font data file }
   nLines := 0 ;
   PutBuffer (1) ;
   xn := xScale * lm ;
   xx := xScale * rm + 1 ;
                                { for each line that will be printed }
   for x := xn to xx do begin
      nLines := nLines + 1 ;
      nSegs := 0 ;
      nsBuffer := iBuffer ;
      PutBuffer (0) ;
      y := yStripen ;
                                { for each character position }
      while y < yStripex do begin
         nSegs := nSegs + 2 ;
                                { run length encode Off characters }
         Off := 0 ;
         while not TestPad(x,y) and (y < yStripex) do begin
            y := y + 1 ;
            Off := Off + 1
         end ;
         PutBuffer (Off) ;
                                { run length encode On characters }
         On := 0 ;
         while TestPad(x,y) and (y < yStripex) do begin
            y := y + 1 ;
            On := On + 1
         end ;
         PutBuffer (On)
      end ;
                                { gobble empty trailers }
      while (fBuffer[iBuffer-1] = 0) and (nSegs > 0) do begin
         iBuffer := iBuffer - 2 ;
         nSegs := nSegs - 2
      end ;
                                { install segment count }
      fBuffer[nsBuffer] := nSegs
   end ;
                                { NB: margin rectification    }
                                { depends on side effects to  }
                                { properly handle blank chars }

                                { rectify right margin }
   n := 0 ;
   while fBuffer[iBuffer-n-1] = 0 do
      n := n + 1 ;
   iBuffer := iBuffer - n ;
   nLines := nLines - n ;
   nBuffer := iBuffer ;
                                { rectify left margin }
   iBuffer := 1 ;
   n := 0 ;
   while (iBuffer < nBuffer) and (fBuffer[iBuffer+n] = 0) do
      n := n + 1 ;
   iBuffer := iBuffer + n ;
   nLines := nLines - n ;
                                { blank ? }
   if nLines = 0 then begin
      iBuffer := 1 ;
      nBuffer := xx - xn + 1 ;
      nLines := nBuffer - 1
   end
                                { any leading margin? }
   else if iBuffer > 1 then begin
      iBuffer := iBuffer - 1 ;
      nLines := nLines + 1
   end ;
                                { write raster count }
   PutFont (nLines) ;
                                { dump buffer }
   while iBuffer < nBuffer do begin
      PutFont (fBuffer[iBuffer]) ;
      iBuffer := iBuffer + 1
   end
end ;

{ Copyright (C) 1986 Adam Fritz, 133 Main St., Afton, N.Y. 13730 }