ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/TPHERS01.ZIP/TPHERSH.PAS

Pascal/Delphi Source File | 1991-09-08 | 18.8 KB | 496 lines

{*****************************************************************************}
{*  A unit to manipulate the Hershey glyph (symbol) set.                     *}
{*                                                                           *}
{*  This code is donated to the Public domain.                               *}
{*                                                                           *}
{*  Dov Grobgeld                                                             *}
{*  Department of Chemical Physics                                           *}
{*  The Weizmann Institute of Science                                        *}
{*  Israel                                                                   *}
{*  Email: [e-mail]                                         *}
{*                                                                           *}
{*  7/9/1991                                                                 *}
{*                                                                           *}
{*  Version 0.1beta                                                          *}
{*                                                                           *}
{*  There are only two dependances on BGI in this code, and both have the    *}
{*  keywords 'BGI dependance' in comments beside them.                       *}
{*****************************************************************************}

unit TPHersh;

interface

uses graph;   { BGI dependance }

{$ifopt n-} type double=real; {$endif}  { Use reals if no math coprocessor }

type
  HersheyFont = array[#32..#127] of integer;
  pHersheyFont = ^HersheyFont;

const
  HersheyRomans : HersheyFont = (
   699, 714, 717, 733, 719,2271, 734, 731, 721, 722,2219, 725, 711, 724, 710, 720,
   700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 712, 713,2241, 726,2242, 715,
  2273, 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,2223, 804,2224,2262, 999,
   730, 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,2225, 723,2226,2246, 718);

var
  HersheyX, HersheyY                 : integer;
  HersheyMaxX, HersheyAspectRatio    : double;

procedure HersheySetGlyphsFileName(s : string);
procedure HersheyLoadGlyphs;
procedure HersheyDisplayGlyph(GlyphNum : integer);
procedure HersheyOutTextXY(x,y : integer; s : string);
procedure HersheyOutText(s : string);
procedure HersheySetGlyphSize(xs, ys: double);
procedure HersheyDisposeFont;
procedure HersheySetFont(var pFont);
procedure HersheyMove(x,y : integer);
function HersheyGlyphWidth(GlyphNum : integer) : double;
function HersheyStringWidth(s : string) : double;
procedure HersheySetAngle(theta : double);
procedure HersheySetStringJustify(Horizontal, Vertical : integer);

implementation

const
  MaxHersheyChars = 3999;
  MaxStrokes = 1000;

type
  {*****************************************************************************}
  {* The strokes in a character are stored in the file as integers represented *}
  {* as characters centered around 'R'.                                        *}
  {*                                                                           *}
  {* All characters are drawn around the center of the character. The width    *}
  {* of the charecter is decided by +-Stroke[0] and the height is determined   *}
  {* by +-Stroke[1].                                                           *}
  {*****************************************************************************}
  StrokeVector = array[1..MaxStrokes-1] of char;
  pStrokeVector = ^StrokeVector;
  HersheyChar  = record
    numStrokes : byte;
    pStroke    : pStrokeVector;
  end;
  HersheyFontType = array[1..MaxHersheyChars] of ^HersheyChar;

const
  HersheyGlyphsFileName : string = 'hersh.hfn';

var
  HersheyFontArray    : ^HersheyFontType;
  HersheyCurrentFont  : ^HersheyFont;
  SinTheta, CosTheta : double;       { Rotation of character }
  xiScale, nuScale      : double;
  HStringJust, VStringJust : double;


{*****************************************************************************}
{*  Allows the user to chose another font file.                              *}
{*****************************************************************************}
procedure HersheySetGlyphsFileName(s : string);
begin
  HersheyGlyphsFileName:= s;
end;

{*****************************************************************************}
{*  FAST block read routines to read the font...                             *}
{*****************************************************************************}
CONST
  BufLen = 8192;

TYPE
  RecType = char;
  ArrayRecType=Array[1..BufLen] of RecType;

VAR
  FontFile                    : FILE;
  InBuf                       : ^arrayRecType;
  InPtr                       : WORD;
  RecRead                     : WORD;

procedure OpenBlockFiles(p : pointer);
begin
  { Open the font file for unformated input }
  Assign(FontFile, HersheyGlyphsFileName);   Reset(FontFile, SizeOf(RecType));
  RecRead:= 0;
  InPtr:= RecRead + 1;
  InBuf:= p;
end;

procedure CloseBlockFiles;
begin
  close(FontFile);
end;

FUNCTION GetNextRec(VAR _rec; NumRecs : integer): BOOLEAN;
var
  rec: ArrayRecType absolute _rec;
  RecOfs : integer;
BEGIN
  if NumRecs + InPtr <= Recread then begin
    move(InBuf^[InPtr], rec[1], NumRecs * sizeof(RecType));
    InPtr:= InPtr + NumRecs;
    GetNextRec:= TRUE;
  end
  else begin
    if RecRead >= InPtr then begin
      move(InBuf^[InPtr], rec[1], (RecRead-InPtr+1) * sizeof(RecType));
      RecOfs:= RecRead - InPtr + 1;
    end
    else RecOfs:= 0;
    BlockRead(FontFile, InBuf^, BufLen, RecRead);
    IF RecRead = 0 THEN BEGIN
      GetNextRec:= FALSE;
      Exit;
    END;
    InPtr:= 1;
    move(InBuf^[InPtr], rec[RecOfs+1], (NumRecs - RecOfs) * sizeof(RecType));
    InPtr:= InPtr + NumRecs - RecOfs;
  end;
END;

{*****************************************************************************}
{*  Load the font into memory.                                               *}
{*****************************************************************************}
procedure HersheyLoadGlyphs;
var
  numString : string[5];
  i       : integer;
  GlyphNum, numStrokes : integer;
  errPos  : integer;
  Buf     : array[1..BufLen] of byte;
  crlf    : array[1..2] of char;
  eofFlag : boolean;
label
  exitLoad;

  function imin(a,b : integer): integer;
  begin
    if a<b then imin:= a
    else imin:= b;
  end;

begin
  if HersheyFontArray=nil then begin
    new(HersheyFontArray);

    { Zero all characters }
    for i:= 1 to MaxHersheyChars do HersheyFontArray^[i]:= nil;
  end;

  openBlockFiles(@Buf);  { Let's use a stack buffer instead of a heap buffer... }

  eofFlag:= false;
  while not eofFlag do begin

    { Get the Hershey Glyph number and the number of strokes in the font }
    numString[0]:= #5;
    eofFlag:= not GetNextRec(numString[1],5);
    val(numString, GlyphNum, errPos);

    numString[0]:= #3;
    eofFlag:= not GetNextRec(numString[1],3);
    val(numString, numStrokes, errPos);

    if eofFlag then goto ExitLoad;

    { Allocate the memory for the character and store it}
    if HersheyFontArray^[GlyphNum] = nil then begin
      new(HersheyFontArray^[GlyphNum]);
      HersheyFontArray^[GlyphNum]^.numStrokes:= numStrokes;
      GetMem(HersheyFontArray^[GlyphNum]^.pStroke, numStrokes * 2);

      { Copy all the characters... }
      eofFlag:= not GetNextRec(HersheyFontArray^[GlyphNum]^.pStroke^[1], 2*numStrokes);
      if not eofFlag then eofFlag:= not GetNextRec(crlf[1], 2);  { Get CR, LF }
      if ((crlf[1] <> #13) or (crlf[2] <> #10)) then begin
        writeln('Warning at character ', GlyphNum, '. Expected cr/lf not found! ');
        writeln('Searching for next cr/lf...');
        repeat
          eofFlag:= not GetNextRec(crlf[1],1);
          if not eofFlag and (crlf[1]=#13) then eofFlag:= not GetNextRec(crlf[2],1);
        until ((crlf[1] = #13) and (crlf[2] = #10)) or eofFlag;
      end;
    end;
  end;

ExitLoad:
  CloseBlockFiles;
end;

{*****************************************************************************}
{*  Throw away the font from memory.                                         *}
{*****************************************************************************}
procedure HersheyDisposeFont;
var
  i: integer;
begin
  for i:= 1 to MaxHersheyChars do begin
    if HersheyFontArray^[i] <> nil then begin
      freemem(HersheyFontArray^[i]^.pStroke,HersheyFontArray^[i]^.numStrokes * 2);
      dispose(HersheyFontArray^[i]);
      HersheyFontArray^[i]:= nil;
    end;
  end;
  Dispose(HersheyFontArray);
  HersheyFontArray:= nil;
end;

{****************************************************************************}
{*  HersheyDraw draws a line from the current Hershey line position to the  *}
{*  position x,y.                                                           *}
{*                                                                          *}
{*  The only system dependent routine. This routine calls the line routine  *}
{*  from the BGI toolkit. It can easily be exchanged to another routine on  *}
{*  any desired device.                                                     *}
{****************************************************************************}
procedure HersheyDraw(x,y : integer);
begin
  Line(HersheyX,HersheyY,x,y);      { BGI dependance }

  HersheyX:= X; HersheyY:= Y;
end;

{****************************************************************************}
{*  Sets the new Hershey current position to x,y                            *}
{****************************************************************************}
procedure HersheyMove(x,y : integer);
begin
  HersheyX:= x; HersheyY:= y;
end;

{****************************************************************************}
{*  Displays Glyph GlyphNum at the current position in the current size      *}
{*  and rotation. It updates the Hershey current position to fit for the    *}
{*  next character.                                                         *}
{****************************************************************************}
procedure HersheyDisplayGlyph(GlyphNum : integer);
var
  skip : boolean;
  i : integer;
  xint, yint : integer;
  xi, nu       : integer; { Internal vectors of character }
  dxi, dnu : integer;     { Height and width information of character }
  charX, charY : integer; { Position of the current character }
begin
  { Check if the character is valid }
  if (GlyphNum < 1) or (GlyphNum > maxHersheyChars) then exit;
  if HersheyFontArray^[GlyphNum]= nil then exit;

  charX:= HersheyX; charY:= HersheyY; { Get current character position }
  HersheyMove(charX, charY);
  skip:= true;

  with HersheyFontArray^[GlyphNum]^ do begin
    { Save the width information of the character }
    dxi:= ord(pStroke^[1]) - ord('R');
    dnu:= ord(pStroke^[2]) - ord('R');

    { Move to the center of the character }
    charX:= charX - round(dxi*xiScale*cosTheta) { + round(GlyphHeightJustType * FontHeight * yScale * sinTheta)) };
    charY:= charY + round(dxi*xiScale*sinTheta) { + round(GlyphHeightJustType * FontHeight * yScale * cosTheta)) };

    for i:= 2 to numStrokes do begin
      if pStroke^[i*2-1] = ' ' then skip:= true
      else begin
        xint:= ord(pStroke^[i*2-1]) - ord('R');
        yint:= ord(pStroke^[i*2  ]) - ord('R');
        if skip then begin
          skip:= false;
          HersheyMove(charX + round(xint * xiScale * cosTheta + yint * nuScale * sinTheta),
                      charY + round(-xint * xiScale * sinTheta + yint * nuScale * cosTheta));
        end
        else
          HersheyDraw(charX + round(xint * xiScale * cosTheta + yint * nuScale * sinTheta),
                      charY + round(-xint * xiScale * sinTheta + yint * nuScale * cosTheta));
      end;
    end;

    { Move to the right side of the character }
    charX:= charX - round(dxi*xiScale*cosTheta);
    charY:= charY + round(dxi*xiScale*sinTheta);
    HersheyMove(charX, charY);
  end;
end;

{****************************************************************************}
{*  Change the current Hershey font.                                        *}
{****************************************************************************}
procedure HersheySetFont(var pFont);
begin
  HersheyCurrentFont:= @pFont;
end;

{****************************************************************************}
{*  Set the font rotation angle.                                            *}
{****************************************************************************}
procedure HersheySetAngle(theta : double);
begin
  SinTheta:= sin(theta/180*pi);
  CosTheta:= cos(theta/180*pi);
end;

{***************************************************************************}
{*  Sets the width and the height of the characters.                       *}
{*  The size is given in Percent of the external Hershey character box     *}
{*  with respect to the maximal xposition.                                 *}
{*                                                                         *}
{*  Note that most characters don't fill their character boxes and thus    *}
{*  will be much smaller than what might be believed.                      *}
{*                                                                         *}
{*  Also note that both the hight and width (xi and nu in the character    *}
{*  coordinates) are given in terms of percent of the maximal x value.     *}
{*  The aspect ratio can be modified by the value of HersheyAspectRatio.   *}
{***************************************************************************}
procedure HersheySetGlyphSize(xs, ys: double);
begin
  xiScale:= xs/100*HersheyMaxX/100;
  nuScale:= ys/100*HersheyMaxX * HersheyAspectRatio/100;
end;

{***************************************************************************}
{*  Sets the maximum x value and the aspect ration which are used in the   *}
{*  calculation of the Glyph size.                                         *}
{***************************************************************************}
procedure HersheySetMaxX(maxX, aspectRatio: double);
begin
  HersheyMaxX:= maxX;
  HersheyAspectRatio:= aspectRatio;
end;

{***************************************************************************}
{*  Returns the width of a Glyph.                                         *}
{***************************************************************************}
function HersheyGlyphWidth(GlyphNum : integer) : double;
begin
  if HersheyFontArray^[GlyphNum]=nil then begin
    HersheyGlyphWidth:= 0;
    exit;
  end;
  HersheyGlyphWidth:= xiScale * -2 * (ord(HersheyFontArray^[GlyphNum]^.pStroke^[1]) - ord('R'));
end;

{***************************************************************************}
{*  Returns the height of a glyph.                                         *}
{***************************************************************************}
function HersheyGlyphHeight(GlyphNum : integer) : double;
begin
  if HersheyFontArray^[GlyphNum]=nil then begin
    HersheyGlyphHeight:= 0;
    exit;
  end;
  HersheyGlyphHeight:= nuScale * 2 * (ord(HersheyFontArray^[GlyphNum]^.pStroke^[2]) - ord('R'));
end;

{***************************************************************************}
{*  Returns the width of a string in the current font...                   *}
{***************************************************************************}
function HersheyStringWidth(s : string) : double;
var
  sum : double;
  i : integer;
begin
  sum:= 0;
  for i:= 1 to length(s) do sum:= sum + HersheyGlyphWidth(HersheyCurrentFont^[s[i]]);
  HersheyStringWidth:= sum;
end;

{**************************************************************************}
{*  How to justify a string.                                              *}
{*                                                                        *}
{*    -1 : left, bot justification                                        *}
{*     0 : middle, centre justification                                   *}
{*     1 : left top justification                                         *}
{**************************************************************************}
procedure HersheySetStringJustify(horizontal, vertical : integer);
begin
  HStringJust:= Horizontal;
  VStringJust:= Vertical;
end;

{****************************************************************************}
{*  Write the string s at the current Hershey pen position in the current   *}
{*  string justification.                                                   *}
{****************************************************************************}
procedure HersheyOutText(s : string);
var
  i : integer;
  stringWidth, stringHeight : integer;
  dx, dy : integer;
  x, y : integer;
  d: double;
begin
  x:= HersheyX; y:= HersheyY;
  if HStringJust<> -1 then begin
    d:= HersheyStringWidth(s);
    stringWidth:= round(HersheyStringWidth(s));
    dx:= round(stringWidth * cosTheta);
    dy:= round(stringWidth * sinTheta);
    if HStringJust=0 then begin
      x:= x - dx div 2;
      y:= y - dy div 2;
    end
    else begin
      x:= x - dx;
      y:= y - dy;
    end;
  end;
  if VStringJust <> 0 then begin
    stringHeight:= round(HersheyGlyphHeight(HersheyCurrentFont^['A']));
    dx:= round(StringHeight * sinTheta);
    dy:= round(StringHeight * cosTheta);
    if VStringJust= 1 then begin
      dx:= - dx div 2;
      dy:= dy div 2;
    end
    else begin
      dx:= dx div 2;
      dy:= - dy div 2;
    end;
    x:= x+dx;
    y:= y+dy;
  end
  else begin
    dx:= 0;
    dy:= 0;
  end;

  HersheyMove(x,y);
  for i:= 1 to length(s) do
    HersheyDisplayGlyph(HersheyCurrentFont^[s[i]]);

  { Move the pen pointer back to compensate for vertical justification }
  if dx+dy <> 0 then HersheyMove(HersheyX-dx,HersheyY-dy);
end;

{****************************************************************************}
{*  Like HersheyOutText, but writes the string at the position (x,y).       *}
{****************************************************************************}
procedure HersheyOutTextXY(x,y : integer; s : string);
var
  i : integer;
begin
  HersheyMove(x,y);
  HersheyOutText(s);
end;

{****************************************************************************}
{* Unit body. Initialize the parameters.                                    *}
{****************************************************************************}
begin
  HersheyMove(0,0);
  HersheyFontArray:= nil;
  HersheySetFont(HersheyRomanS);
  HersheySetGlyphSize(5,5);
  HersheySetAngle(0);
  HersheySetStringJustify(-1,0);
  HersheySetMaxX(640,1);
end.