И снова шрифты

← →
Dib@zol (2007-06-22 17:19) [0]

Здравствуйте эксперты! Это опять я. После дня упорного труда я получил-таки функцию, позволяющую извлекать из символа шрифта его опорные точки. При условии, что в описании символа не участвуют кривые Безье, всё идёт просто классно (например, для "А"). А вот с этими самыми кривыми вышла загвоздка :((( Для наглядности привожу свой прожект.

И вроде бы определяются-то все точки правильно (я изрисовал целиком два клетчатых листка формата А4, считывая вручную точки в режиме отладки), и формулу-то для расчёта я взял из SDK, дык нет, непашет сволочь! Я опять в полном ступоре и надеяться больше не на кого. S O S!

PS: И кто тока придумывает такую срань как TrueType?
PPS: БГ мудак, M$ уё*ки.

program Test;

uses
Windows, Messages;

type
TFloatValue = (fvExtended, fvCurrency);

PT2D = record
x, y : Single;
end;

PT2DARR = array of array of PT2D;

const
WW = 420;
WH = 330;
CN = "TTF_WND";
WN = "Font";

var
M : MSG;
DC : HDC;
W : HWND;
F : HFONT;
VA : PT2DARR;
WC : WNDCLASS;
WXPos, WYPos : Word;

function SetNewFont(Width:Longint; i, u:boolean; FSize:word; FontName:PChar):HFONT;
var
lf:LOGFONT;
begin
FillChar(lf, SizeOf(lf), 0);
lf.lfHeight := -FSize;
lf.lfWeight := Width;
if i then
lf.lfItalic := 1;
if u then
lf.lfUnderline := 1;
lf.lfCharSet := DEFAULT_CHARSET;
lf.lfOutPrecision := OUT_DEFAULT_PRECIS;
lf.lfClipPrecision := CLIP_DEFAULT_PRECIS;
lf.lfQuality := DEFAULT_QUALITY;
lf.lfPitchAndFamily := FF_DONTCARE or DEFAULT_PITCH;
lstrcpy(lf.lfFaceName, FontName);

Result:=CreateFontIndirect(lf);
end;

function IntToStr(n:Integer):string;
begin
Str(n, result);
end;

function StrToFloat(const S: string): Extended;
// ------------------------------------------------------ \\
function TextToFloat(Buffer: PChar; var Value; ValueType: TFloatValue): Boolean;
const
mIE = $0001;
mOE = $0008;
DCon10: Integer = 10;
CWNear: Word = $133F;
DecimalSeparator:Char=",";

var
Temp: Integer;
CtrlWord: Word;
DecimalSep: Char;
SaveGOT: Integer;

asm
PUSH EDI
PUSH ESI
PUSH EBX
MOV ESI,EAX
MOV EDI,EDX
{$IFDEF PIC}
PUSH ECX
CALL GetGOT
POP EBX
MOV SaveGOT,EAX
MOV ECX,[EAX].OFFSET DecimalSeparator
MOV CL,[ECX].Byte
MOV DecimalSep,CL
{$ELSE}
MOV SaveGOT,0
MOV AL,DecimalSeparator
MOV DecimalSep,AL
MOV EBX,ECX
{$ENDIF}
FSTCW CtrlWord
FCLEX
{$IFDEF PIC}
FLDCW [EAX].CWNear
{$ELSE}
FLDCW CWNear
{$ENDIF}
FLDZ
CALL @@SkipBlanks
MOV BH, byte ptr [ESI]
CMP BH,"+"
JE @@1
CMP BH,"-"
JNE @@2
@@1: INC ESI
@@2: MOV ECX,ESI
CALL @@GetDigitStr
XOR EDX,EDX
MOV AL,[ESI]
CMP AL,DecimalSep
JNE @@3
INC ESI
CALL @@GetDigitStr
NEG EDX
@@3: CMP ECX,ESI
JE @@9
MOV AL, byte ptr [ESI]
AND AL,0DFH
CMP AL,"E"
JNE @@4
INC ESI
PUSH EDX
CALL @@GetExponent
POP EAX
ADD EDX,EAX
@@4: CALL @@SkipBlanks
CMP BYTE PTR [ESI],0
JNE @@9
MOV EAX,EDX
CMP BL,fvCurrency
JNE @@5
ADD EAX,4
@@5: PUSH EBX
MOV EBX,SaveGOT
CALL FPower10
POP EBX
CMP BH,"-"
JNE @@6
FCHS
@@6: CMP BL,fvExtended
JE @@7
FISTP QWORD PTR [EDI]
JMP @@8
@@7: FSTP TBYTE PTR [EDI]
@@8: FSTSW AX
TEST AX,mIE+mOE
JNE @@10
MOV AL,1
JMP @@11
@@9: FSTP ST(0)
@@10: XOR EAX,EAX
@@11: FCLEX
FLDCW CtrlWord
FWAIT
JMP @@Exit

@@SkipBlanks:

@@21: LODSB
OR AL,AL
JE @@22
CMP AL," "
JE @@21
@@22: DEC ESI
RET

// Process string of digits
// Out EDX = Digit count

@@GetDigitStr:

XOR EAX,EAX
XOR EDX,EDX
@@31: LODSB
SUB AL,"0"+10
ADD AL,10
JNC @@32
{$IFDEF PIC}
XCHG SaveGOT,EBX
FIMUL [EBX].DCon10
XCHG SaveGOT,EBX
{$ELSE}
FIMUL DCon10
{$ENDIF}
MOV Temp,EAX
FIADD Temp
INC EDX
JMP @@31
@@32: DEC ESI
RET

// Get exponent
// Out EDX = Exponent (-4999..4999)

@@GetExponent:

XOR EAX,EAX
XOR EDX,EDX
MOV CL, byte ptr [ESI]
CMP CL,"+"
JE @@41
CMP CL,"-"
JNE @@42
@@41: INC ESI
@@42: MOV AL, byte ptr [ESI]
SUB AL,"0"+10
ADD AL,10
JNC @@43
INC ESI
IMUL EDX,10
ADD EDX,EAX
CMP EDX,500
JB @@42
@@43: CMP CL,"-"
JNE @@44
NEG EDX
@@44: RET

@@Exit:
POP EBX
POP ESI
POP EDI
end;
// ------------------------------------------------------ \\
begin
TextToFloat(PChar(S), Result, fvExtended);
end;

← →
Dib@zol (2007-06-22 17:19) [1]

function GetRawLtrData(DC, F : HGDIOBJ; L:Byte):Pointer;
var
TF : HFONT;
GM : GLYPHMETRICS;
M : MAT2;
i : Cardinal;
begin
TF:=SelectObject(DC, F);

FillChar(M, SIZEOF(MAT2), 0);
M.eM11.value:=1;
M.eM22.value:=1;

i:=GetGlyphOutline(DC, L, GGO_NATIVE, GM, 0, nil, M);
Result:=GlobalAllocPtr(GMEM_FIXED, i);
GetGlyphOutline(DC, L, GGO_NATIVE, GM, i, Result, M);
SelectObject(DC, TF);
end;

function FXToFloat(FX:TFixed):Single;
begin
Result:=StrToFloat(IntToStr(FX.value)+","+IntToStr(FX.fract));
end;

procedure ExtractLetter(DC:HDC; F:HFONT; Ltr:Char; var VectArr:PT2DARR);
const
SZTPH = SIZEOF(TTPOLYGONHEADER);
SZTTP = SIZEOF(TTPOLYCURVE);
SZWRD = SIZEOF(WORD);
SZDWD = SIZEOF(DWORD);
SZPFX = SIZEOF(PointFX);
MAX_LEN = 4096;
precis = 10;

var
i, k, pass, LC, ctl : Cardinal;
p : Pointer;

tph : TTPOLYGONHEADER;
ttp : TTPOLYCURVE;
tp : PointFX;
wp : Word;
tmp : array [1..3] of PT2D;

// ------------------------------------------------------ \\
procedure CopyMem(var Buf; shift, size:Cardinal);
begin
Move(pointer(cardinal(p)+shift)^, Buf, size);
end;
// ------------------------------------------------------ \\
procedure ShrinkArr;
var i:Word;
begin
inc(pass);
SetLength(VectArr[pass], LC+1);
for i:=0 to LC do begin
VectArr[pass, i].x:=VectArr[pass-1, i].x;
VectArr[pass, i].y:=VectArr[pass-1, i].y;
end;
Finalize(VectArr[pass-1]);
SetLength(VectArr[pass-1], LC+1);
for i:=0 to LC do begin
VectArr[pass-1, i].x:=VectArr[pass, i].x;
VectArr[pass-1, i].y:=VectArr[pass, i].y;
end;
Finalize(VectArr[pass]);
end;
// ------------------------------------------------------ \\
function FindNewHdr(i:DWORD):boolean;
begin
Result:=false;
if (LOWORD(i)<>TT_PRIM_LINE)and(LOWORD(i)<>TT_PRIM_QSPLINE) then begin
ShrinkArr;
k:=SZDWD+wp*SZPFX+k;
ctl:=0;
LC:=0;
Result:=true;
end;
end;
// ------------------------------------------------------ \\
function FindNewLine(i:DWORD):boolean;
begin
Result:=false;
if (LOWORD(i)=TT_PRIM_LINE)and(LOWORD(i)<>TT_PRIM_QSPLINE) then begin
k:=SZDWD+wp*SZPFX+k; // ???????? ????????????????? ?????!!!
Result:=true;
end;
end;
// ------------------------------------------------------ \\
function FindNewQSpl(i:DWORD):boolean;
begin
Result:=false;
if (LOWORD(i)<>TT_PRIM_LINE)and(LOWORD(i)=TT_PRIM_QSPLINE) then begin
k:=SZDWD+wp*SZPFX+k; // ???????? ????????????????? ?????!!!
Result:=true;
end;
end;
// ------------------------------------------------------ \\
label NH, NL, NQ, retry;
begin
p:=GetRawLtrData(DC, F, ord(Ltr));
SetLength(VectArr, 64);
pass:=0;
k:=0;

NH:
SetLength(VectArr[pass], MAX_LEN);
CopyMem(tp, SZDWD+SZDWD+k, SZPFX);
VectArr[pass, 0].x:=FXToFloat(tp.x);
VectArr[pass, 0].y:=FXToFloat(tp.y);

k:=SZTPH+k;
CopyMem(wp, k, SZWRD);
if wp=TT_PRIM_LINE then begin // LINE LINE LINE LINE LINE
NL:
CopyMem(wp, SZWRD+k, SZWRD);

for i:=1+LC to wp+LC do begin
CopyMem(tp, SZDWD+(i-1)*SZPFX+k, SZPFX);
VectArr[pass, i].x:=FXToFloat(tp.x);
VectArr[pass, i].y:=FXToFloat(tp.y);
end;
ctl:=ctl+wp;
LC:=LC+wp;

CopyMem(i, SZDWD+wp*SZPFX+k, SZDWD);
if FindNewHdr(i) then goto NH // New Header
else if FindNewLine(i) then goto NL // New Line
else if FindNewQSpl(i) then goto NQ // New Spline
else ShrinkArr;
end else
if wp=TT_PRIM_QSPLINE then begin // CURVE CURVE CURVE CURVE
NQ:
CopyMem(wp, SZWRD+k, SZWRD);

ctl:=0;
retry:

if ctl=0 then begin
tmp[1].x:=VectArr[pass, LC].x;
tmp[1].y:=VectArr[pass, LC].y;
end else begin
tmp[1].x:=tmp[3].x;
tmp[1].y:=tmp[3].y;
end;
CopyMem(tp, SZDWD+ctl*SZPFX+k, SZPFX);
tmp[2].x:=FXToFloat(tp.x);
tmp[2].y:=FXToFloat(tp.y);
if wp mod 2 = 0 then begin
CopyMem(tp, SZDWD+(ctl+1)*SZPFX+k, SZPFX);
tmp[3].x:=FXToFloat(tp.x);
tmp[3].y:=FXToFloat(tp.y);
end else begin
tmp[3].x:=0.5*(tmp[1].x+tmp[2].x);
tmp[3].y:=0.5*(tmp[1].y+tmp[2].y);
end;

for i:=1+LC to precis+LC do begin
VectArr[pass, i].x:=(tmp[1].x-tmp[2].x-tmp[2].x+tmp[3].x)*sqr(i/precis) + 2*(tmp[2].x-tmp[1].x)*(i/precis) + tmp[1].x;
VectArr[pass, i].y:=(tmp[1].y-tmp[2].y-tmp[2].y+tmp[3].y)*sqr(i/precis) + 2*(tmp[2].y-tmp[1].y)*(i/precis) + tmp[1].y;
end;

ctl:=ctl+2;
LC:=LC+precis;

if ctl<wp then goto retry;

CopyMem(i, SZDWD+wp*SZPFX+k, SZDWD);
if FindNewHdr(i) then goto NH // New Header
else if FindNewLine(i) then goto NL // New Line
else if FindNewQSpl(i) then goto NQ // New Spline
else ShrinkArr;
end;

GlobalFreePtr(p);
end;

function WindowProc(hWnd: HWND; Msg: integer; WParam, LParam: LongInt): LongInt; stdcall;
const
LTR = "j";
k = 1;
var
PT : array [0..255] of TPoint;
i : Word;
TF : HFONT;
lps : PChar;
begin
Result:=0;
case Msg of
WM_CREATE:
begin
DC:=GetDC(hWnd);
F:=SetNewFont(FW_BOLD, false, false, 240, "Arial");
ExtractLetter(DC, F, LTR, VA);
end;

WM_PAINT:
begin
if VA<>nil then begin
TF:=SelectObject(DC, F);
SetBkMode(DC, TRANSPARENT);
lps:=LTR;
SetTextColor(DC, $00DDEE);
TextOut(DC, 120, 18, lps, 1);
SelectObject(DC, TF);
for i:=0 to Length(va[k])-1 do begin
PT[i].X:=round(va[k, i].x)+120;
PT[i].Y:=-round(va[k, i].y)+240;
end;
Polyline(DC, PT, Length(va[k]));
end;
end;

WM_CLOSE:
begin
ReleaseDC(hWnd, DC);
DeleteDC(DC);
Finalize(VA);
DeleteObject(F);
DestroyWindow(hWnd);
end;

WM_DESTROY: PostQuitMessage(0);
end;
Result:=DefWindowProc(hWnd, Msg, WParam, LParam)
end;

begin
WXPos:=round((GetSystemMetrics(SM_CXSCREEN)-WW)/2);
WYPos:=round((GetSystemMetrics(SM_CYSCREEN)-WH)/2);

with WC do begin
Style := CS_HREDRAW or CS_VREDRAW;
lpfnWndProc := @WindowProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := sysInit.HInstance;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := GetSysColorBrush(COLOR_BTNFACE);
lpszClassName := CN;
end;
RegisterClass(WC);
W := CreateWindowEx(0, CN, WN, WS_VISIBLE or WS_SYSMENU,
WXPos, WYPos, WW, WH, 0, 0, HInstance, nil);
ShowWindow(W, SW_SHOWNORMAL);
UpdateWindow(W);

while GetMessage(M, 0, 0, 0) do begin
TranslateMessage(M);
DispatchMessage(M);
end;
Halt(M.wParam);
end.

← →
Dib@zol (2007-06-23 16:15) [2]

Ну тык чё??? Так никто и не знает??? :...((((

И снова шрифты Найти похожие ветки