Skip to content

Commit 36706b9

Browse files
RetroNick2020RetroNick2020
committed
BMFont for freepascal
1 parent f964150 commit 36706b9

6 files changed

Lines changed: 605 additions & 0 deletions

File tree

‎freepascal/BMFonts in ptcGraph/BMFont_Test.pas‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
Program BMFont_test;
2+
uses ptccrt,ptcGraph,BmFont,BmFontGraph;
3+
4+
var
5+
Fnt : TBmFont;
6+
C : TBmChar;
7+
Pg : TBmPage;
8+
FontRender : TBmFontRenderer;
9+
gd,gm : smallint;
10+
begin
11+
gd:=VGA;
12+
gm:=VGAHI;
13+
Initgraph(gd,gm,'');
14+
15+
Fnt := TBmFont.Create;
16+
Fnt.LoadText('pixantiqua.fnt');
17+
18+
FontRender :=TBmFontRenderer.Create(Fnt,'E:\Development\MyProjects\LazDemos\BMFonts in ptcGraph');
19+
20+
FontRender.DrawText(10,10,'This is how we say hello!!!');
21+
FontRender.DrawText(9,9,'This is how we say hello!!!',Green);
22+
23+
readln;
24+
FontRender.Free;
25+
closegraph;
26+
end.

‎freepascal/BMFonts in ptcGraph/bmfont.pas‎

