mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-04 08:02:17 +02:00
529 lines
17 KiB
Plaintext
529 lines
17 KiB
Plaintext
{
|
||
$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<73>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<75>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<73>ndig ausgegeben wird, dann }
|
||
{ Grafikcursor nachf<68>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<73>ndig ausgegeben wird, dann }
|
||
{ Grafikcursor nachf<68>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 <20>berpr<70>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.1 1998-12-21 13:07:05 peter
|
||
* use -FE
|
||
|
||
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
|
||
=============================================================================
|
||
}
|