МОДУЛЬ ПОДДЕРЖКИ ТЕКСТОВОГО ВВОДА/ВЫВОДА В ГРАФИЧЕСКОМ РЕЖИМЕ F.GRTEXT
Описание модуля см. п. 1.3.
{$N+,E+} ^=====»»=====; onit F_GrText; ^=s=——-=—»—»==;
/
Модуль поддержки текстового ввода/вывода
в графическом режиме
} ^—————————————————————————————/
INTERFACE
^—————————————————————————————}
Uses DOS,Graph,CRT;
const
AppHandle: Boolean = True; {Флаг управления аппаратной поддержкой CGA/EGA/VGA)
ESCFlag : Boolean = False; {Флаг завершения ввода no ESC} {
Следующие константы используются для указания типа рамки при обращении к процедуре SETtlINDOff. } const
EmptyBorder - 0; {Стереть рамку}
SingleBorder =• 1; {Рамка из одинарных линий) DoubleBorder ==2; /Рамка из двойных линий} I
Следующий массив определяет символы псевдографики для вычерчивания рамок (альтернативная кодировка) } const
BorderChar: array [0..2,1..6] of Char = ((#32, #32, #32, #32, #32, #32), (#218, #196, #191, #179, #192, #217), (#201, #205, #187, »18б, #200, #188));
Procedure CIrScr;
{Очищает текстовое окно или экран)
Procedure Colors(Text,Back: Byte);
(Устанавливает цвета для текстового вывода}
Function GetMaxChar: Byte;
{Возвращает максимальное количество символов на строке}
Function GetMaxLine: Byte;
{Возвращает максимальное количество строк на экране}
Procedure GetWindGraphCoo(var X1,Y1,X2,Y2: Integer) ;
(Возвращает графические координаты текстового окна)
Procedure GotoXY(X,Y: Byte);
{Перемещает курсор в заданную позицию}
Function GraphCooX(X: Byte): Integer;
{Возвращает графическую координату по заданной горизонтальной текстовой координате}
Function GraphCooY(Y: Byte): Integer;
{Возвращает графическую координату по заданной вертикальной текстовой координате}
Procedure GraphWriteOn;
{Переназначает стандартные каналы ввода/вывода на процедуры Graph Write и GraphRead}
Procedure GraphWriteOff;
{Восстаналивает стандартные каналы ввода/вывода}
Procedure SetFontfFnt: Pointer; X,Y: Byte);
{Устанавливает текущий шрифт для текстового ввода/вывода}
Procedure Scrolling(N: Integer);
{Осуществляет сдвиг содержимого окна вверх или вниз:
N - количество строк, на которые сдвигается окно (N < 0 - сдвиг вниз)}
Procedure TextBackGround(Color: Byte);
{Устанавливает цвет фона для символов}
Procedure TextColor(Color: Byte);
{Устанавливает цвет символов}
Function TextCooXfX: Integer): Byte;
(Возвращает ближайшую текстовую координату по заданной горизонтальной графической координате}
Function TextCooY(Y: Integer): Byte;
{Возвращает ближайшую текстовую координату по заданной вертикальной графической координате}
Function WhereX: Byte;
{Возвращает горизонтальную координату курсора}
Function WhereY: Byte;
{Возвращает горизонтальную координату курсора}
Procedure Window(Xl,Yl,X2,Y2: Byte);
{Устанавливает текстовое окно}
Procedure SetWindow(Xl,Yl,X2,Y2,BordeJ:: Byte;
Header: String; Clip,Build,Play: Boolean);
{Устанавливает окно, очищает его и обводит рамкой}
Function RegisterCHRFile(S: String): Integer;
{Регистрирует векторный шрифт, содержащийся в файле с именем S, и возвращает порядковый номер шрифта)
Function RegisterCHRFont(Font: Pointer): Integer;
{Регистрирует векторный шрифт, загруженный в память по адресу Font, и возвращает порядковый номер шрифта}
Procedure OutString(S: String; Font: Integer; Angle: Integer; MX,MY: Real) {Выводит с помощью векторного шрифта Font строку S с поворотом на угол Angle и с масштабными коэффициентами MX,MY}
^_—————————————————————————————;
IMPLEMENTATION
^———————————————————..——————————;
type
aob = array [O.-MaxInt] of Byte;
const
ChangeWR: Boolean -e False; (Признак замены драйвера вывода} Font: лaoЬ = NIL; {Адрес массива шрифта} TCol: Byte = LightGray; {Цвет символов} BCol: Byte - Black; {Цвет фона}
var
OldOut, OldInp: Text;
Xt: Byte; (Горизонтальная координата курсора} Xg: Integer;
Yt: Byte; {Вертикальная координата курсора} Yg: Integer;
Xlt,Ylt,X2t,Y2t: Byte; {Координаты активного окна} Xlg,Ylg,X2g,Y2g: Integer;
MaxChar: Byte; {Длина текстовой строки экрана} MaxLine: Byte; {Количество строк на экране} XF: Byte; {Ширина символа в пикселах} YF: Byte; (Высота символа в пикселах} Adapter: Byte; (Признак аппаратуры адаптера}
Procedure WriteChar(X,Y: Integer; Ch: Byte);
{Выводит символ с кодом Ch в позицию X,У} var
k: Integer;
b: Byte;
j: Byte;
begin
for k := 0 to predd'F) do begin
b := Font" [Ch*YF+lc] ;
case Adapter of
О: {Вывод без аппаратной поддержки}
begin
for j := 0 to 7 do
if b and (128 shr j)<>0 then
PutPixel(X*XF+j,Y+k,TCol) else if BColoO then
PutPixel(X*XF+j,Y+k,BCol) end;
1: {Аппаратная поддержка EGA/VGA}
asm
{Вычисляем адрес байта а видеопамяти}
mov ax,$AOOO
mov es,ax {es = $АООО}
mov bx, у (Ьх = у)
add bx,k (Ьх » (y-l-k) }
mov cl,4
shi bx,cl
mov dx,bx {dx » (y+k>*16}
mov ci,2
shi bx,cl {bx = <y+k)*64f
add bx,dx {bx = (y+k) *80)
add bx,x {bx = (y+k)*80+x} {Устанавливаем режим записи 2]
mov dx,$3CE
mov al,5
out dx,al
inc dx
mov al,2
out dx,al {Разрешаем изменять только биты символа}
mov dx,$3CE
mov al,8
out dx,al
inc dx
mov al,b {Разрешены биты символа}
out dx,al
{Выводим символ}
mov al,es: [bx]
mov al,TCol
mov es:[bx],al {Проверяем фоновый цвет}
mov dl,BCol
cmp dl, 0
je @0 {Изменяем биты фона для создания фонового цвета}
mov dx,$3CE
mov al,8 {Регистр маски битов}
out dx,al
inc dx
mov al,b {Разрешить изменение}
not al {разрядов фона}
out dx,al
{Выводим фон) mov al,es:[bx] mov al,BCol
mov es:[bx],al {Устанавливаем все биты} @0:
end;
end end end; {WriteChar} /———————————————;
Function GraphRead(var F: TextRec): Integer; Far;
(Осуществляет ввод текста для процедур Read/ReadLn} var
XOt : Byte; {Начальное положение курсора}
YUp,YDn: Integer; {Размер курсора}
InsFlag: Boolean; {Флаг режима вставки}
Cur : Pointer; (Изображение курсора}
Back : Pointer; {Фон курсора}
S : String; {Строка ввода}
С '. Char; {Очередной символ} const
CSize: Word =• 0;
Procedure SetCursor;
{Устанавливает форму курсора} var
Filllnfo: FillSettingsType;
begin
if CSizeOO then begin
FreeMem(Back,CSize) ;
FreeMem(Cur,CSize) end;
YDn :== Yg+YF-1;
if InsFlag then YUp := YDn - 2
else
YUp :- Yg;
CSize := ImageSize(Xg,YUp,Xg+XF-l,YDn) ;
GetMem(Back,CSize) ;
Getlmage (XgiYUp^g+XF-l^YDr^Back^) ;
GetFillSettings(Filllnfo) ;
SetFillStyle(SolidFill,TCol) ;
Bar(Xg,YUp,Xg+XF-l,YDn) ;
with Filllnfo do
SetFillStyle(Pattern,Color) ;
GetMem(Cur,CSize) ;
Getlmage(Xg,YUp,Xg+XF-1,YDn,Cur^) ;
PutImage (XgyYUptBack^NormalPut) ;
end; {SetCursor} {——————}
Procedure Cursor;
{Создает изображение мигающего курсора} var
k: Integer;
const
D = 10;
begin
Getlmage(Xg,YUp,Xg+XF-1,YDn,Bac^) ;
while not KeyPressed do begin
PutImage(Xg,YUp,Cur",NormalPut);
for k :- 1 to 10 do
if not KeyPressed then Delay(D) ;
PutImage(Xg,YUp,Back^,NormalPut);
for k :- 1 to 10 do
if not KeyPressed then
Delay(D) end end; {Cursor} {—————} Procedure Home;
{Курсор - в начало строки ввода} begin
GotoXY(XOt,WhereY) ;
end; {Home} {—————} Procedure Left;
{Курсор - на символ влево} begin
if WhereX>XOt then
GotoXY(WhereX-1,WhereY) end; {Left} {—————} Procedure Right;
{Курсор - на символ вправо} begin
if WhereX-XOt<Length(s) then
GotoXY(WhereX+1,WhereY) end; {Right} {—————} Procedure EndKey;
{Курсор ~ в конец строки} begin
GotoXY(XOt+Lengthfs),WhereY) end; {EndKey} {—————] Procedure Ins;
{Переключение режима ввода} begin
InsFlag := not InsFlag;
SetCursor end; {Ins} {—————} Procedure WriteString;
{Восстанавливает ввод после редактирования} var
k: Byte;
begin
for k :- 1 to Length(S) do
WriteChar(Xlt+XOt+k-3,Yg,ord(S[k])) ;
WriteChar(Xlt+XOt+Length(S)-2,Yg,32) end;
(—————} Procedure Del;
{Забить символ с курсором} var
n: Byte;
begin
n := WhereX-XOt;
if n<Length(S) then begin
Delete (S,n+l,l) ;
WriteString end end; {Del} {—————} Procedure Backspace;
(Забить символ слева от курсора} vac
n: Byte;
begin
n := WhereX-XOt;
if n>=l then begin
Delete(S,n,l) ;
WriteString;
GotoXY(WhereX-l,WhereY) end end; {Backspace} !—————} Procedure AnyChar;
var
n: Byte;
begin
n := WhereX-XOt;
if n»Length(S) then
if Xlt+XOt+Length(S)<-X2t then
S := S+c else else
if InsFlag and (Xlt+XOt+Length(S) <»S<2t) then
Insert (C,S,n+l) else
S[n+l] := C;
WriteString;
GotoXY(WhereX+l,WhereY) end; {AnyChar} {—————} Procedure Enter;
{Завершает ввод по клавише Enter} var
k: Byte;
begin
with F do begin
for k := 1 to Length(S) do BufPtr"[BufEnd+k-1] := S[k];
BufEnd := Length(S);
if BufEnd°0 then begin
BufEnd := 1;
BufPtr"[0] := ' ' end end;
GotoXY(l,WhereY+l) end; {Enter} (—————}
Procedure ESC;
{Выход по клавише ESCf begin
with F do begin
BufEnd :=° 1;
BufPtr^tO] := • ';
ESCFlag := True end end; {ESC} {—————} begin (GraphRead}
with F do if (Mode-fminput) and (BufEnd»0) than begin
XOt := WhereX;
InsFlag := True;
ESCFlag := False;
SetCursor;
repeat
Cursor;
с := ReadKey;
case с of
#0: case ord(ReadKey) of 71: Home;
75: Left;
77: Right;
79: EndKey;
82: Ins;
83: Del;
else
с := #0 end;
#8: Backspace;
#13: Enter;
#27: ESC;
else
AnyChar end;
until (c-#13) or (c=#27) ;
FreeMem(Back,CSize) ;
FreeMem(Cur,CSize) ;
CSize :- 0 end;
GraphRead := 0 end; {GraphRead} ^____—————————————;
Function GraphWrite(var F: TextRec;: Integer; Far;
{Осуществляет вывод текста} var
Drv,Mode: Integer;
k: Integer;
Reg: Registers;
begin
if Font=NIL then exit;
DetectGraph(Drv,Mode) ;
if AppHandle and (Drv in [3..5,9]) then Adapter :- 1 {EGA, VGA}
else
Adapter := 0; {Другие типы или нет AppHandle} with F do
if (Mode=fm0utput) and (BufPos>0) then begin
for k := 0 to BufPos-1 do case BufPtr'^k] of
#7: with Reg do
begin {Звук}
ah := $E;
al := 7;
Intr($10,Reg) end;
#8: if k>BufEnd then
begin (Забой слева от курсора}
WriteChar(Xt-2,Yg,32) ;
GotoXY(WhereX-l,WhereY) end;
#10: if Yt+1 in [Ylt..Y2t] then /Перевод строки} GotoXY(WhereX,WhereY+l) ;
#13: {Возврат каретки} GotoXY(l,WhereY) ;
else begin
WriteChar(Xt-l,Yg,ord(BufPtrA(lt])) ;
if Xt+1 in [Xlt..X2t] then
GotoXX(WhereX+l,WhereY) else if Yt+1 in [Ylt..Y2t] then
GotoXY(l,WhereY+l) end end;
BufPos :•= 0 end;
GraphWrite := 0 end; {Graphfirite} ^———————————————;
Function Zerofvar F: TextRec): Integer; Far;
{Заглушка для функций Open/Close} begin
Zero := 0 end; {Zero} _•————————————————;
Function Mush (var F: TextRec): Integer; Far;
(Обнуляет буфер ввода} begin
with F do begin
BufPos := 0;
BufEnd := 0 end;
Flush := 0 end;
/————————————————;
Procedure CIrScr;
(Очищает текстовое окно или экран} var
FillInfo: FillSettingsType;
begin
if FontoMIL then begin
GetFillSettings(Filllnfo);
SetFillStyle(SolidFill,BCol) ;
Bar(Xlg,Ylg,X2g,Y2g);
with Filllnfo do
SetFillStyle(Pattern,Color) ;
GotoXY(l,l) end end; {CIrScr} {„. —————————— ————;
Procedure Colors(Text,Back: Byte);
(Устанавливает цвета для текстового вывода} begin
TextColor(Text);
TextBackGround(Back) end; {Colors} {., _———————. ———.——;
Function GetMaxChar: Byte;
{Возвращает максимальное количество символов на строке} begin
GetMaxChar := MaxChar end; {GetMaxChar} /————————————————;
Function GetMaxLine: Byte;
{Возвращает максимальное количество строк} begin
GetMaxLine :"= MaxLine end; {GetMaxLine} {-, ———————— —————_-;
Procedure GetWindGraphCoo(var X1,Y1,X2,Y2: Integer);
!Возвращает графические координаты текстового окна} begin
XI := Xlg;
Yl :° Ylg;
X2 :- X2g;
Y2 :=• Y2g
end; {GetWindGraphCoo} /——___———— ——————,——;
Procedure GotoXY(X,Y: Byte);
^Перемещает курсор в заданную позицию} begin
if (FontoMIL) and (X in [1. .MaxChar]) and
(Y in [1..MaxLine]) and (X<=X2t-Xlt+l) and (Y<=Y2t-Ylt+l) then begin
Xt :» X+Xlt-1;
Yt := Y+Ylt-1;
Xg := GraphCooX(Xt) ;
Yg := GraphCooY(Yt) end end; {GotoXY} f,- _——————__———————;
Function GraphCooX(X: Byte): Integer;
{Возвращает графическую координату по заданной горизонтальной текстовой координате} begin
if FontoHIL then
GraphCooX := pred(X)*XF else
GraphCooX :•= -1 end; {GraphCooX}
Function GraphCooY(Y: Byte): Integer;
{Возвращает графическую координату по заданной вертикальной текстовой координате) begin
if FontoNIL then
GraphCooX :- pred(Y)*YF
else
GraphCooY := -1 end; {GraphCooY} ^————————————————;
Procedure GraphWriteOn;
{Переназначает стандартные каналы ввода/вывода на процедуры GraphWrite и -GraphReadf begin
if not ChangeWR then begin
Move(Output,OldOut,SizeOt(Output)) ;
with TextRec(Output) do begin
OpenFunc :== SZero;
CloseFunc := @Zero;
FlushFunc := OGraphWrite;
InOutFunc :" SGraphWrite end;
Move(Input,Oldlnp,SizeOf(Input)) ;
with TextRec(Input) do begin
OpenFunc := @Zero;
CloseFunc := @Zero;
FlushFunc :" SFlush;
InOutFunc := @GraphRead end;
ChangeWR := True end end; {GraphlfrlteOn} {„. ———————.——————;
Procedure GraphWriteOff;
(Восстаяаливает стандартные каналы ввода/вывода) begin
if ChangeWR then begin
Move(OldOut,Output,SizeOf(Output)) ;
Move(Oldlnp,Input,SizeOf(Input));
ChangeWR := False end end; I Graph»rlteOff} ^————————————————;
Procedure SetFont(Fnt: Pointer; X,Y: Byte) ;
{Устанавливает текущий шрифт для текстового ввода/вывода! begin
Font := Fnt;
MaxChar := succ(GetMaxX) div X;
MaxLine :== succ (GetMaxY) div У;
XF := X;
YF :- Y;
Window(1,l,MaxChar,MaxLine) end; {SetFont} _.————————————————^
Procedure Scrolling(N: Integer);
{Осуществляет сдвиг содержимого окна вверх или вниз;
N - количество строк, на которые сдвигается окно (N < 0 - сдвиг вниз)} var
k: Byte;
х,у: Word;
LineSize: Word;
P: Pointer;
Filllnfo: FillSettingsType;
begin
GetFillSettings(Filllnfo) ;
SetFillStyle (SolidFUl.BCol) ;
LineSize :- ImageSize(xlg,ylg,x2g,ylg+YF);
if abs(N»=Y2t-Ylt+l then
Bar(xlg,ylg,x2g,y2g) (Очистить окно} else if N>0 then
begin {Сдвиг вверх} GetMem(P,LineSize);
for k := 0 to YZt-Ylt-N do begin
GetImagetxIgtylg+lN+krYFfXPgtylg+fN+k+l^YF,?^) ;
PutImage(xlg,ylg+k*YF,P",NormalPut) end;
FreeMem(P,LineSize);
Bar(xlg,y2g-N*YF,x2g,y2g) and else if N<0 then
begin {Сдвиг вниз! GetMem(P,LineSize);
N :=- abs(N) ;
for k :- Y2t-Ylt-N downto 1 do begin
Getlmage(xlg,ylg+(k-1)*YF,x2g,ylg+k*YF,P^ ;
PutImage(xlg,y2g-(Y2t-Ylt-N-k+l)*YF,P",NormalPut) end;
FreeMem(P,LineSize) ;
Bar(xlg,ylg,x2g,ylg+N*XF) end;
with Filllnfo do
SetFillStyle(Pattern,Color) end; {Scrolling} /————————————————;
Procedure TextBackGround(Color: Byte);
(Устанавливает цвет фона для символов} begin
BCol := Color end; fTextBackGround} _•————————————————;
Procedure TextColor(Color: Byte);
{Устанавливает цвет символов} begin
TCol :== Color end; {TextColor} ,———————.———— —————^
Function TextCooX(X: Integer): Byte;
{Возвращает ближайшую текстовую координату по заданной горизонтальной графической координате} begin
it (FontoNIL) and (X in [0. .GetMaxX]) then
TextCooX := round(X/MaxChar)+1 else
TextCooX := 0 end; {TextCooX}
^——————————.————;
Function TextCooX(Y: Integer): Byte;
(Возвращает ближайшую текстовую координату по заданной вертикальной графической координате! begin
if (FontoNIL) and (Y in [0. .GetMaxY]) then TextCooY := round(Y/MaxLine)+1
else
TextCooY := 0 end; {TextCooY} ^__————_——————————;
Function WhereX: Byte;
(Возвращает горизонтальную координату курсора} begin
if FontOMIL then
WhereX := Xt-Xlt+1 else
WhereX := 0 end; {WhereX} ^__——————————————/
Function WhereY: Byte;
^Возвращает горизонтальную координату курсора} begin
if FontOMIL then
WhereX := Yt-Ylt+1 else
WhereY := 0 end; (fihereY} ^_-_———————————————;
Procedure Window(XI,Y1,X2,Y2: Byte);
{Устанавливает текстовое окно} begin
if (FontoNIL) and (XI in [1. .MaxChar]) and (Yl in [1..MaxLine]) and (X2 in [1..MaxChar]) and (Y2 in [1..MaxLine]) and (X2>=X1) and (Y2>=Y1) then begin
Xt := XI;
Yt := Yl;
Xg :== XF*pred(Xt) ;
Yg := YF*pred(Yt) ;
Xlt := XI;
Ylt := Yl;
X2t := X2;
y2t := Y2;
Xlg := XF*pred(Xlt) ;
Ylg := YF*pred(Ylt) ;
X2g := XF*X2t;
Y2g := YF*Y2t end end; {Window} ^————————————————;
Procedure SetWindow(XI,Y1,X2,Y2,Border: Byte;
Header: String; Clip,Build,Play: Boolean);
(Устанавливает окно, очищает его и обводит рамкой}
const
TonBeg = 400;
TonEnd = 800;
Pause = 5;
N = 20;
var
k,X,xxl,yyl,xx2,yy2,dx,dy: Byte;
dt: Integer;
begin
if (FontOMIL) and (XI in [1. .MaxChar]) and (Yl in [1..MaxLine]) and (X2 in [1..MaxChar1) and (Y2 in [1..MaxLine]) and (X2>=X1) and (Y2>=Y1) then begin
if Build and ((X2-X1>"4) or (X2-X1>-4)) tben begin
X := (X2-X1) div 2;
if X>1 then begin
xxl :» Xl+X-l;
xx2 := Xl+X+1 end else begin
xxl :" XI;
xx2 := X2 end;
X := (Y2-Y1) div 2;
i.? X>1 then begin
yyl := У1+Х-1;
yy2 := У1+Х+1 end else begin
yyl :- Yl;
yy2 := У2 end;
dx := (X2-X1) dULv N;
if dx=0 then dx := 1;
dy := (Y2-Y1) div Ы;
i? dy=0 then dy := 1;
dt := (TonEnd-TonBeg) div N;
for k :» 0 to N-1 do begin
if Play then
Sound(TonBeg+k*dt) ;
Window (x-xl, yyl, xx2, yy2) ;
CIrScr;
if xxl>xi then dec (xxl,dx) ;
if xx2<X2 then inc (xx2,dx) ;
if уу1>У1 then dec(yyl,dy) ;
if yy2<Y2 then inc(yy2,dy) ;
end;
мойоипа end;
Window(XI,Y1,X2,Y2) ;
CIrScr;
i? Border in [0..2] then begin
Write(BorderChar[Border,1]);
for k := 2 to X2-X1 do
Write(BorderChar[Border,2]);
Write(BorderChar[Border,3]) ;
for k := 2 to Y2-Y1 do begin
GotoXY(l,k) ;
Write(BorderChar(Border,4] )• t GotoXY(X2-Xl+l,k) ;
Write(BorderChar[Border,4]) end;
GotoXY(l,Y2-Yl+l) ;
Write(BorderChar[Border,5]);
for k :" 2 to X2-X1 do
Write(BorderChar[Border,2]) ;
Write(BorderChar[Border,6]) end;
if Length(Header)>0 then begin
if Length(Header)>X2-X1-2 then Header[0] :- chr(X2-X1-2):
GotoXY((X2-Xl-Length(Header)) div 2+2,1) ;
Write(Header) end;
if Clip then
Window(Xl+l,Yl+l,X2-l,Y2-l) end end; fSetffindow} ^-—————————.————————————————+
I Поддержка вывода сообщений вектортши I I шрифтами 1
+-------------—----—--—-——---—------——+;
type
PFontDesc =^TFontDesc;
TFontDesc = record {Описатель шрифта)
NextFont: PFontDesc; (Ссылка на следующий}
NFont : Integer; {Номер шрифта}
Name: record
case Byte of
0:(FName: String); (Имя файла)
l:(Flag : Byte; {Флаг формата) Addrs: record {Адрес}
sa,oa: Word end;
end;
FirstChr : Byte; {Первый сиывол}
LastChar : Byte; {Последний символ}
Height: ShortInt; {Высота от базы}
Bottom: ShortInt; {Высота до низа)
Offs: array [0..255] of Word; {Смещения!
Leng: array [0..255] of Word; {Длины} end;
TFontPara = record {Блок параметров шрифта/
ParPrefix : Char; (Символ "+"}
CharsCount: Word; (Количество символов в шрифте}
Reservl : Byte; (He используется}
FirstChar : Byte; (Код первого символа}
DataOffset: Word; (Смещение до векторных команд первого символа}
FillFlag : Byte; (Флаг заливки}
UpperMargin: Byte; (Высота символов}
Reserv2 : Byte; (He используется}
LowerMargin: Shortint; (Нижняя кромка}
Reserv3 : array [1..5] of Byte end;
THead = array [1..4] of Char;
const
FontList: PFontDesc Bs NIL; (Список шрифтов} FontNumb: Integer = 0; (Количество шрифтов} var
FDesc: TFontDesc;
F: File;
Buf: array [1..128] of Byte; (Заголовок) Head: THead absolute Buf;
FPar: TFontPara; (Параметры шрифта} coast
HeadO: THead = ('P','K',#8,#8);
Function RegisterCHRFile(S: String): Integer;
{Регистрирует векторный шрифт, содержащийся в файле с именем S, и возвращает порядковый номер шрифта} var
k: Integer;
Err: Boolean;
P,PD: PFontDesc;
ParOffs: Word;
Function ReadFile(var Dest; Size: Word): Boolean;
(Читает Size байт из файла F в переменную Dest} begin
BlockRead(F,Dest,Size,k) ;
ReadFile := k=Size end;
{——————}
begin
{Проверяем и корректируем имя} if pos (' . ',S)=0 then S := S+'.chr' ;
(Проверяем по списку, чтобы исключить повторную регистрацию} if FontNurnboO then begin
FDesc := FontList^-with FDesc do
while (NextFontOMIL) and (SOName.FName) do FDesc := MextFont^;
if S=FDesc.Name.PName then
begin (Найден в списке - вернуть номер} RegisterChrFile := FDesc.NFont;
Exit end end;
(Открываем файл} RegisterChrFile := -1;
Assign (F,S);
{$!-} Reset (F,1);
{$!+} if IQResultOO then
Exit;
{Читаем заголовок} if not ReadFile(Buf,128) then
Exit;
RegisterChrFile := -2;
if HeadoHeadO then
Exit; {Неверный формат файла} (Ищем конец текста} repeat
k := 1;
while (k<=128) and (Buf[k]o$lA) do inc(k);
if )c=129 then
if not ReadFile(Buf,128) then
Exit until But[k]=$lA;
{Позиционируем файл на блок параметров) ParOffs := Buf[k+l]+Buf[k+2] shi 8;
Seek(F,ParOffs) ;
{Читаем параметры}
if not ReadFile(FPar,16) or (FPar.ParPrefix<>'+') then Exit;
{Резервируем память для описателя} RegisterChrFile := -3;
if MaxAvaiKSizeOf(TFontDesc) then
Exit; /Her памяти для регистрации} New(PD) ;
{Формируем новый дескриптор} with PD^FPar do begin
NextFont := Nib;
NFont :- FontNumb+1;
Name.FName := S;
FirstChr := FirstChar;
LastChar := FirstChar+CharsCount-1;
Height := UpperMargin;
Bottom := LowerMargin;
{Читаем таблицу смещений} RegisterChrFile := -1;
Seek(F,ParOffs+DataOffset-3*CharsCount);
if not ReadFile(Offs[FirstChar],2*CharsCount) then begin
Dispose(PD) ;
Exit end;
{Настраиваем смещения) for k := FirstChar to LastChar do
Offs[k] := Offs[k]+ParOffs+DataOffset;
{Формируем таблицу длин} fo» k := PirstChar to LastChar-1 do Leng[k] := Offs[k+1]-Offs[k];
Leng[LastChar] := FileSize(F)-
Offs[LastChar-1]-ParOffs end;
{Формируем список описателей} if FontNumb=0 then
FontList := PD {Список был пустым} else
begin {Ищем конец списка} Р := FontList; {Начало списка} while P^NextFontONIL do
Р := P^.NextFont; {Next^NIL - конец} P^NextFont :» PD end;
inc(FontNumb)i RegisterChrFile := FontHumb end; {RegisterChrFile} ^_————.———————_
Function RegisterCHRFont(Font: Pointer): Integer;
{Регистрирует векторный шрифт, загруженный в память по адресу Font, и возвращает порядковый номер шрифта}
type
TByte = array [0..65534] of Byte;
var
PH: "THead;
PP: "TFontPara;
PB: "TByte absolute PH;
P,PD: PFontDesc;
k: Integer;
ParOffset: Word;
FileSize: Word;
begin
{Проверяем начало заголовка} PH :° Font;
RegisterChrFont := -Si-if PH^oHeadO then
Exit; {Нет поля 'РК'#8#8} k := 4 у {Ищем CopynghtEnd} while (PB''[k]o$lA) and (k<256) do
inc(k);
if PB^[k]o$lA then
Exit; /Яе нашли терминатор в 256 байтах} {Проверяем блок параметров} ParOffset := РВ^+И+РВ"^-!^] shi 8;
FileSize := PB'^ [k+7]^-PBЛ [k+8] shi 8;
PP :» AddrtPB^[ParOffset]);
if PPA.ParPrefix<>'+^ then
Exit; {Нет префикса параметров} {Резервируем память для описателя} RegisterChrFont :» -3;
if MaxAvail<SizeOf(TFontDesc) then
Exit; /йег памяти для регистрации} New(PD) ;
{Формируем новый дескриптор} with PD^PP^ do
begin
NextFont := 11IL;
NFont := FontNumb+1;
Name.Flag := 0; {Шрифт - в памяти)
k := ParOffset+DataOffset;
Name.Addrs.sa :=. segtRB-^k]); {Адрес} Name.Addrs.oa := ofs (PB" [Ic]); [шрифта} FirstChr := FirstChar;
LastChar :=' FirstChar+CharsCount-1;
Height := UpperMargin;
Bottom := LowerMargin;
{Переносим таблицу смещений) k := ParOffset+DataOf?set-3*CharsCount;
Move(PB"W,0ffs[FirstChar],2*CharsCount) ;
{Формируем таблицу длин} for k := FirstChar to LastChar^l do Leng[k] := Offs{k+ll-0ffstk};
Leng[LastChar] := FileSize-Offs[LastChar-1] end;
{Формируем список описателей} if FontNumb^O then
FontList := PD {Список был пустым} else
begin {Ищем конец списка} Р := FontList; {Начало списка} while P^.NextFontONIb do
Р := P^NextFont; {Sext=llIL - конец} P^-NextFont := PD end;
inc(FontNumb) ;
RegisterChrFont := FontNurob end; {RegisterCtirFont} /————————————;
Procedure OutString(S: String; Font: Integer; Angle: Integer; MX,MY: Real);
{Выводит с помощью векторного шрифта Font строку S с поворотом на угол Angle и с масштабными коэффициентами MX,UY) vac
х0,у0: Integer; (Начало очередного символа}
Ang: Real;
Procedure OutChar(var V);
{Выполняет векторные .команды V} var
Vec: array [1. .Maxlnt.1 of Word absolute V;
k,op: Word;
Procedure Coo(X,Y: Integer; var xx,yy: Integer);
{Осуществляет поворот координат X,Y на угол Angle и возвращает новые координаты хх,уу} var
г,a: Single;
begin
{Переводим в полярные координаты}
г :» sqrt(1.0*x*x+1.0*y*y);
if x=0 then if y<0 then 'а :=. -pi/2
else
a := pi/2
else
a := arctan(y/x);
a := a+Ang; {поворот координат}
{Вычисляем новые координаты)
уу := Round(r*sin(a));
хх := Round(r*cos(a)) end; {Coo} <-—"-——;
var
x, y,xl,yl,xx,yy: Integer;
begin (OutChar) k := 1;
x := xO;
у :- yO;
repeat
op := Vec[k] and $8080;
xx := Vec[k] and $7F;
yy := (Vec[k] shr 8) and $7F» if yy>63 then УУ ••= УУ-128;
{Учитываем масштабные коэффициенты} xx := Round(xx*MX) ;
yy := Round(yy*MY) ;
{Поворачиваем на угол Angle} Coo (xx,yy,xl,yl) ;
xl := xO+xl;
yl := yO-yl;
{Вычерчиваем вектор} if op=$8080 then Line(x,y,xl,yl; ;
{Переходим в новую точку, if opoO then begin
x := xl;
у :° yl end;
{Проверяем конец команд} if op°0 then
begin {Готовим вывод следующего} х0 := x;
yO :- у end else
inc(k) until Op=0 end; (OutChar) {——————}
var
F: File;
k,j: Word;
c: Byte;
Buf: array [1..1OOO] of Word;
P: PFontDesc;
PB: Pointer;
begin {OutString}
(Ищем регистрацию шрифта} if (FontNumb°0) or
(Font>FontNumb) or (S='') then Exit; (Нет ни одного шрифта, пустая
строка или неверный номер шрифта} Р := FontList;
(Переводим угол в радианы} Ang := Angle*pi/180;
for k := 1 to Font-1 do P := P^NextFont;
with P" do begin
if Name.FNameo'' then begin
Assign(F,Name.PName) ;
{$!-} Reset (F,1) ;
{$!+} if IQResultoO then
Exit; (Ошибка доступа к файлу/ end;
х0 := GetX; (Текущие координаты} у 0 := GetY;
for k := 1 to Length(S) do begin
с :- ord(S[k]> ;
if с in [FirstChr..LastChar] then if Name.FNameo'' then
begin (Берем шрифт из файла}
{$!-} Seek(F,Offs [с]) ;
BlockRead(E',Buf,Leng[c] ,j);
{$!+}
if (IOResult=0) and (Leng[c]-j) then OutChar(Buf) end
else (Шрифт загружен в память} with Name.Addrs do begin
PB := ptr(sa,oa+0ffs[c]);
OutCharfPB") end end;
MoveTo(xO,yO) ;
if Name. FNameo' ' then
Close(F) end end; {OutString} ^=,-,»=»-«=.-=; end. {F_Gc'rext} ("=-======»=»=/