Lines changed: 225 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,225 @@
1+
unit BmFont;
2+
{$mode objfpc}{$H+}
3+
4+
interface
5+
6+
uses
7+
Classes, SysUtils, StrUtils, fgl, Generics.Collections;
8+
9+
type
10+
TBmInfo = record
11+
face : string;
12+
size : integer;
13+
bold : integer;
14+
italic : integer;
15+
charset : string;
16+
unicode : integer;
17+
stretchH : integer;
18+
smooth : integer;
19+
aa : integer;
20+
padding : string;
21+
spacing : string;
22+
outline : integer;
23+
end;
24+
25+
TBmCommon = record
26+
LineHeight : integer;
27+
Base : integer;
28+
Width : integer;
29+
Height : integer;
30+
pages : integer;
31+
ppacked : integer;
32+
alphaChnl : integer;
33+
redChnl : integer;
34+
greenChnl : integer;
35+
blueChnl : integer;
36+
end;
37+
38+
TBmPage = record
39+
id : integer;
40+
filename : string;
41+
end;
42+
43+
TBmChar = record
44+
id : Integer; // unicode code-point
45+
x, y, w, h : Integer; // texture rectangle
46+
xo, yo : integer; // x/y offset when drawing
47+
xa : Integer; // x-advance for next glyph
48+
page : Integer;
49+
chnl : Integer;
50+
end;
51+
52+
TBmKern = record
53+
first, second: integer;
54+
amount: integer;
55+
end;
56+
57+
CharDict = specialize TDictionary<integer, TBmChar>;
58+
PagesDict = specialize TDictionary<integer, TBmPage>;
59+
60+
TBmFont = class
61+
public
62+
info : TBmInfo;
63+
Common : TBmCommon;
64+
Pages : PagesDict; // texture file names
65+
Chars : CharDict; // glyph data
66+
Kerns : array of TBmKern; // kerning pairs
67+
constructor Create;
68+
destructor Destroy; override;
69+
procedure LoadText(const FileName: string); // .fnt text format
70+
function GetCharByID(id: integer): TBmChar; // fast lookup
71+
function GetPageByID(id: integer): TBmPage;
72+
end;
73+
74+
implementation
75+
76+
constructor TBmFont.Create;
77+
begin
78+
Pages := PagesDict.Create;
79+
Chars := CharDict.Create;
80+
end;
81+
82+
destructor TBmFont.Destroy;
83+
begin
84+
Pages.Free;
85+
Chars.Free;
86+
inherited;
87+
end;
88+
89+
90+
91+
procedure TBmFont.LoadText(const FileName: string);
92+
var
93+
sl: TStringList;
94+
ln: string;
95+
p : TStringArray;
96+
97+
procedure Split(const s: string);
98+
begin
99+
p := s.Split([' '], TStringSplitOptions.ExcludeEmpty);
100+
end;
101+
102+
function xVal(const key: string; Default: Integer = 0): Integer;
103+
var
104+
i: Integer;
105+
t: string;
106+
begin
107+
for i := 0 to High(p) do
108+
begin
109+
t := p[i];
110+
if t.StartsWith(key) then
111+
Exit(t.Substring(key.Length+1).ToInteger);
112+
end;
113+
Result := Default;
114+
end;
115+
116+
function sVal(const key: string; Default: String = ''): string;
117+
var
118+
i: Integer;
119+
t: string;
120+
begin
121+
for i := 0 to High(p) do
122+
begin
123+
t := p[i];
124+
t := StringReplace(t, '"', '', [rfReplaceAll]); //remove "" from string
125+
126+
if t.StartsWith(key) then
127+
Exit(t.Substring(key.Length+1));
128+
end;
129+
Result := Default;
130+
end;
131+
132+
133+
var
134+
c : TBmChar;
135+
k : TBmKern;
136+
pg: TBmPage;
137+
n : integer;
138+
begin
139+
sl := TStringList.Create;
140+
try
141+
sl.LoadFromFile(FileName);
142+
for ln in sl do
143+
begin
144+
if ln.StartsWith('info') then
145+
begin
146+
Split(ln); //takes lines and converts to TStringArray
147+
Info.face := sVal('face');
148+
Info.size := xVal('size');
149+
Info.bold := xVal('bold');
150+
Info.italic := xVal('italic');
151+
Info.charset := sVal('charset');
152+
Info.unicode := xVal('unicode');
153+
Info.stretchH := xVal('stretchH');
154+
Info.smooth:= xVal('smooth');
155+
Info.aa:= xVal('aa');
156+
Info.padding:= sVal('padding');
157+
Info.spacing:= sVal('spacing');
158+
Info.outline:= xVal('outline');
159+
end
160+
else if ln.StartsWith('common') then
161+
begin
162+
Split(ln); //takes lines and converts to TStringArray
163+
Common.LineHeight := xVal('lineHeight');
164+
Common.Base := xVal('base');
165+
Common.Width := xVal('scaleW');
166+
Common.Height := xVal('scaleH');
167+
Common.pages := xVal('pages');
168+
Common.ppacked := xVal('packed');
169+
Common.alphaChnl := xVal('alphaChnl');
170+
Common.redChnl := xVal('redChnl');
171+
Common.greenChnl := xVal('greenChnl');
172+
Common.blueChnl := xVal('blueChnl');
173+
end
174+
else if ln.StartsWith('page') then
175+
begin
176+
Split(ln);
177+
pg.id := xVal('id');
178+
pg.filename := sVal('file');
179+
Pages.AddOrSetValue(pg.id, pg);
180+
end
181+
else if ln.StartsWith('char') then
182+
begin
183+
Split(ln);
184+
c.id := xVal('id');
185+
c.x := xVal('x');
186+
c.y := xVal('y');
187+
c.w := xVal('width');
188+
c.h := xVal('height');
189+
c.xo := xVal('xoffset');
190+
c.yo := xVal('yoffset');
191+
c.xa := xVal('xadvance');
192+
c.page := xVal('page');
193+
c.chnl := xVal('chnl');
194+
Chars.AddOrSetValue(c.id, c);
195+
end
196+
else if ln.StartsWith('kerning') then
197+
begin
198+
Split(ln);
199+
k.first := xVal('first');
200+
k.second := xVal('second');
201+
k.amount := xVal('amount');
202+
SetLength(Kerns, Length(Kerns) + 1);
203+
Kerns[High(Kerns)] := k;
204+
end;
205+
end;
206+
finally
207+
sl.Free;
208+
end;
209+
end;
210+
211+
function TBmFont.GetCharByID(id: integer): TBmChar;
212+
begin
213+
if not Chars.TryGetValue(id, Result) then
214+
Result := Default(TBmChar); // zero-filled = missing glyph
215+
end;
216+
217+
function TBmFont.GetPageByID(id: integer): TBmPage;
218+
begin
219+
if not Pages.TryGetValue(id, Result) then
220+
Result := Default(TBmPage);
221+
end;
222+
223+
224+
end.
225+

‎freepascal/BMFonts in ptcGraph/bmfontgraph.pas‎

