Program FontEditor;
{$G+,N+,E-,D-}
Uses Graph, CRT;
{$L C:\PROGRA~2\BP70\BIN\EGAVGA.OBJ}
{$L C:\PROGRA~2\BP70\FONTS\BMPHEAD.OBJ}
const
BMPHeadSize = 62;
HS: array [0..15] of Char = '0123456789ABCDEF';
LL = 1024;
OldInt1Ch : Pointer = NIL;
Xf1: Integer = 100;
Xf2: Integer = 390;
Yf1: Integer = 10;
Yf2: Integer = 450;
TbX : Word = 499;
TbY : Word = 9;
flag : Word = 0;
AdrIncr : Longint = $10000;
type
TFontLetter = array[0..LL-1] of Byte;
TFontBMP = array[0..495] of Byte;
var
ChArr : array [0..255] of Byte;
P : Pointer;
PLetter : ^TFontLetter;
Letter : Longint absolute PLetter;
LgPr : Longint absolute P;
FontSize, LFSz : Longint;
D, R, e, IOR : Integer;
i, j, k, X, Y : Integer;
FntOffset : LongInt;
PrevMouse : Word;
f, fBMP : file;
S, S1, BMPname : String;
LetterHeight, LetterWidth, NLetters, Col : Byte;
Leave, WasEdited, Hex : Boolean;
CCC : Char;
Procedure EGAVGA; External;
Procedure BMPHEAD; External;
{C:\PROGRA~2\BP70\FONTS\normal.fnt}
Procedure WaitRetrace;Assembler;
asm
mov dx, 03DAh
@VRTL1:
in al, dx
test al, 8
jnz @VRTL1
@VRTL2:
in al, dx
test al, 8
jnz @VRTL2
ret
end;
Procedure InitMouse; Assembler;
asm
mov ax, 0
int 33h
end;
Procedure ShowMouse; Assembler;
asm
mov ax, 1
int 33h
end;
Procedure HideMouse; Assembler;
asm
mov ax, 2
int 33h
end;
Function MouseButt : Word; Assembler;
asm
mov ax, 3
int 33h
mov ax, bx
end;
Function MouseX : Word; Assembler;
asm
mov ax, 3
int 33h
mov ax, cx
end;
Function MouseY : Word; Assembler;
asm
mov ax, 3
int 33h
mov ax, dx
end;
Procedure MouseGotoXY(X, Y : Integer); Assembler;
asm
mov ax, 4
mov cx, word ptr X
mov dx, word ptr Y
int 33h
end;
Function MouseIn(X1,Y1,X2,Y2: Integer): Boolean;
begin
MouseIn := (MouseX > X1) and (MouseX < X2) and (MouseY > Y1) and (MouseY < Y2)
end; {MouseIn}
Function HexW(X: Word; Bl : Boolean): String;
var
S: String;
k: Byte;
begin
S := '';
for k := 3 downto 0 do
S := S+HS[(X shr (k*4)) and 15];
if not Bl then
While (S[1] = '0') and (Length(S)<>0) do
Delete(S, 1, 1);
HexW := S
end; {HexW}
Procedure SetInt1Ch; Assembler;
asm
push es
mov ax, 351Ch
int 21h
mov word ptr OldInt1Ch, bx
mov word ptr OldInt1Ch+2, es
mov word ptr @OI1Ch, bx
mov word ptr @OI1Ch+2, es
pop es
mov ax, 251Ch
push ds
mov dx, seg @int1Ch
mov ds, dx
mov dx, offset @int1Ch
int 21h
pop ds
ret
@int1Ch:
pushf
push ds
push ax
mov ax, seg flag
mov ds, ax
inc word ptr flag
pop ax
pop ds
popf
db 02Eh, 0EAh {cs:jmp 00000000}
@OI1Ch :
dd 0
{ iret}
end;
Procedure RestoreInt1Ch; Assembler;
asm
push ds
lds dx, OldInt1Ch
mov ax, 251Ch
int 21h
pop ds
end;
Procedure ReadBMP;
var
PBMP, PFONT : ^TFontBMP;
i : Word;
begin
Hex := True;
BMPname := S;
S := 'noname.fnt';
Delete(BMPname, 1, 5);
if P <> NIL then FreeMem(P, FontSize);
fontSize := 4096;
GetMem(P, 4096);
PFONT := P;
GetMem(PBMP, 4096);
Assign(fBMP, BMPname);
Reset(fBMP, 1);
Seek(fBMP, 62);
BlockRead(fBMP, PBMP^, 4096);
Close(fBMP);
for i := 0 to 4095 do
PFONT^[i] := PBMP^[(i and $0F) shl 4 + (i and $F0) shr 4 + i and $F00];
FreeMem(PBMP, 4096);
end;
Procedure ReadBMPX;
var
PBMP, PFONT : ^TFontBMP;
i : Word;
begin
Hex := True;
BMPname := S;
S := 'noname.fnt';
Delete(BMPname, 1, 5);
if P <> NIL then FreeMem(P, FontSize);
fontSize := 4096;
GetMem(P, 4096);
PFONT := P;
Assign(fBMP, BMPname);
Reset(fBMP, 1);
Seek(fBMP, 62);
BlockRead(fBMP, PFONT^, 4096);
Close(fBMP);
end;
Procedure WriteBMP_Image;
var
PBMP, PFONT : ^TFontBMP;
i : Word;
begin
BMPname := S;
if Pos('.', BMPname)<>0 then Delete(BMPname, Pos('.', BMPname), Length(BMPname)+1-Pos('.', BMPname));
BMPname := BMPname+'.bmp';
PFONT := P;
GetMem(PBMP, 4096);
for i := 0 to 4095 do
PBMP^[i] := PFONT^[(i and $0F) shl 4 + (i and $F0) shr 4 + i and $F00];
Assign(fBMP, BMPname);
ReWrite(fBMP, 1);
PFONT := @BMPHead;
BlockWrite(fBMP, PFONT^, 62);
BlockWrite(fBMP, PBMP^, 4096);
Close(fBMP);
FreeMem(PBMP, 4096);
end;
Procedure WriteBMP_Font;
var
PBMP, PFONT : ^TFontBMP;
i : Word;
begin
BMPname := S;
if Pos('.', BMPname)<>0 then Delete(BMPname, Pos('.', BMPname)-1, Length(BMPname)+2-Pos('.', BMPname));
BMPname := BMPname+'@.bmp';
PBMP := @BMPHead;
Assign(fBMP, BMPname);
ReWrite(fBMP, 1);
BlockWrite(fBMP, PBMP^, 62);
PBMP := P;
BlockWrite(fBMP, PBMP^, 4096);
Close(fBMP);
end;
Procedure TableFont;
begin
PLetter := P;
Letter := Letter + FntOffset;
LetterHeight := FontSize div (NLetters+1);
TbX := 627-LetterWidth*16;
x := 0;
y := 0;
HideMouse;
SetFillStyle(1, Green);
{ WaitRetrace;}
Bar(TbX, TbY, TbX+LetterWidth*16+1, TbY+LetterHeight*16+1);
for i := 0 to NLetters do
begin
for j := 0 to LetterHeight - 1 do
begin
for k := 0 to LetterWidth-1 do
begin
Col := (PLetter^[j] and ($80 shr k));
if Col <> 0 then Col := Yellow;
x := k+(i and $0F)*LetterWidth;
y := j + (i shr 4)*LetterHeight;
PutPixel(x+TbX+1, y+TbY+1, Col);
end;
end;
inc(Letter, LetterHeight);
end;
ShowMouse;
end;
Procedure DrawWorkField;
var
i : Integer;
begin
HideMouse;
SetColor(LightRed);
MoveTo(Xf1, Yf1);
LineTo(Xf2, Yf1);
LineTo(Xf2, Yf2);
LineTo(Xf1, Yf2);
LineTo(Xf1, Yf1);
SetColor(LightGray);
for i := 1 to LetterWidth-1 do
Line(Xf1+i*(Xf2-Xf1) div LetterWidth, Yf1, Xf1+i*(Xf2-Xf1) div LetterWidth, Yf2);
for i := 1 to LetterHeight-1 do
Line(Xf1, Yf1+i*(Yf2-Yf1) div LetterHeight, Xf2, Yf1+i*(Yf2-Yf1) div LetterHeight);
SetFillStyle(1, LightCyan);
WaitRetrace;
Bar(Xf1-4, Yf1-4, Xf1, Yf1);
Bar(Xf2, Yf2, Xf2+4, Yf2+4);
Bar((Xf1+Xf2) div 2 - 2, Yf1-4, (Xf1+Xf2) div 2 + 2, Yf1);
ShowMouse;
end;
Function FontRead : Boolean;
begin
Assign(f, S);
{$I-}
Reset(f, 1);
IOR := IOResult;
{$I+}
if IOR <> 0 then
begin
FontRead := False;
Exit;
end;
if P <> NIL then FreeMem(P, LFSz);
LFSz := FileSize(f);
FontSize := LFSz;
Seek(f, 0);
GetMem(P, LFSz);
BlockRead(f, P^, LFSz);
Close(f);
FontRead := True;
end;
Procedure FontWrite;
begin
PLetter := P;
Letter := Letter + FntOffset;
{$I-}
Assign(f, S);
ReWrite(f, 1);
{$I+}
Seek(f, 0);
BlockWrite(f, PLetter^, FontSize);
Close(f);
end;
Procedure LodSmb(Ch:Byte);
var
i : Integer;
begin
PLetter := P;
Letter := Letter + FntOffset;
inc(Letter, LetterHeight*Ch);
for i := 0 to LetterHeight-1 do
ChArr[i]:= PLetter^[i];
end;
Procedure StoSmb(Ch:Byte);
var
i : Integer;
begin
PLetter := P;
Letter := Letter + FntOffset;
inc(Letter, LetterHeight*Ch);
for i := 0 to LetterHeight-1 do
PLetter^[i]:=ChArr[i];
end;
Procedure FillField;
var
j, k : Integer;
begin
HideMouse;
WaitRetrace;
for j := 0 to LetterHeight - 1 do
begin
for k := 0 to LetterWidth-1 do
begin
Col := (ChArr[j] and ($80 shr k));
if Col <> 0 then
SetFillStyle(1, Blue)
else
SetFillStyle(1, Black);
Bar(k*(Xf2-Xf1) div LetterWidth+Xf1+1, j*(Yf2-Yf1) div LetterHeight+Yf1+1,
(k+1)*(Xf2-Xf1) div LetterWidth+Xf1-1, (j+1)*(Yf2-Yf1) div LetterHeight+Yf1-1);
end;
end;
for j := 0 to LetterHeight - 1 do
begin
for k := 0 to LetterWidth-1 do
begin
Col := (ChArr[j] and ($80 shr k));
if Col <> 0 then Col := White;
PutPixel(k+620, j+460, Col);
PutPixel(3*k+590, 3*j + 430, Col);
end;
end;
ShowMouse;
end;
Procedure ResizeField(Mode : Boolean);
var
X1old, Y1old, X2old, Y2old : Integer;
begin
X1old := Xf1;
X2old := Xf2;
Y1old := Yf1;
Y2old := Yf2;
SetColor(LightGray);
SetWriteMode(XORput);
HideMouse;
if Mode then
While MouseButt=1 do
begin
if (MouseX > Xf1+50) and (MouseX < TbX) then Xf2 := MouseX;
if (MouseY > Yf1+50) and (MouseY < 479) then Yf2 := MouseY;
MoveTo(Xf1, Yf1);
LineTo(Xf2, Yf1);
LineTo(Xf2, Yf2);
LineTo(Xf1, Yf2);
LineTo(Xf1, Yf1);
ShowMouse;
While (MouseX=Xf2) and (MouseY=Yf2) and (MouseButt=1) do;
HideMouse;
MoveTo(Xf1, Yf1);
LineTo(Xf2, Yf1);
LineTo(Xf2, Yf2);
LineTo(Xf1, Yf2);
LineTo(Xf1, Yf1);
end
else
While MouseButt=1 do
begin
if (MouseX < Xf2-50) and (MouseX > 0) then Xf1 := MouseX;
if (MouseY < Yf2-50) and (MouseY > 0) then Yf1 := MouseY;
MoveTo(Xf1, Yf1);
LineTo(Xf2, Yf1);
LineTo(Xf2, Yf2);
LineTo(Xf1, Yf2);
LineTo(Xf1, Yf1);
ShowMouse;
While (MouseX=Xf1) and (MouseY=Yf1) and (MouseButt=1) do;
HideMouse;
MoveTo(Xf1, Yf1);
LineTo(Xf2, Yf1);
LineTo(Xf2, Yf2);
LineTo(Xf1, Yf2);
LineTo(Xf1, Yf1);
end;
ShowMouse;
SetWriteMode(NormalPut);
if MouseButt <> 0 then
begin
Xf1:= X1old;
Xf2:= X2old;
Yf1:= Y1old;
Yf2:= Y2old;
end;
HideMouse;
ClearDevice;
ShowMouse;
TableFont;
DrawWorkField;
FillField;
end;
Procedure MoveField;
var
X1old, Y1old, X2old, Y2old, XX, dY, dX : Integer;
begin
dX := (Xf2-Xf1) div 2;
dY := Yf2-Yf1;
XX := (Xf2+Xf1) div 2;
X1old := Xf1;
X2old := Xf2;
Y1old := Yf1;
Y2old := Yf2;
SetColor(LightGray);
SetWriteMode(XORput);
HideMouse;
While MouseButt=1 do
begin
if ((MouseX-dx)>0) and ((MouseX+dx)0) and (MouseY+dY<479) then
begin
XX := MouseX;
Xf1 := XX - dx;
Xf2 := XX + dx;
Yf1 := MouseY;
Yf2 := MouseY + dY;
end;
MoveTo(Xf1, Yf1);
LineTo(Xf2, Yf1);
LineTo(Xf2, Yf2);
LineTo(Xf1, Yf2);
LineTo(Xf1, Yf1);
ShowMouse;
While (MouseX=XX) and (MouseY=Yf1) and (MouseButt=1) do;
HideMouse;
MoveTo(Xf1, Yf1);
LineTo(Xf2, Yf1);
LineTo(Xf2, Yf2);
LineTo(Xf1, Yf2);
LineTo(Xf1, Yf1);
end;
ShowMouse;
SetWriteMode(NormalPut);
if MouseButt <> 0 then
begin
Xf1:= X1old;
Xf2:= X2old;
Yf1:= Y1old;
Yf2:= Y2old;
end;
HideMouse;
ClearDevice;
ShowMouse;
TableFont;
DrawWorkField;
FillField;
end;
Procedure CheckResize;
begin
if (MouseX>=Xf2) and (MouseY>=Yf2) and (MouseXXf1-5) and (MouseY>Yf1-5) then
ResizeField(False);
if (MouseX<=(Xf1+Xf2) div 2 + 2) and (MouseX >= (Xf1+Xf2) div 2 - 2) and
(MouseY<=Yf1) and (MouseY>Yf1-5) then MoveField;
end;
Procedure FillCrate;
var
y, x : Byte;
begin
x := LetterWidth*(MouseX-Xf1) div (Xf2-Xf1);
y := LetterHeight*(MouseY-Yf1) div (Yf2-Yf1);
ChArr[y] := ChArr[y] or ($80 shr x);
FillField;
end;
Procedure ClearCrate;
begin
x := LetterWidth*(MouseX-Xf1) div (Xf2-Xf1);
y := LetterHeight*(MouseY-Yf1) div (Yf2-Yf1);
ChArr[y] := ChArr[y] and not ($80 shr x);
FillField;
end;
Procedure GetSimbol;
var
Ch : Byte;
begin
Ch := (((MouseX-TbX) - (MouseX-TbX) mod LetterWidth) div LetterWidth)+
16*((MouseY-TbY) - (MouseY-TbY) mod LetterHeight) div LetterHeight;
LodSmb(Ch);
FillField;
end;
Procedure PutSimbol;
var
Ch : Byte;
begin
Ch := (((MouseX-TbX) - (MouseX-TbX) mod LetterWidth) div LetterWidth)+
16*((MouseY-TbY) - (MouseY-TbY) mod LetterHeight) div LetterHeight;
StoSmb(Ch);
TableFont;
end;
Procedure SymInfo;
var
Xo, Yo : Integer;
Ch : Byte;
PPi : Pointer;
ImgSz : Longint;
Xl : Integer;
Sj : String[80];
begin
Xo := MouseX;
Yo := MouseY;
Ch := (((MouseX-TbX) - (MouseX-TbX) mod LetterWidth) div LetterWidth)+
16*((MouseY-TbY) - (MouseY-TbY) mod LetterHeight) div LetterHeight;
Str(Ch, Sj);
Sj := Sj + ' '+ HexW(Ch, False)+'h';
Xl := Length(Sj)*8+5;
SetFillStyle(1, DarkGray);
SetColor(LightCyan);
ImgSz := ImageSize(Xo-Xl, Yo, Xo, Yo-10);
if (MouseX=Xo) and (MouseY=Yo) and (MouseButt=0) and not KeyPressed
then
begin
WaitRetrace;
GetMem(PPi, ImgSz);
HideMouse;
GetImage(Xo-Xl, Yo, Xo, Yo-10, PPi^);
Bar(Xo-Xl, Yo, Xo, Yo-10);
OutTextXY(Xo-Xl+2, Yo-9, Sj);
ShowMouse;
While (MouseX=Xo) and (MouseY=Yo) and (MouseButt=0) and not KeyPressed do;
HideMouse;
PutImage(Xo-Xl, Yo-10, PPi^, NormalPut);
ShowMouse;
FreeMem(PPi, ImgSz);
flag := 0;
end;
end;
Procedure WaitMouse;
begin
While MouseButt <> 0 do;
end;
Function Yes(Mes : String) : Boolean;
const
MenuHeight: Integer = 100;
MenuWidth: Integer= 100;
var
C : Char;
begin
MenuHeight:= 100;
MenuWidth:= 150;
if Length(Mes)*8>MenuWidth then MenuWidth := Length(Mes)*8+10;
HideMouse;
SetFillStyle(1, LightRed);
WaitRetrace;
Bar(320-MenuWidth div 2, 240 - MenuHeight div 2, 320+MenuWidth div 2, 240 + MenuHeight div 2);
SetFillStyle(1, Red);
Bar(321-MenuWidth div 2, 241 - MenuHeight div 2, 319+MenuWidth div 2, 239 + MenuHeight div 2);
SetColor(LightGreen);
OutTextXY(320-MenuWidth div 2 + (MenuWidth-(Length(Mes)*8)) div 2, 268 - MenuHeight div 2, Mes);
SetFillStyle(1, LightRed);
Bar(265, 255, 295, 270);
Bar(345, 255, 375, 270);
OutTextXY( 272, 259, 'Да');
OutTextXY( 349, 259, 'Нет');
ShowMouse;
While True do
begin
if MouseButt = 1 then
if MouseIn(265, 255, 295, 270) then
begin
Yes := True;
WaitMouse;
Exit;
end;
if MouseButt = 1 then
if MouseIn(345, 255, 375, 270) then
begin
Yes := False;
WaitMouse;
Exit;
end;
if KeyPressed then
begin
C := ReadKey;
if C in [#27, 'Н', 'н', 'Y', 'y'] then
begin
Yes := False;
WaitMouse;
Exit;
end;
if C in [#13, 'Д', 'д', 'L', 'l'] then
begin
Yes := True;
WaitMouse;
Exit;
end;
end;
end;
end;
Procedure Clear;
var
i : Byte;
begin
for i := 0 to LetterHeight-1 do
ChArr[i] := 0;
end;
Procedure FillAll;{Заполнить}
var
i : Byte;
begin
for i := 0 to LetterHeight-1 do
ChArr[i] := $FF;
end;
Procedure Inverse;
var
i : Byte;
begin
for i := 0 to LetterHeight-1 do
ChArr[i] := not ChArr[i];
end;
Procedure ParBuild;
var
tmpS, Scq : String[80];
begin
HideMouse;
WaitRetrace;
SetFillStyle(1, Cyan);
Bar(110, 110, 530, 125);
OutTextXY(111, 114, S);
SetFillStyle(1, LightRed);
SetColor(Yellow);
{ WaitRetrace;}
Bar(290, 345, 350, 360);
OutTextXY(293, 348, 'Хорошо!');
SetColor(Blue);
OutTextXY(120, 160, 'Число символов в шрифте: ');
OutTextXY(120, 190, 'Высота символов: ');
OutTextXY(120, 220, 'Ширина символов: ');
OutTextXY(120, 250, 'Смещение шрифта: ');
OutTextXY(340, 280, 'Инкремент: ');
SetColor(LightBlue);
Str(LFSz, tmpS);
{WaitRetrace;}
OutTextXY(160, 290, 'Размер файла: '+tmpS+' байт');
Str(FontSize, tmpS);
SetFillStyle(1, LightGray);
Bar(280, 310, 328, 320);
OutTextXY(160, 310, 'Размер шрифта: '+tmpS+' байт');
tmpS := HexW(Ofs(PLetter^), True)+'h';
Scq := HexW(Seg(PLetter^), True)+'h:';
OutTextXY(160, 330, 'Смещение указателя: '+Scq+tmpS);
SetFillStyle(1, Cyan);
SetColor(Magenta);
Str(NLetters+1, tmpS);
Bar(320, 155, 370, 175);
OutTextXY( 321, 160, tmpS);
Str(LetterHeight, tmpS);
Bar(320, 185, 370, 205);
OutTextXY( 321, 190, tmpS);
Str(LetterWidth, tmpS);
Bar(320, 215, 370, 235);
OutTextXY( 321, 220, tmpS);
if Hex then tmpS := HexW(AdrIncr shr 16, False) + HexW(AdrIncr and $FFFF, True)
else Str(AdrIncr, tmpS);
Bar(425, 275, 515, 295);
OutTextXY( 430, 280, tmpS);
if Hex then tmpS := HexW(FntOffset shr 16, False) + HexW(FntOffset and $FFFF, True)
else Str(FntOffset, tmpS);
{WaitRetrace;}
Bar(320, 245, 410, 265);
OutTextXY(321, 250, tmpS);
SetColor(Red);
OutTextXY(440, 252, 'HEX');
Bar(470, 250, 480, 260);
if Hex then
begin
SetColor(Black);
Line(471, 251, 479, 259);
Line(471, 259, 479, 251);
SetColor(LightGreen);
Circle(475, 255, 3);
Circle(475, 255, 2);
Circle(475, 255, 1);
PutPixel(475, 255, LightGreen)
end;
SetFillStyle(1, Blue);
{WaitRetrace;}
Bar(371, 155, 389, 175);
Bar(371, 185, 389, 205);
Bar(371, 215, 389, 235);
Bar(411, 245, 429, 265);
SetColor(LightCyan);
OutTextXY( 373, 160, ' ');
OutTextXY( 373, 190, ' ');
OutTextXY( 373, 220, ' ');
OutTextXY( 413, 250, ' ');
ShowMouse;
end;
Procedure NewValue(x1, y1, x2, y2 : Word;var Vl : LongInt);
var
tmpS : String;
C : Char;
OldVal : Longint;
Code : Integer;
begin
WasEdited := True;
OldVal := Vl;
if Hex then tmpS := HexW(Vl shr 16, False) + HexW(Vl and $FFFF, True)
else Str(Vl, tmpS);
SetColor(LightMagenta);
SetFillStyle(1, Cyan);
HideMouse;
Repeat
Bar(x1, y1, x2, y2);
OutTextXY(x1+1, y1+5, tmpS);
C := ReadKey;
case C of
'-' : if Length(tmpS)=0 then tmpS := '-';
'0'..'9' : begin
if not Hex then
begin
if tmpS[1] <> '-' then
if Length(tmpS)<10 then tmpS := tmpS + C;
if tmpS[1] = '-' then
if Length(tmpS)<11 then tmpS := tmpS + C;
end;
if Hex then
begin
if tmpS[1] <> '-' then
if Length(tmpS)<8 then tmpS := tmpS + C;
if tmpS[1] = '-' then
if Length(tmpS)<9 then tmpS := tmpS + C;
end;
end;
'a'..'f','A'..'F' : if Hex then
begin
if tmpS[1] <> '-' then
if Length(tmpS)<8 then tmpS := tmpS + UpCase(C);
if tmpS[1] = '-' then
if Length(tmpS)<9 then tmpS := tmpS + UpCase(C);
end;
#8 : if Length(tmpS)>0 then tmpS[0] := Chr(Length(tmpS)-1);
end;
Until (C = #27) or (C = #13);
if C = #27 then
Vl := OldVal
else
begin
if Hex then
begin
if tmpS[1] = '-' then
begin
Delete(tmpS, 1, 1);
tmpS := '-$' + tmpS;
end
else tmpS := '$'+tmpS;
end;
Val(tmpS, Vl, Code);
end;
if Hex then tmpS := HexW(Vl shr 16, False) + HexW(Vl and $FFFF, True)
else Str(Vl, tmpS);
SetColor(Magenta);
Bar(x1, y1, x2, y2);
OutTextXY(x1+1, y1+5, tmpS);
ShowMouse;
end;
Procedure NewValueByte(x1, y1, x2, y2 : Word;var Vl : Byte; Fg : Boolean);
var
tmpS : String;
Code : Word;
C : Char;
OldVal : Byte;
NewVal : Word;
begin
WasEdited := True;
OldVal := Vl;
if Fg then
Str(Vl+1, tmpS)
else
Str(Vl, tmpS);
SetColor(LightMagenta);
SetFillStyle(1, Cyan);
HideMouse;
Repeat
Bar(x1, y1, x2, y2);
OutTextXY(x1+1, y1+5, tmpS);
C := ReadKey;
case C of
'-' : if Length(tmpS)=0 then tmpS := '-';
'0'..'9' : if Length(tmpS)<3 then tmpS := tmpS + C;
#8 : if Length(tmpS)>0 then tmpS[0] := Chr(Length(tmpS)-1);
end;
Until (C = #27) or (C = #13);
if C = #27 then
Vl := OldVal
else
begin
if Fg then
begin
Val(tmpS, NewVal, Code);
if Vl <> 0 then
dec(NewVal);
end
else Val(tmpS, NewVal, Code);
Vl := NewVal;
end;
if Fg then
Str(Vl+1, tmpS)
else
Str(Vl, tmpS);
SetColor(Magenta);
Bar(x1, y1, x2, y2);
OutTextXY(x1+1, y1+5, tmpS);
ShowMouse;
end;
Procedure Paramet;
var
tmpS : String[80];
C : Char;
NltOld, LHold, LWold : Byte;
begin
HideMouse;
SetFillStyle(1, DarkGray);
Bar(99, 99, 541, 381);
SetFillStyle(1, LightGray);
Bar(100, 100, 540, 380);
ShowMouse;
SetColor(LightGreen);
NltOld := NLetters;
LHold := LetterHeight;
LWold := LetterWidth;
ParBuild;
While True do
begin
if MouseButt = 1 then
begin
if MouseIn(290, 345, 350, 360) then Break;
if MouseIn(470, 250, 480, 260) then Hex := not Hex;
if MouseIn(370, 155, 380, 175) then inc(NLetters);
if MouseIn(370, 185, 380, 205) then inc(LetterHeight);
if MouseIn(370, 215, 380, 235) then inc(LetterWidth);
if MouseIn(410, 245, 420, 265) then inc(FntOffset);
if MouseIn(380, 155, 390, 175) then dec(NLetters);
if MouseIn(380, 185, 390, 205) then dec(LetterHeight);
if MouseIn(380, 215, 390, 235) then dec(LetterWidth);
if MouseIn(420, 245, 430, 265) then dec(FntOffset);
if MouseIn(320, 155, 370, 175) then
NewValueByte(320, 155, 370, 175, NLetters, True);
if MouseIn(320, 185, 370, 205) then
if not WasEdited then
NewValueByte(320, 185, 370, 205, LetterHeight, False);
if MouseIn(320, 215, 370, 235) then
if not WasEdited then
NewValueByte(320, 215, 370, 235, LetterWidth, False);
if MouseIn(320, 245, 410, 265) then
if not WasEdited then
NewValue(320, 245, 410, 265, FntOffset);
if MouseIn(425, 275, 515, 295) then
if not WasEdited then
NewValue(425, 275, 515, 295, AdrIncr);
if MouseIn(110, 110, 530, 125) then
if not WasEdited then
begin
SetColor(LightBlue);
tmpS := S;
While MouseButt <> 0 do;
HideMouse;
Repeat
SetFillStyle(1, Cyan);
WaitRetrace;
Bar(110, 110, 530, 125);
OutTextXY(111, 114, S);
C := ReadKey;
if C = #0 then ReadKey;
if C = #8 then Delete(S, Length(S), 1)
else if C in [' '..'ё'] then S := S+C;
Until (C=#27) or (C=#13) or (MouseButt<>0);
ShowMouse;
if C=#27 then S := tmpS;
end;
While MouseButt <> 0 do;
WasEdited := False;
FontSize := (NLetters+1)*LetterHeight;
SetColor(LightGreen);
ParBuild;
if KeyPressed then if ReadKey=#27 then Break;
end;
if KeyPressed then
begin
case ReadKey of
#27:
begin
NLetters := NltOld;
LetterHeight := LHold;
LetterWidth := LWold;
Break;
end;
#13: Break;
end;
end;
end;{While True...}
FontSize := (NLetters+1)*LetterHeight;
end;
Procedure NewField;{Новый}
var
i : Integer;
begin
FreeMem(P, LFSz);
LetterHeight := 16;
LetterWidth := 8;
NLetters := 255;
S := 'noname.fnt';
Paramet;
LFSz := FontSize;
GetMem(P, LFSz);
While MouseButt<>0 do;
if Yes('Заполнить символы (Да) или оставить пустыми (Нет)?')
then FillAll
else Clear;
for i := 0 to NLetters do
begin
StoSmb(i);
end;
end;
Procedure LoadNew;
begin
Paramet;
if not FontRead then if Yes('Файл не найден. Создать новый?') then NewField
else Leave := True;
end;
Procedure SaveAs;
begin
Paramet;
FontWrite;
end;
Procedure HorizMir;
var
i, Smb : Byte;
begin
for i := 0 to LetterHeight div 2-1 do
begin
Smb := ChArr[i];
ChArr[i] := ChArr[LetterHeight - i - 1];
ChArr[LetterHeight - i - 1] := Smb;
end;
end;
Procedure VertMir;
var
i, Smb : Byte;
begin
for i := 0 to LetterHeight - 1 do
begin
Smb := ChArr[i];
asm
mov al, byte ptr Smb
xor cx, cx
mov cl, byte ptr LetterWidth
@lb:
rcr al, 1
rcl bl, 1
loop @lb
mov byte ptr Smb, bl
end;
ChArr[i] := Smb;
end;
end;
Procedure HorizMirAll;
var
i : Word;
begin
for i := 0 to NLetters do
begin
LodSmb(i);
HorizMir;
StoSmb(i);
end;
end;
Procedure VertMirAll;
var
i : Word;
begin
for i := 0 to NLetters do
begin
LodSmb(i);
VertMir;
StoSmb(i);
end;
end;
Procedure InverseAll;
var
i, j : Byte;
begin
for j := 0 to NLetters do
begin
LodSmb(j);
for i := 0 to LetterHeight-1 do
ChArr[i] := not ChArr[i];
StoSmb(j);
end;
end;
Procedure Menu;
{Меню : очистить, сохранить, сохранить как, заполнить, <откатка>
загрузить, новый, параметры[ширина, высота, число символов], выход}
const
MenuHeight: Integer = 200;
MenuWidth: Integer= 200;
d = 20;
NS = 9;
List : array [1..NS] of String[80]=
('Новый',
'Загрузить',
'Сохранить',
'Сохранить как...',
'Очистить',
'Заполнить',
'Инверсия/перевёртывание',
'Параметры',
'Выход'
);
var
OldSz : Longint;
NSz : LongInt;
X, Y, i : Integer;
begin
MenuHeight:= 200;
MenuWidth:= 200;
if Length(S)*8>MenuWidth then MenuWidth := Length(S)*8+10;
While MouseButt=2 do;
While MouseButt<>0 do;
X := MouseX;
if MouseX+MenuWidth>639 then
X := 639-MenuWidth;
Y := MouseY;
if MouseY+MenuHeight>479 then
Y := 479-MenuHeight;
HideMouse;
SetFillStyle(1, LightGray);
WaitRetrace;
Bar(X, Y, X + MenuWidth, Y + MenuHeight);
SetFillStyle(1, DarkGray);
Bar(X+1, Y+1, X + MenuWidth-1, Y + MenuHeight-1);
SetColor(LightGray);
OutTextXY(X+3, Y+3, S);
SetColor(Brown);
for i := 1 to NS do
OutTextXY(X+3, Y+10+d*i, List[i]);
ShowMouse;
While not Leave do
begin
if not ((MouseX<=X+MenuWidth) and (MouseX>=X)) then
if (MouseX> X + MenuWidth) then MouseGotoXY(X + MenuWidth, MouseY)
else MouseGotoXY(X, MouseY);
if not ((MouseY<=Y+MenuHeight) and (MouseY>=Y)) then
if (MouseY> Y + MenuHeight) then MouseGotoXY(MouseX, Y+MenuHeight)
else MouseGotoXY(MouseX, Y);
if (MouseButt=1) or KeyPressed then
begin
if MouseIn(X, Y+10+d*1, X+MenuWidth, Y+9+d*2) then
begin
if Yes('Хотите открыть НОВЫЙ файл?') then
NewField;
Break;
end;
if MouseIn(X, Y+10+d*2, X+MenuWidth, Y+9+d*3) then
begin
if Yes('Вставить шрифт?') then
begin
S1 := S;
S := '';
Paramet;
Assign(f, S);
S := S1;
{$I-}
Reset(f, 1);
{$I+}
IOR := IOResult;
if IOR <> 0 then
begin
Str(IOR, S1);
Yes('Ошибка : '+S1);
Break;
end;
NSz := FileSize(f);
Seek(f, 0);
PLetter := P;
Letter := Letter + FntOffset;
if NSz=FontSize then BlockRead(f, PLetter^, FontSize)
else
if Yes('Размер файла отличается от размера окна. Загрузить?') then
BlockRead(f, PLetter^, NSz)
else
if Yes('Может, прочитать из файла начало?') then
begin
if FontSize grOk then
begin
WriteLn('Произошла ошибка графики!!!');
WriteLn(GraphErrorMsg(e));
end;
P := NIL;
InitMouse;
SetInt1Ch;
ShowMouse;
if S = '/MEMO' then
begin
Hex := True;
if not Yes('Режим редактирования шрифтов в памяти') then
begin
RestoreInt1Ch;
HideMouse;
CloseGraph;
Halt(1);
end;
end;
if S[1]+S[2]+S[3]+S[4]+S[5] = '/BMP:' then ReadBMP;
if S[1]+S[2]+S[3]+S[4]+S[5] = '/BMX:' then ReadBMPX;
if not Hex then
if not FontRead then
begin
RestoreInt1Ch;
HideMouse;
CloseGraph;
WriteLn('Ошибка открытия файла, '+S+' IOError = ', IOR);
Halt(IOR);
end;
WasEdited := False;
NLetters := 255;
LetterWidth := 8;
if Hex then
begin
LFSz := 0;
FontSize := 4096;
end;
HideMouse;
ClearDevice;
ShowMouse;
TableFont;
DrawWorkField;
LodSmb(0);
FillField;
While True do
begin
if (MouseButt<>2) and (MouseButt <> 1) then
begin
PrevMouse := MouseButt;
if MouseIn(TbX, TbY, TbX+LetterWidth*16+1, TbY+LetterHeight*16+1) then
if flag > $10 then
SymInfo;
end;
if MouseButt=1 then
begin
if PrevMouse <> 1 then
CheckResize;
if MouseIn(Xf1, Yf1, Xf2, Yf2) then
begin
FillCrate;
PrevMouse := 1;
end;
if MouseIn(TbX, TbY, TbX+LetterWidth*16+1, TbY+LetterHeight*16+1) then
PutSimbol;
end;
if MouseButt=2 then
if MouseIn(Xf1, Yf1, Xf2, Yf2) then
begin
ClearCrate;
PrevMouse := 2;
end
else
if MouseIn(TbX, TbY, TbX+LetterWidth*16+1, TbY+LetterHeight*16+1) then
begin
GetSimbol;
PrevMouse := 2;
end
else if PrevMouse <> 2 then Menu;
if Leave then Break;
if KeyPressed then
begin
CCC := ReadKey;
case CCC of
{Исп.: F1 F2 F3 F4 F5 F6 F7 F8}
{Sh+F2, Sh+F4}
#0 : case ReadKey of
#68{F10}: if Yes ('Выйти хотите?') then Break;
#59{F1}: Paramet;
#60{F2}:
if Yes('Вы уверены, что хотите сохранить файл '+ S +'?')
then
begin
OSz := FontSize;
FontSize := LFSz;
FontWrite;
FontSize := OSz;
end;
#85{Shift+F2}: if Yes('Сохранить как?') then
SaveAs;
#61{F3}:if Yes('Загрузить файл с диска?') then
LoadNew;
#72, #80{Стрелки U, D}: HorizMir;
#75, #77{Стрелки L, R}: VertMir;
#66{F8}: if Yes('Хотите открыть НОВЫЙ файл?') then
NewField;
#63{F5}:if Yes('Перевернуть весь шрифт?') then HorizMirAll;
#64{F6}:if Yes('Или развернуть относительно верткальной оси?') then VertMirAll;
#65{F7}:if Yes('Хотите ли вы инвертировать весь шрифт? ') then InverseAll;
#62{F4}:if Yes('Вы хотите создать BMP-образ шрифта?') then WriteBMP_Image;
#87{Shift+F4}:if Yes('Вы хотите записать шрифт внутрь BMP?') then WriteBMP_Font;
end;
'*' : Inverse;
'=', '+': FntOffset := FntOffset + AdrIncr;
'-' : FntOffset := FntOffset - AdrIncr;
#27: if Yes ('Выйти хотите?') then Break;
end;
begin
HideMouse;
ClearDevice;
ShowMouse;
TableFont;
DrawWorkField;
FillField;
end;
end;
end;
{ for i := 0 to 255 do
begin
LodSmb(i);
FillField;
Delay(100);
if KeyPressed then if ReadKey =#27 then Break;
end;}
RestoreInt1Ch;
HideMouse;
if P <> NIL then
FreeMem(P, LFSz);
CloseGraph;
end.
< -->