fpc/rtl/dos/ppi/text.ppi

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1993,97 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{***************************************************************************}
{                               Textausgabe                                 }
{***************************************************************************}

    const
       { maximal 16 Vektorfonts unterst�tzen }
       { um mehr Fonts laden zu k”nnen, muá  }
       { diese Variable erh”ht werden        }
       maxfonts = 16;
       fontdivs:array[0..maxfonts]of integer=
       (1,4,3,4,4,4,4,4,4,3,3,1,1,1,1,1,1);
    
    type
       pbyte = ^byte;

    {$PACKRECORDS 1}
       pfontdata = ^tfontdata;

       tfontdata = record
          filetyp              : char;
          nr_chars             : word;
          undefined1           : byte;
          value_first_char     : byte;
          undefined2           : array[1..3] of byte;
          dist_origin_top      : shortint;
          dist_origin_baseline : shortint;
          dist_origin_bottom   : shortint;
          undefined3           : array[1..5] of byte;
       end;

    {$PACKRECORDS NORMAL}

       tfontrec = record
          name : string[8];
          data : pointer;
          header : pfontdata;
          offsets : pword;
          widths : pbyte;
          instr : pbyte;
       end;

    var
       fonts : array[1..maxfonts] of tfontrec;
       installedfonts : longint;

