home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
h
/
htmix20.zip
/
FE.ZIP
/
FE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-07-14
|
28KB
|
806 lines
program FontEditor;
{┌──────────────────────────────── INFO ────────────────────────────────────┐}
{│ File : FE.PAS │}
{│ Author : Harald Thunem │}
{│ Purpose : Edit fonts in text mode VGA. │}
{│ Updated : July 10 1992 │}
{└──────────────────────────────────────────────────────────────────────────┘}
{────────────────────────── Compiler directives ─────────────────────────────}
{$A+ Word align data }
{$B- Short-circuit Boolean expression evaluation }
{$E- Disable linking with 8087-emulating run-time library }
{$G+ Enable 80286 code generation }
{$R- Disable generation of range-checking code }
{$S- Disable generation of stack-overflow checking code }
{$V- String variable checking }
{$X- Disable Turbo Pascal's extended syntax }
{$N+ 80x87 code generation }
{$D- Disable generation of debug information }
{────────────────────────────────────────────────────────────────────────────}
uses Dos,
Screen,
FEUnit,
Strings,
Keyboard;
const PowerList : array[1..8] of byte = (128,64,32,16,8,4,2,1);
MainBAttr = White+BlueBG;
TopAttr = White+CyanBG;
BottomAttr1 = Yellow+CyanBG;
BottomAttr2 = White+CyanBG;
CharRow = 5; { Char box Row (upper left) }
CharCol = 4; { Char box Column }
CharRows = 18; { Char box Row number }
CharCols = 35; { Char box Column number }
CharAttrBo = White+LightGrayBG; { Char box Border attr }
CharAttrBoH = Red+LightWhiteBG; { Char box Border attr }
CharAttrNo = White+CyanBG; { Char box Normal attr }
CharAttrHiNo= White+RedBG; { Char box Highlighted normal }
CharAttrHiSe= White+LightRedBG; { Char box Highlighted selected }
CharAttrSe = White+LightWhiteBG; { Char box Selected attr }
ChartRow = 5; { Chart box Row (upper left) }
ChartCol = 43; { Chart box Column }
ChartRows = 10; { Chart box Row number }
ChartCols = 34; { Chart box Column number }
ChartAttrBo = White+LightGrayBG; { Chart box Border attr }
ChartAttrBoH= Red+LightWhiteBG; { Chart box Highlight Border }
ChartAttrNo = White+CyanBG; { Chart box Normal attr }
ChartAttrHi = Yellow+LightRedBG; { Chart box Highlighted attr }
ChartAttrSe = White+RedBG; { Chart box Selected attr }
var Filename : string;
CurrentPath : string;
procedure SaveFontFile(FontFileName: string);
begin
Assign(FontFile,FontFileName);
ReWrite(FontFile);
Write(FontFile,Font);
Close(FontFile);
end;
function HexStr(b: byte): string;
var bl: array[1..2] of byte;
i: byte;
s: string;
begin
s := '$';
bl[1] := b shr 4; { High 4 bits }
bl[2] := b and $0F; { Low 4 bits }
for i := 1 to 2 do
if bl[i]<10 then
s := s + Chr(bl[i]+48)
else s := s + Chr(bl[i]+65-10);
HexStr := s;
end;
procedure Savefile(var Filename: string);
const SaveAttr = White+GreenBG;
TopAttr = Green+LightWhiteBG;
FileAttr = Yellow+BlackBG;
var L : byte;
Size : integer;
Scr : pointer;
begin
L := 30;
Size := 2*5*L;
GetMem(Scr,Size);
StoreToMem(11,25,5,L,Scr^);
Box(11,25,4,L-2,SaveAttr,NoBorder,' ');
AddShadow(11,25,4,L-2);
Fill(11,25,1,L-2,TopAttr,' ');
WriteStr(11,33,TopAttr,'Save file');
WriteStr(13,27,SaveAttr,'Save to : ');
InputString(Filename,13,37,12,FileAttr,[Escape,Return]);
StoreToScr(11,25,5,L,Scr^);
FreeMem(Scr,Size);
if Key=Return then
SaveFontFile(CurrentPath+Filename);
Key := NullKey;
end;
procedure Help;
const HelpAttr = White+GreenBG;
TopAttr = Green+LightWhiteBG;
CommAttr = LightCyan+GreenBG;
HRow = 3;
HCol = 17;
HRows = 21;
HCols = 48;
var
Size : integer;
Scr : pointer;
begin
Size := 2*HRows*HCols;
GetMem(Scr,Size);
StoreToMem(HRow,HCol,HRows,HCols,Scr^);
Box(HRow,HCol,HRows-1,HCols-2,HelpAttr,NoBorder,' ');
AddShadow(HRow,HCol,HRows-1,HCols-2);
Fill(HRow,HCol,1,HCols-2,TopAttr,' ');
WriteC(HRow,HCol+(HCols div 2)-1,TopAttr,'Help');
Fill(HRow,HCol,HRows-1,1,HelpAttr,'█');
Fill(HRow,HCol+HCols-3,HRows-1,1,HelpAttr,'█');
Fill(HRow+HRows-2,HCol+1,1,HCols-4,HelpAttr,'▄');
WriteStr(HRow+2,HCol+2,CommAttr,'Commands');
WriteStr(HRow+3,HCol+4,CommAttr,'F1 ');
WriteEos(HelpAttr,'- This help screen');
WriteStr(HRow+4,HCol+4,CommAttr,'F2 ');
WriteEos(HelpAttr,'- Save current font to file');
WriteStr(HRow+5,HCol+4,CommAttr,'F3 ');
WriteEos(HelpAttr,'- Load a new font from file');
WriteStr(HRow+6,HCol+4,CommAttr,'Space');
WriteEos(HelpAttr,'- Toggle character bit');
WriteStr(HRow+7,HCol+4,CommAttr,'Tab ');
WriteEos(HelpAttr,'- Switch between character editing');
WriteStr(HRow+8,HCol+4,HelpAttr,' and character selection');
WriteStr(HRow+9,HCol+4,CommAttr,'AltF ');
WriteEos(HelpAttr,'- Fill with movement');
WriteStr(HRow+10,HCol+4,CommAttr,'AltE ');
WriteEos(HelpAttr,'- Erase with movement');
WriteStr(HRow+11,HCol+4,CommAttr,'AltN ');
WriteEos(HelpAttr,'- Normal movement');
WriteStr(HRow+12,HCol+4,CommAttr,'Esc ');
WriteEos(HelpAttr,'- Quit');
WriteStr(HRow+14,HCol+4,HelpAttr,' Read the FE.DOC file for a more');
WriteStr(HRow+15,HCol+4,HelpAttr,'detailed description of the available');
WriteStr(HRow+16,HCol+4,HelpAttr,'commands.');
WriteStr(HRow+17,HCol+20,Blue+LightWhiteBG,#16+' OK '+#17);
WriteStr(HRow+17,HCol+26,HelpAttr and $F0,'▄');
WriteStr(HRow+18,HCol+21,HelpAttr and $F0,'▀▀▀▀▀▀');
repeat
InKey(Ch,Key);
until Key in [Escape,Return];
StoreToScr(HRow,HCol,HRows,HCols,Scr^);
FreeMem(Scr,Size);
Key := NullKey;
end;
procedure About;
const ARow = 7;
ACol = 13;
ARows = 10;
ACols = 54;
var A,i,j: byte;
begin
Fill(1,1,25,80,White+BlueBG,'▒');
Fill(ARow,ACol,ARows,ACols,White+LightBlackBG,' ');
AddShadow(ARow,ACol,ARows,ACols);
Fill(ARow,ACol,1,ACols,Green+LightWhiteBG,' ');
WriteC(ARow,ACol+(ACols div 2),SameAttr,'About');
{ Blue }
Fill(ARow+1,ACol,ARows-1,3,White+LightBlueBG,' ');
Fill(ARow+1,ACol+ACols-3,ARows-1,3,White+LightBlueBG,' ');
{ Green }
Fill(ARow+1,ACol+3,ARows-1,3,White+LightGreenBG,' ');
Fill(ARow+1,ACol+ACols-6,ARows-1,3,White+LightGreenBG,' ');
{ Cyan }
Fill(ARow+1,ACol+6,ARows-1,3,White+LightCyanBG,' ');
Fill(ARow+1,ACol+ACols-9,ARows-1,3,White+LightCyanBG,' ');
{ Red }
Fill(ARow+1,ACol+9,ARows-1,3,White+LightRedBG,' ');
Fill(ARow+1,ACol+ACols-12,ARows-1,3,White+LightRedBG,' ');
{ Magenta }
Fill(ARow+1,ACol+12,ARows-1,3,White+LightMagentaBG,' ');
Fill(ARow+1,ACol+ACols-15,ARows-1,3,White+LightMagentaBG,' ');
{ Change middle attribute }
for i := (ARow+4) to (ARow+6) do
for j := ACol to (ACol+ACols-1) do
begin
A := ReadAttr(i,j);
A := A and $7F;
Attr(i,j,1,1,A);
end;
{ Text }
WriteC(ARow+4,ACol+(ACols div 2),SameAttr,'Font Editor 2.0');
WriteC(ARow+5,ACol+(ACols div 2),SameAttr,'by');
WriteC(ARow+6,ACol+(ACols div 2),SameAttr,'Harald Thunem');
Inkey(Ch,Key);
Key := NullKey;
end;
function Confirm(Msg: string; Select: boolean): boolean;
const MessageAttr = White+RedBG;
TopAttr = Green+LightWhiteBG;
var L : byte;
Size : integer;
Scr : pointer;
begin
if Pos('?',Msg)<=0 then Msg := Msg + ' ?';
L := 4+(Length(Msg) div 2);
Size := 2*7*(2*L+2);
GetMem(Scr,Size);
StoreToMem(11,8,7,60,Scr^);
Box(11,40-L,6,2*L,MessageAttr,NoBorder,' ');
AddShadow(11,40-L,6,2*L);
Fill(11,40-L,1,2*L,TopAttr,' ');
WriteC(11,40,TopAttr,'Confirm');
WriteC(13,40,MessageAttr,Msg);
if Select then
WriteStr(15,30,Blue+LightWhiteBG,#16+' Yes '+#17)
else WriteStr(15,30,Blue+LightGrayBG,' Yes ');
WriteStr(16,31,Black+RedBG,'▀▀▀▀▀▀▀');
WriteStr(15,37,Black+RedBG,'▄');
if Select then
WriteStr(15,43,Blue+LightGrayBG,' No ')
else WriteStr(15,43,Blue+LightWhiteBG,#16+' No '+#17);
WriteStr(16,44,Black+RedBG,'▀▀▀▀▀▀▀');
WriteStr(15,50,Black+RedBG,'▄');
repeat
InKey(Ch,Key);
Ch := Upcase(Ch);
WriteStr(15,30,Blue+LightGrayBG,' Yes ');
WriteStr(15,43,Blue+LightGrayBG,' No ');
if Key in [LeftArrow,RightArrow] then
Select := not Select;
if Select then
WriteStr(15,30,Blue+LightWhiteBG,#16+' Yes '+#17)
else WriteStr(15,43,Blue+LightWhiteBG,#16+' No '+#17);
until (Ch in ['Y','N']) or (Key in [Return,Escape]);
if (Ch='Y') then Select := true;
if (Ch='N') then Select := false;
if Key=Escape then Select := false;
Confirm := Select;
StoreToScr(11,8,7,60,Scr^);
Freemem(Scr,Size);
Key := NullKey;
end;
procedure OpenFile(var CurrentPath,Filename: string);
const OpenAttr = White+LightGrayBG;
OpenAttr2= White+CyanBG;
DirAttr = LightCyan+LightGrayBG;
TopAttr = Green+LightWhiteBG;
SlideAttr= White+GreenBG;
HighAttr = Yellow+MagentaBG;
OpenRow = 5;
OpenCol = 20;
MaxFiles = 1000;
type FileType = record
Attr : Byte;
Time : Longint;
Size : Longint;
Name : string[12];
end;
PFile = ^FileType;
var FileList : array[1..MaxFiles] of PFile;
NumFiles : integer;
ImSize,
Size: integer;
SearchPath: string;
Scr : pointer;
procedure ScanForFiles(CurrentPath,SearchPath: string);
var S: SearchRec;
begin
NumFiles := 0;
FindFirst(CurrentPath+'*.*',AnyFile,S);
while DosError=0 do
begin
if (S.Name<>'.') and (S.Attr=Directory) then
begin
Inc(NumFiles);
GetMem(FileList[NumFiles],Size);
FileList[NumFiles]^.Attr := S.Attr;
FileList[NumFiles]^.Time := S.Time;
FileList[NumFiles]^.Size := S.Size;
FileList[NumFiles]^.Name := S.Name;
end;
FindNext(S);
end;
FindFirst(CurrentPath+SearchPath,ReadOnly+Archive+Hidden,S);
while DosError=0 do
begin
Inc(NumFiles);
GetMem(FileList[NumFiles],Size);
FileList[NumFiles]^.Attr := S.Attr;
FileList[NumFiles]^.Time := S.Time;
FileList[NumFiles]^.Size := S.Size;
FileList[NumFiles]^.Name := S.Name;
FindNext(S);
end;
end;
procedure SortFileList;
var i: integer;
b: boolean;
t: PFile;
begin
repeat
b := true;
for i := 1 to NumFiles-1 do
if FileList[i]^.Name > FileList[i+1]^.Name then
begin
t:=FileList[i]; FileList[i]:=FileList[i+1]; FileList[i+1]:=t; b:=False;
end;
until b;
repeat
b := true;
for i := 1 to NumFiles-1 do
if (FileList[i]^.Attr and Directory<>Directory) and (FileList[i+1]^.Attr and Directory=Directory) then
begin
t:=FileList[i]; FileList[i]:=FileList[i+1]; FileList[i+1]:=t; b:=False;
end;
until b;
end;
procedure EraseFileList;
var i: integer;
begin
for i := 1 to NumFiles do
FreeMem(FileList[i],Size);
end;
procedure ClearOpen;
var i: integer;
begin
Fill(OpenRow,OpenCol,10,42,OpenAttr,' ');
for i := 1 to 10 do
begin
WriteStr(OpenRow+i-1,OpenCol+13,OpenAttr,'│');
WriteStr(OpenRow+i-1,OpenCol+27,OpenAttr,'│');
end;
end;
procedure DrawBackground;
begin
Box(OpenRow-1,OpenCol-1,18,44,OpenAttr,NoBorder,' ');
AddShadow(OpenRow-1,OpenCol-1,18,44);
Box(OpenRow+10,OpenCol-1,7,44,OpenAttr2,NoBorder,' ');
Fill(OpenRow-1,OpenCol-1,1,44,TopAttr,' ');
WriteC(OpenRow-1,OpenCol+20,TopAttr,'Open File');
WriteStr(OpenRow+10,OpenCol-1,TopAttr,' ');
WriteStr(OpenRow+10,OpenCol+42,TopAttr,' ');
Fill(OpenRow+10,OpenCol+1,1,40,SlideAttr,'▒');
WriteStr(OpenRow+10,OpenCol,SlideAttr,#17);
WriteStr(OpenRow+10,OpenCol+41,SlideAttr,#16);
ClearOpen;
end;
procedure WriteFileList(StartNum: integer);
var i,j: integer;
begin
ClearOpen;
i := StartNum-1;
repeat
Inc(i);
j := i-StartNum;
if FileList[i]^.Attr=Directory then
WriteStr(OpenRow+(j mod 10),OpenCol+1+14*(j div 10),DirAttr,FileList[i]^.Name)
else WriteStr(OpenRow+(j mod 10),OpenCol+1+14*(j div 10),OpenAttr,FileList[i]^.Name);
until (i-StartNum >= 29) or (i=NumFiles);
end;
procedure LightName(StartNum,i: integer; b: boolean);
var j: integer;
a: byte;
s: string[13];
begin
if b then a:=HighAttr
else if FileList[i]^.Attr = Directory then a:=DirAttr
else a := OpenAttr;
j := i-StartNum;
s := ' '+FileList[i]^.Name+' ';
WriteStr(OpenRow+(j mod 10),OpenCol+14*(j div 10),a,s);
end;
procedure WriteInfo(i: integer);
const DateStr : array[1..12] of string[3] = ('Jan','Feb','Mar','Apr','May','Jun',
'Jul','Aug','Sep','Oct','Nov','Dec');
var DT: DateTime;
s,s1: string;
a: byte;
begin
Fill(OpenRow+10,OpenCol+1,1,40,SlideAttr,'▒');
if NumFiles>1 then
a := 1+Trunc(39*(i-1)/(NumFiles-1))
else a:=1;
WriteStr(OpenRow+10,OpenCol+a,SlideAttr,'■');
WriteStr(OpenRow+12,OpenCol+1,OpenAttr2,'File :');
WriteStr(OpenRow+13,OpenCol+1,OpenAttr2,'Size :');
WriteStr(OpenRow+14,OpenCol+1,OpenAttr2,'Attr :');
WriteStr(OpenRow+15,OpenCol+1,OpenAttr2,'Path :');
WriteStr(OpenRow+12,OpenCol+22,OpenAttr2,'Time :');
WriteStr(OpenRow+13,OpenCol+22,OpenAttr2,'Date :');
s := Copy(FileList[i]^.Name+' ',1,12);
WriteStr(OpenRow+12,OpenCol+8,OpenAttr2,s);
Str(FileList[i]^.Size:1,s);
s := Copy(s+' ',1,12);
WriteStr(OpenRow+13,OpenCol+8,OpenAttr2,s);
a := FileList[i]^.Attr;
if (a and Directory)=Directory then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2, 'Directory')
else if (a and Archive)=Archive then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2, 'Archive ')
else if (a and ReadOnly)=ReadOnly then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2,'ReadOnly ')
else if (a and Hidden)=Hidden then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2, 'Hidden ');
s := SearchPath;
if Length(s)>34 then
s := Copy(s,1,34);
WriteStr(OpenRow+15,OpenCol+8,OpenAttr2,' ');
WriteStr(OpenRow+15,OpenCol+8,OpenAttr2,s);
UnpackTime(FileList[i]^.Time,DT);
s := '';
Str(DT.Hour:1,s);
if DT.Hour<10 then s := '0'+s;
Str(DT.Min:1,s1);
if DT.Min<10 then s1 := '0'+s1;
s := s+':'+s1;
Str(DT.Sec:1,s1);
if DT.Sec<10 then s1 := '0'+s1;
s := s+':'+s1;
WriteStr(OpenRow+12,OpenCol+29,OpenAttr2,s);
s := DateStr[DT.Month];
Str(DT.Day:1,s1);
if DT.Day<10 then s1 := '0'+s1;
s := s+'.'+s1;
Str(DT.Year:1,s1);
s := s+' '+s1;
WriteStr(OpenRow+13,OpenCol+29,OpenAttr2,s);
end;
procedure NewSearchPath;
const NewAttr = White+RedBG;
EditAttr= LightCyan+LightGrayBG;
var s: string;
begin
Box(OpenRow+6,OpenCol+11,1,19,NewAttr,NoBorder,' ');
AddShadow(OpenRow+6,OpenCol+11,1,19);
WriteStr(OpenRow+6,OpenCol+12,NewAttr,'Path ');
s := SearchPath;
InputString(s,OpenRow+6,OpenCol+17,12,EditAttr,[Escape,Return]);
if Key=Return then
SearchPath := s;
Key := NullKey;
end;
procedure SelectFile;
var i,j,StartNum,OldStartNum: integer;
begin
StartNum := 1;
OldStartNum := 1;
i := 1;
WriteFileList(StartNum);
LightName(StartNum,i,true);
WriteInfo(i);
repeat
InKey(Ch,Key);
LightName(StartNum,i,false);
case Key of
UpArrow : if i > 1 then Dec(i);
DownArrow : if i < NumFiles then Inc(i);
LeftArrow : if i > 10 then Dec(i,10) else i := 1;
RightArrow: if i < NumFiles-10 then Inc(i,10) else i := NumFiles;
F3 : begin
NewSearchPath;
EraseFileList;
ScanForFiles(CurrentPath,SearchPath);
SortFileList;
StartNum := 1;
OldStartNum := 1;
i := 1;
WriteFileList(StartNum);
LightName(StartNum,i,true);
WriteInfo(i);
end;
Return : if FileList[i]^.Attr = Directory then
begin
if FileList[i]^.Name = '..' then
begin
j := Length(CurrentPath);
repeat
Dec(j);
until CurrentPath[j]='\';
CurrentPath := Copy(CurrentPath,1,j);
end
else
CurrentPath := CurrentPath + FileList[i]^.Name+'\';
EraseFileList;
ScanForFiles(CurrentPath,SearchPath);
SortFileList;
StartNum := 1;
OldStartNum := 1;
i := 1;
WriteFileList(StartNum);
LightName(StartNum,i,true);
WriteInfo(i);
Key := NullKey;
end;
end;
if (i-StartNum < 0) and (StartNum>10) then Dec(StartNum,10);
if (i-StartNum >= 30) then Inc(StartNum,10);
if StartNum<>OldStartNum then
begin
WriteFileList(StartNum);
OldStartNum := StartNum;
end;
LightName(StartNum,i,true);
WriteInfo(i);
until Key in [Escape,Return];
if Key=Return then Filename := FileList[i]^.Name;
end;
begin
ImSize := 2*19*46;
GetMem(Scr,ImSize);
StoreToMem(OpenRow-1,OpenCol-1,19,46,Scr^);
SearchPath := '*.FNT';
Size := SizeOf(FileType);
ScanForFiles(CurrentPath,SearchPath);
SortFileList;
DrawBackground;
SelectFile;
EraseFileList;
StoreToScr(OpenRow-1,OpenCol-1,19,46,Scr^);
FreeMem(Scr,ImSize);
end;
procedure AddSmallShadow(Row,Col,Rows,Cols: byte);
var i,Attr: byte;
begin
for i := 1 to Cols do
begin
Attr := ReadAttr(Row+Rows,Col+i) and $F0;
WriteStr(Row+Rows,Col+i,Attr,'▀');
end;
for i := 1 to Rows-1 do
begin
Attr := ReadAttr(Row+i,Col+Cols) and $F0;
WriteStr(Row+i,Col+Cols,Attr,'█');
end;
Attr := ReadAttr(Row,Col+Cols) and $F0;
WriteStr(Row,Col+Cols,Attr,'▄');
end;
procedure StatusLine(Filename: string);
begin
Fill(25,1,1,80,BottomAttr2,' ');
WriteStr(25,2,BottomAttr1,'F1');
WriteEos(BottomAttr2,'-Help');
WriteStr(25,2,BottomAttr1,'F1');
WriteEos(BottomAttr2,'-Help ');
WriteEos(BottomAttr1,'F2');
WriteEos(BottomAttr2,'-Save ');
WriteEos(BottomAttr1,'F3');
WriteEos(BottomAttr2,'-Load ');
WriteEos(BottomAttr1,'Tab');
WriteEos(BottomAttr2,'-Select Char ');
Filename := UpcaseStr(Filename);
WriteStr(25,73-Length(Filename),BottomAttr1,'File : ');
WriteEos(BottomAttr2,Filename);
end;
procedure MainBackground(Filename: string);
begin
Fill(1,1,25,80,MainBAttr,' ');
Fill(2,4,1,73,TopAttr,' ');
AddSmallShadow(2,4,1,73);
WriteC(2,40,TopAttr,'Font Editor 2.0');
StatusLine(Filename);
end;
procedure CharBackground;
var i: byte;
begin
Fill(CharRow,CharCol,CharRows,CharCols,CharAttrBo,' ');
AddSmallShadow(CharRow,CharCol,CharRows,CharCols);
Fill(CharRow+1,CharCol+4,CharRows-2,CharCols-11,CharAttrNo,' ');
WriteStr(CharRow,CharCol+4,CharAttrBoH,' 8 7 6 5 4 3 2 1 ');
WriteEos(CharAttrBo,' Value');
WriteStr(CharRow+CharRows-1,CharCol+4,CharAttrBo,' 8 7 6 5 4 3 2 1');
for i := 1 to 16 do
WriteStr(CharRow+i,CharCol+1,CharAttrBo,StrLF(i,2));
Fill(CharRow+CharRows-7,CharCol+CharCols,7,38,CharAttrBo,' ');
AddSmallShadow(CharRow+CharRows-7,CharCol+CharCols,7,38);
WriteStr(CharRow+12,CharCol+CharCols+2,CharAttrBo,'Normal Character Bit Current');
WriteC(CharRow+14,CharCol+CharCols+18,CharAttrBo,'---- 0 ----');
WriteC(CharRow+16,CharCol+CharCols+18,CharAttrBo,'---- 1 ----');
WriteStr(CharRow+14,CharCol+CharCols+4,CharAttrSe,' ');
AddSmallShadow(CharRow+14,CharCol+CharCols+4,1,3);
WriteStr(CharRow+16,CharCol+CharCols+4,CharAttrNo,' ');
AddSmallShadow(CharRow+16,CharCol+CharCols+4,1,3);
WriteStr(CharRow+14,CharCol+CharCols+29,CharAttrHiNo,' ');
AddSmallShadow(CharRow+14,CharCol+CharCols+29,1,3);
WriteStr(CharRow+16,CharCol+CharCols+29,CharAttrHiSe,' ');
AddSmallShadow(CharRow+16,CharCol+CharCols+29,1,3);
end;
procedure ChartBackground;
var i: byte;
begin
Fill(ChartRow,ChartCol,ChartRows,ChartCols,ChartAttrBo,' ');
AddSmallShadow(ChartRow,ChartCol,ChartRows,ChartCols);
Fill(ChartRow+1,ChartCol+1,ChartRows-2,ChartCols-2,ChartAttrNo,' ');
for i := 0 to $FF do
WriteStr(ChartRow+1+(i div 32),ChartCol+1+(i mod 32),ChartAttrNo,Chr(i));
WriteC(ChartRow,ChartCol+(ChartCols div 2),ChartAttrBo,'ASCII Chart');
end;
procedure ShowChar(CharNumber: byte);
var i,j: byte;
s: string;
begin
for i := 1 to 16 do
begin
for j := 8 downto 1 do
begin
if Font[CharNumber,i] and PowerList[j] = PowerList[j] then
WriteStr(CharRow+i,CharCol+4+3*(j-1),CharAttrSe,' ')
else WriteStr(CharRow+i,CharCol+4+3*(j-1),CharAttrNo,' ');
end;
WriteStr(CharRow+i,CharCol+CharCols-5,CharAttrBo,HexStr(Font[CharNumber,i]));
end;
s := 'Character # '+HexStr(CharNumber)+' = '+StrLF(CharNumber,3);
WriteC(ChartRow+ChartRows-1,ChartCol+(ChartCols div 2),ChartAttrBo,s);
end;
procedure SelectCharNumber(var CharNumber: byte);
var CN: byte;
begin
CN := CharNumber;
WriteStr(CharRow,CharCol+4,CharAttrBo,' 8 7 6 5 4 3 2 1 ');
WriteC(ChartRow,ChartCol+(ChartCols div 2),ChartAttrBoH,'ASCII Chart');
WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrHi,Chr(CN));
repeat
InKey(Ch,Key);
WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrNo,Chr(CN));
case Key of
UpArrow : Dec(CN,32);
DownArrow : Inc(CN,32);
LeftArrow : Dec(CN);
RightArrow: Inc(CN);
end;
WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrHi,Chr(CN));
ShowChar(CN);
until Key in [TabKey,Return,Escape];
if Key<>Escape then
CharNumber := CN;
WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrNo,Chr(CN));
WriteStr(ChartRow+1+(CharNumber div 32),ChartCol+1+(CharNumber mod 32),ChartAttrSe,Chr(CharNumber));
WriteC(ChartRow,ChartCol+(ChartCols div 2),ChartAttrBo,'ASCII Chart');
WriteStr(CharRow,CharCol+4,CharAttrBoH,' 8 7 6 5 4 3 2 1 ');
ShowChar(CharNumber);
Key := NullKey;
Ch := ' ';
end;
procedure EditCharacter;
var Row,Col,CharNumber: byte;
OldCurrentPath,
OldFilename: string;
Filled: boolean;
DrawMode: (FillAll,EraseAll,Normal);
begin
CharNumber := 65;
ShowChar(CharNumber);
Row := 1;
Col := 1;
DrawMode := Normal;
Filled := (Font[CharNumber,Row] and PowerList[Col]) = PowerList[Col];
if Filled then
WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiSe,' ')
else WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiNo,' ');
WriteStr(ChartRow+1+(CharNumber div 32),ChartCol+1+(CharNumber mod 32),ChartAttrSe,Chr(CharNumber));
repeat
InKey(Ch,Key);
if Filled then
WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrSe,' ')
else WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrNo,' ');
case Key of
TabKey : SelectCharNumber(CharNumber);
UpArrow : Dec(Row);
DownArrow : Inc(Row);
LeftArrow : Dec(Col);
RightArrow: Inc(Col);
PgUp : begin Dec(Row); Inc(Col); end;
PgDn : begin Inc(Row); Inc(Col); end;
HomeKey : begin Dec(Row); Dec(Col); end;
EndKey : begin Inc(Row); Dec(Col); end;
AltF : DrawMode := FillAll;
AltE : DrawMode := EraseAll;
AltN : DrawMode := Normal;
F1 : Help;
F2 : SaveFile(Filename);
F3 : begin
OldCurrentPath := CurrentPath;
OldFilename := Filename;
OpenFile(CurrentPath,Filename);
if (Key<>Escape) and ReadFontFile(CurrentPath+Filename) then
begin
LoadUserFont;
ShowChar(CharNumber);
end
else begin
Filename := OldFilename;
CurrentPath := OldCurrentPath;
end;
StatusLine(Filename);
Key := NullKey;
end;
Space : if DrawMode = Normal then
begin
Font[CharNumber,Row] := Font[CharNumber,Row] xor PowerList[Col];
LoadOneChar(CharNumber,Font[CharNumber]);
WriteStr(CharRow+Row,CharCol+CharCols-5,CharAttrBo,HexStr(Font[CharNumber,Row]));
end;
end;
if Row>BytesPerChar then Row:=1;
if Row<1 then Row:=BytesPerChar;
if Col>8 then Col:=1;
if Col<1 then Col:=8;
if DrawMode<>Normal then
begin
if DrawMode=FillAll then
Font[CharNumber,Row] := Font[CharNumber,Row] or PowerList[Col]
else Font[CharNumber,Row] := Font[CharNumber,Row] and (not PowerList[Col]);
LoadOneChar(CharNumber,Font[CharNumber]);
WriteStr(CharRow+Row,CharCol+CharCols-5,CharAttrBo,HexStr(Font[CharNumber,Row]));
end;
Filled := (Font[CharNumber,Row] and PowerList[Col]) = PowerList[Col];
if Filled then
WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiSe,' ')
else WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiNo,' ');
until Key = Escape;
if Confirm('Save file before quitting',true) then SaveFile(Filename);
end;
begin
WriteLn('Font Editor 2.0 Written by H.Thunem');
GetDir(0,CurrentPath);
if Length(CurrentPath)>3 then
CurrentPath := CurrentPath + '\';
Filename := 'STANDARD.FNT';
if ParamCount=1 then
Filename := UpcaseStr(ParamStr(1));
if Pos('.',Filename)=0 then
Filename := Filename + '.FNT';
if ReadFontFile(Filename) then LoadUserFont
else begin
if Filename<>'STANDARD.FNT' then
WriteLn('Couldn''t find ',Filename,'. Using STANDARD.FNT instead !');
Filename := 'STANDARD.FNT';
if ReadFontFile(Filename) then LoadUserFont
else
begin
WriteLn('Couldn''t find ',Filename,'. Quitting program !!');
Halt(1);
end;
end;
SetIntens;
SetCursor(CursorOff);
About;
MainBackground(Filename);
CharBackground;
ChartBackground;
EditCharacter;
SetBlink;
SetCursor(CursorUnderline);
ClrScr;
Fill(1,1,1,80,White+BlueBG,' ');
WriteStr(1,1,SameAttr,' Welcome back to... The Font Editor by H.Thunem');
end.