Lines changed: 127 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,127 @@
1+
unit BmFontGraph;
2+
{$mode objfpc}{$H+}
3+
4+
interface
5+
6+
uses
7+
BmFont, ptcGraph, SysUtils, Classes, FPImage,FPReadPNG,graphcopy;
8+
9+
10+
type
11+
TBmFontRenderer = class
12+
private
13+
FFont : TBmFont;
14+
FPages: array of TFPCustomImage; // one TFPCustomImage per texture page
15+
FKerningOn: Boolean;
16+
17+
procedure LoadPages(const BasePath: string);
18+
function KernAmount(first, second: integer): integer;
19+
public
20+
constructor Create(Font: TBmFont; const TextureBasePath: string);
21+
destructor Destroy; override;
22+
procedure DrawText(x, y: Integer; const txt: string; col: longword = White);
23+
property KerningOn: Boolean read FKerningOn write FKerningOn;
24+
end;
25+
26+
implementation
27+
28+
procedure TBmFontRenderer.LoadPages(const BasePath: string);
29+
var
30+
i: Integer;
31+
fs: TFileStream;
32+
reader: TFPCustomImageReader;
33+
fname : string;
34+
begin
35+
SetLength(FPages, FFont.Pages.Count);
36+
reader := TFPReaderPNG.Create; // works for PNG atlases
37+
try
38+
for i := 0 to FFont.Pages.Count - 1 do
39+
begin
40+
fname:=IncludeTrailingPathDelimiter(BasePath) + FFont.Pages[i].filename;
41+
fs := TFileStream.Create(fname, fmOpenRead);
42+
try
43+
FPages[i] := TFPMemoryImage.Create(0, 0);
44+
FPages[i].LoadFromStream(fs, reader);
45+
finally
46+
fs.Free;
47+
end;
48+
end;
49+
finally
50+
reader.Free;
51+
end;
52+
end;
53+
54+
{ ---------- helper: look up kerning pair ---------- }
55+
function TBmFontRenderer.KernAmount(first, second: integer): integer;
56+
var
57+
i: Integer;
58+
begin
59+
if not FKerningOn then Exit(0);
60+
for i := 0 to High(FFont.Kerns) do
61+
if (FFont.Kerns[i].first = first) and (FFont.Kerns[i].second = second) then
62+
Exit(FFont.Kerns[i].amount);
63+
Result := 0;
64+
end;
65+
66+
constructor TBmFontRenderer.Create(Font: TBmFont; const TextureBasePath: string);
67+
begin
68+
inherited Create;
69+
FFont := Font;
70+
FKerningOn := True;
71+
LoadPages(TextureBasePath);
72+
end;
73+
74+
destructor TBmFontRenderer.Destroy;
75+
var
76+
i: Integer;
77+
begin
78+
for i := 0 to FFont.Pages.Count - 1 do
79+
begin
80+
FPages[i].Free;
81+
end;
82+
inherited;
83+
end;
84+
85+
procedure TBmFontRenderer.DrawText(x, y: Integer; const txt: string; col: longword);
86+
var
87+
cx, cy, i, page, dstX, dstY: Integer;
88+
c: TBmChar;
89+
kern: integer;
90+
begin
91+
if not Assigned(FFont) then Exit;
92+
dstX := x;
93+
for i := 1 to Length(txt) do
94+
begin
95+
c := FFont.GetCharByID(Ord(txt[i]));
96+
if c.id = 0 then // missing glyph space
97+
begin
98+
dstX := dstX + FFont.Common.LineHeight div 3;
99+
Continue;
100+
end;
101+
102+
// kerning with previous character
103+
if (i > 1) and FKerningOn then
104+
dstX := dstX + KernAmount(Ord(txt[i-1]), Ord(txt[i]));
105+
106+
page := c.page;
107+
if (page < 0) or (page > High(FPages)) then Continue;
108+
109+
// destination top-left on screen
110+
dstX := dstX + c.xo;
111+
dstY := y + c.yo;
112+
113+
// copy the glyph rectangle from atlas to screen
114+
CopyImageRect(
115+
FPages[page], // source atlas (TFPMemoryImage)
116+
c.x, c.y, // source top-left
117+
dstX, dstY, // destination top-left
118+
c.w, c.h, // width / height
119+
128, // alpha threshold (0-255)
120+
col); // ptcGraph colour tint
121+
122+
// advance cursor
123+
dstX := dstX + c.xa - c.xo; // xa already includes xo
124+
end;
125+
end;
126+
127+
end.

0 commit comments

Comments
 (0)