{$I FONT.PPI}              

    { gibt true zur�ck, wenn p auf eine g�ltige Fontdatei zeigt }

    function testfont(p : pointer) : boolean;

      begin
         testfont:=(pchar(p)^='P') and
          (pchar(p+1)^='K') and
          (pchar(p+2)^=#8) and
          (pchar(p+3)^=#8);
      end;

    { setzt die Hilfsdaten f�r den Font mit der Nr. font }
    { der Zeiger data muá schon gesetzt sein             }

    function setupfont(font : word) : integer;

      begin
         setupfont:=grOK;
         fonts[font].header:=fonts[font].data+$80;
         if fonts[font].header^.filetyp<>'+' then
           begin
              setupfont:=grInvalidFont;
              exit;
           end;
         fonts[font].offsets:=fonts[font].data+$90;
         fonts[font].widths:=pbyte(fonts[font].offsets+fonts[font].header^.nr_chars*2);
         fonts[font].instr:=fonts[font].widths+fonts[font].header^.nr_chars;
      end;

    function InstallUserFont(const FontFileName : string) : integer;

      begin
         _graphresult:=grOk;
         { es muá kein Graphikmodus gesetzt sein! }
         { ist noch Platz f�r einen Font ? }
         if installedfonts=maxfonts then
           begin
              _graphresult:=grError;
              exit;
           end;
         inc(installedfonts);
         fonts[installedfonts].name:=FontFileName;
         fonts[installedfonts].data:=nil;
         InstallUserFont:=installedfonts;
      end;

    function RegisterBGIfont(font : pointer) : integer;

      var
         hp : pbyte;
         b : word;
         name : string[12];

      begin
         { noch nicht garantiert, daá alles klappt }
         RegisterBGIfont:=grInvalidFontNum;
         { es muá kein Graphikmodus gesetzt sein! }
         if testfont(font) then
           begin
              hp:=pbyte(font);
              { Ende des Textheaders suchen }
              while hp^<>$1a do
                hp:=hp+1;
              { auf Start des Names springen }
              hp:=hp+3;
              { Namen lesen }
              name:='';
              for b:=0 to 3 do
                name:=name+char((hp+b)^);
              { richtigen Font suchen }
              for b:=1 to installedfonts do
                begin
                   if fonts[b].name=name then
                     begin
                        fonts[b].data:=font;
                        RegisterBGIfont:=grOK;
                        RegisterBGIfont:=setupfont(b);
                     end;
                end;
           end
         else
           RegisterBGIFont:=grInvalidFont;
      end;

    procedure GetTextSettings(var TextInfo : TextSettingsType);

      begin
         _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         textinfo:=akttextinfo;
      end;

    procedure OutText(const TextString : string);
      var x,y:integer;
      begin
         _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         x:=curx; y:=cury;
         OutTextXY(curx,cury,TextString);
         { wenn horizontal und linksb�ndig ausgegeben wird, dann }
         { Grafikcursor nachf�hren }
         if (akttextinfo.direction=HorizDir) and
           (akttextinfo.horiz=LeftText) then
               inc(x,textwidth(TextString));
         curx:=x; cury:=y;   { LineTo manipuliert den GrafikCursor !! }
      end;

    procedure outtext(const charakter : char);
    var s:string;
        x,y:integer;
    begin
      s:=charakter;
      _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         x:=curx; y:=cury;
         OutTextXY(curx,cury,s);
         { wenn horizontal und linksb�ndig ausgegeben wird, dann }
         { Grafikcursor nachf�hren }
         { if (akttextinfo.direction=HorizDir) and
           (akttextinfo.horiz=LeftText) then }
               inc(x,textwidth(s));  
         curx:=x; cury:=y;   { LineTo manipuliert den GrafikCursor !! }
    end;
   
    procedure OutTextXY(x,y : integer;const TextString : string);

      var
         b1,b2         : shortint;
         c,instr,mask  : byte;
         i,j,jj,k,l    : longint;
         oldvalues     : linesettingstype;
         nextpos       : word;
         xpos,ypos,offs: longint;        
         FontPtr       : Pointer;
      begin
         _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
 
         { wirkliche x- und y-Startposition berechnen }
         if akttextinfo.direction=horizdir then
         begin   
           case akttextinfo.horiz of
                centertext : XPos:=(textwidth(textstring) shr 1);
                lefttext   : XPos:=0;
                righttext  : XPos:=textwidth(textstring);
           end;
           case akttextinfo.vert of
               centertext : YPos:=(textheight(textstring) shr 1);
               bottomtext : YPos:=0;
               toptext    : YPos:=textheight(textstring);
           end;
         end else  
         begin   
           case akttextinfo.horiz of
                centertext : XPos:=(textheight(textstring) shr 1);
                lefttext   : XPos:=0;
                righttext  : XPos:=textheight(textstring);
           end;
           case akttextinfo.vert of
               centertext : YPos:=(textwidth(textstring) shr 1);
               bottomtext : YPos:=0;
               toptext    : YPos:=textwidth(textstring);
           end;     
         end;         
         X:=X-XPos;
         Y:=Y+YPos;
         XPos:=X; YPos:=Y;
         
         if akttextinfo.font=DefaultFont then begin
           if akttextinfo.direction=horizdir then
             ypos:=ypos-6*akttextinfo.charsize
           {else
             xpos:=xpos-6*akttextinfo.charsize};
           (* c:=textwidth(textstring) div 8 - 1; { Charcounter }
             gave wrong values if charsize<>1 PM *)
           c:=length(textstring); { Charcounter }
           FontPtr:=@defaultfontdata;

           for i:=1 to c do begin
             offs:=ord(textString[i]) shl 3;   { Offset des Chars in Data }
             for j:=0 to 7 do begin
               mask:=$80;
               b1:=defaultfontdata[offs+j];    { Offset der Charzeile }
               jj:=j*akttextinfo.charsize;
               if akttextinfo.direction=horizdir then
                 xpos:=x+((i-1) shl 3)*akttextinfo.charsize
               else
                 ypos:=y-((i-1) shl 3)*akttextinfo.charsize;
               for k:=0 to {7}8*akttextinfo.charsize-1 do
                 begin
                 if (b1 and mask) <> 0 then
                   for l:=0 to akttextinfo.charsize-1 do
                     if akttextinfo.direction=horizdir then
                       putpixeli(xpos+k,jj+ypos+l,aktcolor)
                     else
                       putpixeli(xpos+jj+l,ypos-k,aktcolor)
                 else if ClearText then
                   for l:=0 to akttextinfo.charsize-1 do
                     if akttextinfo.direction=horizdir then
                       putpixeli(xpos+k,jj+ypos+l,aktbackcolor)
                     else
                       putpixeli(xpos+jj+l,ypos-k,aktbackcolor);
                 if (k mod akttextinfo.charsize) = akttextinfo.charsize-1 then
                   mask:=mask shr 1;
               end;
             end;
           end;        
         end else
           
           begin
              { Linienstil setzen }
              getlinesettings(oldvalues);
              setlinestyle(solidln,oldvalues.pattern,normwidth);
              if akttextinfo.direction=vertdir then xpos:=xpos + Textheight(textstring);
              curx:=xpos; cury:=ypos; x:=xpos; y:=ypos;
              for i:=1 to length(textstring) do
                begin
                   c:=byte(textstring[i]);
                   c:=c-fonts[akttextinfo.font].header^.value_first_char;
                   { definiertes Zeichen ? }
                   if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then continue;
                   nextpos:=fonts[akttextinfo.font].offsets[c];
                   while true do
                     begin
                         b1:=fonts[akttextinfo.font].instr[nextpos];
                         nextpos:=nextpos+1;
                         b2:=fonts[akttextinfo.font].instr[nextpos];
                         nextpos:=nextpos+1;
                         instr:=((b1 and $80) shr 6)+((b2 and $80) shr 7);
                         b1:=b1 and $7f;
                         b2:=b2 and $7f;
                         { Vorzeichen erweitern }
                         if (b1 and $40)<>0 then b1:=b1 or $80;
                         if (b2 and $40)<>0 then b2:=b2 or $80;
                         { neue Stiftposition berechnen und skalieren }
                         if akttextinfo.direction=VertDir then
                           begin
                             xpos:=x-((b2*aktmultx) div aktdivx);
                             ypos:=y-((b1*aktmulty) div aktdivy); 
                           end
                         else
                           begin
                             xpos:=x+((b1*aktmultx) div aktdivx) ;
                             ypos:=y-((b2*aktmulty) div aktdivy) ; 
                           end;
                         case instr of
                            0 : break;
                            2 : begin curx:=xpos; cury:=ypos; end;
                            3 : begin line(curx,cury,xpos,ypos);
                                      curx:=xpos; cury:=ypos;
                                end;
                         end;
                     end;
                   if akttextinfo.direction=VertDir then
                     y:=y-(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx)              
                   else
                     x:=x+(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx) ; 
                end;  
              setlinestyle( oldvalues.linestyle, oldvalues.pattern, oldvalues.thickness);
           end;
      end;

    procedure outtextxy(x,y: Integer;const charakter : char);
    var s:string;
    begin
      s:=charakter;
      outtextXY(x,y,s);
    end;
   
    function TextHeight(const TextString : string) : word;

      begin
         _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         if akttextinfo.font=DefaultFont 
            then TextHeight:=6+akttextinfo.charsize
            else
              TextHeight:=(((fonts[akttextinfo.font].header^.dist_origin_top-
                fonts[akttextinfo.font].header^.dist_origin_bottom) * aktmulty) div aktdivy) ;
      end;

    function TextWidth(const TextString : string) : word;
      var i,x : Integer;
          c   : byte;
      begin
         _graphresult:=grOk;  x:=0;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         if akttextinfo.font = Defaultfont then
            TextWidth:=length(TextString)*8*akttextinfo.charsize
            else begin
               for i:=1 to length(TextString) do begin
                   c:=byte(textstring[i]);
                   dec(c,fonts[akttextinfo.font].header^.value_first_char);
                   { definiertes Zeichen ? }
                   if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then
                     continue;
                   x:=x+fonts[akttextinfo.font].widths[c];                  
               end;
            TextWidth:=((x * aktmultx) div aktdivx) ;
            end;
      end;

    procedure SetTextJustify(horiz,vert : word);

      begin
         _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         if (horiz<0) or (horiz>2) or
            (vert<0) or (vert>2) then
           begin
              _graphresult:=grError;
              exit;
           end;
         akttextinfo.horiz:=horiz;
         akttextinfo.vert:=vert;
      end;

    procedure SetTextStyle(font,direction : word;charsize : word);

      var
         f : file;

      begin
         _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         { Parameter auf G�ltigkeit �berpr�fen }
         if font>installedfonts then
           begin
              _graphresult:=grInvalidFontNum;
              exit;
           end;
         akttextinfo.font:=font;
         if (direction<>HorizDir) and (direction<>VertDir) then
           direction:=HorizDir;
         akttextinfo.direction:=direction;
         akttextinfo.charsize:=charsize;
         if (charsize <> usercharsize) then begin        
            aktmultx:=charsize;
            aktdivx:=fontdivs[font];
            aktmulty:=charsize;
            aktdivy:=fontdivs[font];
         end;
         { Fontdatei laden ? }
         if (font>0) and not assigned(fonts[font].data) then
           begin
              assign(f,bgipath+fonts[font].name+'.CHR');
              reset(f,1);
              if ioresult<>0 then
                begin
                   _graphresult:=grFontNotFound;
                   akttextinfo.font:=DefaultFont;
                   exit;
                end;
              getmem(fonts[font].data,filesize(f));
              if not assigned(fonts[font].data) then
                begin
                   _graphresult:=grNoFontMem;
                   akttextinfo.font:=DefaultFont;
                   exit;
                end;
              blockread(f,fonts[font].data^,filesize(f));

              if testfont(fonts[font].data) then
                _graphresult:=setupfont(font)
              else
                begin
                   _graphresult:=grInvalidFont;
                   akttextinfo.font:=DefaultFont;
                   freemem(fonts[font].data,filesize(f));
                end;
              close(f);
           end;
      end;

    procedure SetUserCharSize(Multx,Divx,Multy,Divy : word);

      begin
         _graphresult:=grOk;
         if not isgraphmode then
           begin
              _graphresult:=grnoinitgraph;
              exit;
           end;
         aktmultx:=Multx;
         aktdivx:=Divx;
         aktmulty:=Multy;
         aktdivy:=Divy;
      end;

 
{
  $Log$
  Revision 1.3  1998-11-23 10:04:19  pierre
    * pieslice and sector work now !!
    * bugs in text writing removed
    + scaling for defaultfont added
    + VertDir for default font added
    * RestoreCRTMode corrected

  Revision 1.2  1998/11/18 09:31:42  pierre
    * changed color scheme
      all colors are in RGB format if more than 256 colors
    + added 24 and 32 bits per pixel mode
      (compile with -dDEBUG)
      24 bit mode with banked still as problems on pixels across
      the bank boundary, but works in LinearFrameBufferMode
      Look at install/demo/nmandel.pp

  Revision 1.1.1.1  1998/03/25 11:18:42  root
  * Restored version

  Revision 1.3  1998/01/26 11:58:41  michael
  + Added log at the end


  
  Working file: rtl/dos/ppi/text.ppi
  description:
  ----------------------------
  revision 1.2
  date: 1997/12/01 12:21:34;  author: michael;  state: Exp;  lines: +14 -0
  + added copyright reference in header.
  ----------------------------
  revision 1.1
  date: 1997/11/27 08:33:51;  author: michael;  state: Exp;
  Initial revision
  ----------------------------
  revision 1.1.1.1
  date: 1997/11/27 08:33:51;  author: michael;  state: Exp;  lines: +0 -0
  FPC RTL CVS start
  =============================================================================
}