Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

CanvasFontManager.pas

Last change on this file was 420, checked in by ataylor, 6 years ago
Improve DBCS string width calculations, other small tweaks.
Property svn:eol-style set to `native`
File size: 32.8 KB

Line
1	Unit CanvasFontManager;
2
3	Interface
4
5	Uses
6	OS2Def,
7	Classes,
8	Forms,
9	PMWIN,
10	Graphics;
11
12	Const
13	// This defines the fraction of a pixel that
14	// font character widths will be given in
15	FontWidthPrecisionFactor = 256;
16
17	Type
18	// a user-oriented specification of a font;
19	// does not include OS/2 API data
20	TFontSpec = record
21	FaceName: string[ 64 ];
22	PointSize: integer; // if 0 then use x/y size
23	XSize: integer;
24	YSize: integer;
25	Attributes: TFontAttributes; // set of faBold, faItalic etc
26	end;
27
28	// NOTE: Char widths are in 1/FontWidthPrecisionFactor units
29	TCharWidthArray = array[ #0..#255 ] of longint;
30	TPCharWidthArray = ^ TCharWidthArray;
31
32	// Used internally for storing full info on font
33	TLogicalFont= Class( TComponent )
34	pFaceName: pstring; // user-selected name
35	pUseFaceName: pstring; // after substitutions.
36
37	// Selected bits of FONTMETRICS
38	fsSelection: USHORT;
39
40	FontType: TFontType;
41	FixedWidth: boolean;
42	PointSize: integer;
43	ID: integer;
44	Attributes: TFontAttributes;
45
46	// this can be nil if not already fetched
47	pCharWidthArray: TPCharWidthArray;
48	lMaxbaselineExt: LONG;
49	lAveCharWidth: LONG;
50	lMaxCharInc: LONG;
51	lMaxDescender: LONG;
52	lEmInc: LONG;
53
54	destructor Destroy; override;
55	end;
56
57	TFontFace = class
58	pName: pstring;
59	FixedWidth: boolean;
60	FontType: TFontType;
61
62	Sizes: TList; // relevant for bitmap fonts only
63	// contains TLogicalFont objects
64	constructor Create;
65	destructor Destroy; override;
66	end;
67
68	TCanvasFontManager = class
69	protected
70	FCanvas: TCanvas;
71	FLogicalFonts: TList;
72	FCurrentFontSpec: TFontSpec;
73	FDefaultFontSpec: TFontSpec;
74	FCurrentFont: TLogicalFont;
75	FAllowBitmapFonts: boolean;
76
77	protected
78	function CreateFont( const FontSpec: TFontSpec ): TLogicalFont;
79
80	function GetFont( const FontSpec: TFontSpec ): TLogicalFont;
81
82	procedure RegisterFont( Font: TLogicalFont );
83	procedure SelectFont( Font: TLogicalFont;
84	Scale: longint );
85
86	// Retrieve character widths for current font
87	procedure LoadMetrics;
88
89	// load metrics if needed
90	procedure EnsureMetricsLoaded;
91	public
92	Constructor Create( Canvas: TCanvas;
93	AllowBitmapFonts: boolean );
94	destructor Destroy; override;
95
96	// Useful functions:
97
98	// Set the font for the associated canvas.
99	procedure SetFont( const FontSpec: TFontSpec );
100
101	// Retrieve the width of the given char, in the current font
102	function CharWidth( const C: Char ): longint;
103
104	function AverageCharWidth: longint;
105	function MaximumCharWidth: longint;
106	function CJKCharWidth: longint; // ALT
107	function CJKTextWidth( const Length: longint; const S: PChar ): longint;
108	function IsFixed: boolean;
109
110	function CharHeight: longint;
111	function CharDescender: longint;
112
113	procedure DrawString( Var Point: TPoint;
114	const Length: longint;
115	const S: PChar );
116
117	property Canvas: TCanvas read FCanvas;
118	property DefaultFontSpec: TFontSpec read FDefaultFontSpec write FDefaultFontSpec;
119	end;
120
121	// Convert a Sibyl font to a FontSpec (Color is left the same)
122	procedure SibylFontToFontSpec( Font: TFont; Var FontSpec: TFontSpec );
123
124	// Thoughts on how it works....
125
126	// SelectFont looks for an existing logical font that
127	// matches the request. If found selects that logical font
128	// onto the canvas.
129
130	// If not found it creates a logical font and selects that onto
131	// the canvas.
132
133	// For bitmap fonts the logical font definition includes pointsize
134	// For outline fonts the defn is only face+attr; in this case
135	// selectfont also ses the 'CharBox' according to the point size.
136	Implementation
137
138	uses
139	PMWin,
140	PMGpi,
141	OS2Def,
142	PmDev,
143	SysUtils,
144
145	StringUtilsUnit;
146
147	Imports
148	Function GpiQueryCharStringPosAt( PS: Hps;
149	StartPoint: PPointL;
150	Options: ULONG;
151	Count: LONG;
152	TheString: PChar;
153	IncrementsArray: PLONG;
154	CharacterPoints: PPointL ): BOOL;
155	ApiEntry; 'PMGPI' Index 585;
156	Function GpiQueryCharStringPos( PS: Hps;
157	Options: ULONG;
158	Count: LONG;
159	TheString: PChar;
160	IncrementsArray: PLONG;
161	CharacterPoints: PPointL ): BOOL;
162	ApiEntry; 'PMGPI' Index 584;
163	end;
164
165	Type
166	// A little pretend window to send font name.size
167	// and get definite font info back. (See .CreateFont)
168	TFontWindow = class( TControl )
169	public
170	procedure CreateWnd; override;
171	property OwnerDraw;
172	Function SetPPFontNameSize( Const FNS: String ): Boolean;
173	end;
174
175	var
176	FontFaces: TList = nil; // of TFontface
177	FontWindow: TFontWindow;
178
179	DefaultOutlineFixedFace: TFontFace;
180	DefaultOutlineProportionalFace: TFontFace;
181
182	// TFontFace
183	//------------------------------------------------------------------------
184
185	constructor TFontface.Create;
186	begin
187	Sizes := TList.Create;
188	end;
189
190	destructor TFontface.Destroy;
191	begin
192	Sizes.Destroy;
193	end;
194
195	// TLogicalFont
196	//------------------------------------------------------------------------
197
198	// frees allocated memory, if any.
199	// Note - does not delete the Gpi Logical Font
200	destructor TLogicalFont.Destroy;
201	begin
202	DisposeStr( pFaceName );
203	DisposeStr( pUseFaceName );
204
205	if pCharWidthArray <> nil then
206	FreeMem( pCharWidthArray,
207	sizeof( TCharWidthArray ) );
208
209	inherited Destroy;
210	end;
211
212	// TFontWindow
213	//------------------------------------------------------------------------
214
215	procedure TFontWindow.CreateWnd;
216	begin
217	inherited CreateWnd;
218	end;
219
220	Function TFontWindow.SetPPFontNameSize( Const FNS: String ): Boolean;
221	Var
222	CS: Cstring;
223	Begin
224	CS := FNS;
225
226	Result := WinSetPresParam( Handle,
227	PP_FONTNAMESIZE,
228	Length( CS ) + 1,
229	CS );
230	End;
231
232	//------------------------------------------------------------------------
233
234	// Convert a Sibyl font to a FontSpec
235	//------------------------------------------------------------------------
236	procedure SibylFontToFontSpec( Font: TFont; Var FontSpec: TFontSpec );
237	begin
238	FontSpec.FaceName := Font.FaceName;
239	FontSpec.PointSize := Font.PointSize;
240	FontSpec.Attributes := Font.Attributes;
241	end;
242
243	// Find a font face with the given name
244	//------------------------------------------------------------------------
245	function FindFaceName( const name: string ): TFontFace;
246	Var
247	FaceIndex: LongInt;
248	Face: TFontFace;
249	begin
250	for FaceIndex := 0 to FontFaces.Count - 1 do
251	begin
252	Face := FontFaces[ FaceIndex ];
253
254	if StrEqualIgnoringCase( Face.pName^, Name ) then
255	begin
256	Result := Face;
257	exit;
258	end;
259	end;
260	Result := nil;
261	end;
262
263	// Return the first font face of type = Outline (scalable)
264	//------------------------------------------------------------------------
265	function GetFirstOutlineFace( FixedWidth: boolean ): TFontFace;
266	Var
267	FaceIndex: LongInt;
268	Face: TFontFace;
269	begin
270	for FaceIndex := 0 to FontFaces.Count - 1 do
271	begin
272	Face := FontFaces[ FaceIndex ];
273
274	if ( Face.FixedWidth = FixedWidth )
275	and ( Face.FontType = ftOutline ) then
276	begin
277	Result := Face;
278	exit;
279	end;
280	end;
281	Result := nil;
282	end;
283
284	// Find the bitmap font which best matches the given pointsize.
285	//------------------------------------------------------------------------
286	function GetClosestBitmapFixedFont( const PointSize: longint ): TLogicalFont;
287	Var
288	FaceIndex: Longint;
289	FontIndex: longint;
290	Face: TFontFace;
291	Font: TLogicalFont;
292	begin
293	Result := nil;
294	for FaceIndex := 0 to FontFaces.Count - 1 do
295	begin
296	Face := FontFaces[ FaceIndex ];
297
298	if Face.FontType = ftBitmap then
299	begin
300	for FontIndex := 0 to Face.Sizes.Count - 1 do
301	begin
302	Font := Face.Sizes[ FontIndex ];
303	if Font.FixedWidth then
304	begin
305	if ( Result = nil )
306	or ( Abs( Font.PointSize - PointSize )
307	< Abs( Result.PointSize - PointSize ) ) then
308	Result := Font;
309	end;
310	end;
311	end;
312	end;
313	end;
314
315	// Pick some nice default fonts.
316	//------------------------------------------------------------------------
317	procedure GetDefaultFonts;
318	begin
319	// courier new is common and reasonably nice
320	DefaultOutlineFixedFace := FindFaceName( 'Courier New' );
321	if DefaultOutlineFixedFace = nil then
322	begin
323	DefaultOutlineFixedFace := GetFirstOutlineFace( true ); // first fixed outline face
324	end;
325
326	DefaultOutlineProportionalFace := FindFaceName( 'Helvetica' );
327	if DefaultOutlineProportionalFace = nil then
328	begin
329	DefaultOutlineProportionalFace := GetFirstOutlineFace( false ); // first prop outline face
330	end;
331	end;
332
333	Type
334	TMyFontMetrics = Array[ 0..1 ] Of FONTMETRICS;
335	PMyFontMetrics = ^TMyFontMetrics;
336
337	// Fetch the global list of font faces and sizes
338	//------------------------------------------------------------------------
339	procedure GetFontList;
340	Var
341	Count: LongInt;
342	aPS: HPS;
343	T: LongInt;
344	Font: TLogicalFont;
345	Face: TFontFace;
346	pfm: PMyFontMetrics;
347	FamilyName: string;
348	fsDefn: USHORT;
349	Begin
350	FontFaces := TList.Create;
351
352	aPS := WinGetPS( HWND_DESKTOP );
353	Count := 0;
354	// Get font count
355	Count := GpiQueryFonts( aPS,
356	QF_PUBLIC,
357	Nil,
358	Count,
359	0,
360	Nil );
361	If Count > 0 Then
362	Begin
363	// allocate memory to retrieve all the font data.
364	GetMem( pfm, Count * SizeOf( FONTMETRICS ) );
365	GpiQueryFonts( aPS,
366	QF_PUBLIC,
367	Nil,
368	Count,
369	SizeOf(FONTMETRICS),
370	pfm^[ 0 ] );
371
372	For T := 0 To Count - 1 Do
373	Begin
374	Font := TLogicalFont.Create( Screen );
375
376	Font.pFaceName := NewStr( pfm^[ T ].szFaceName );
377	FamilyName := pfm^[ T ].szFamilyName;
378
379	// See what type it is. Actually this is not very
380	// useful as various substitutions are normally made.
381	fsDefn := pfm^[ T ].fsDefn;
382	If ( fsDefn And FM_DEFN_OUTLINE ) <> 0 Then
383	Font.FontType := ftOutline
384	else
385	Font.FontType := ftBitmap;
386
387	if Font.pFaceName^ = 'Helvetica' then
388	Font := Font;
389	Font.PointSize := pfm^[ T ].sNominalPointSize div 10;
390	Font.FixedWidth := pfm^[ T ].fsType And FM_TYPE_FIXED <> 0 ;
391	Font.fsSelection := pfm^[ T ].fsSelection;
392	Font.lMaxbaselineExt := pfm^[ T ].lMaxbaselineExt;
393	Font.lAveCharWidth := pfm^[ T ].lAveCharWidth;
394	Font.lMaxCharInc := pfm^[ T ].lMaxCharInc;
395	Font.lEmInc := pfm^[ T ].lEmInc;
396
397	Font.ID := -1; // and always shall be so...
398
399	Face := FindFaceName( Font.pFaceName^ );
400	if Face = nil then
401	begin
402	// new face found
403	Face := TFontFace.Create;
404	Face.pName := Font.pFaceName; // point to the actual face name string!
405	Face.FixedWidth := Font.FixedWidth;
406	Face.FontType := Font.FontType;
407	FontFaces.Add( Face );
408	end;
409	Face.Sizes.Add( Font );
410	End;
411	End;
412
413	FreeMem( pfm, Count * SizeOf( FONTMETRICS ) );
414	WinReleasePS( aPS );
415
416	// pick some for defaults
417	GetDefaultFonts;
418
419	FontWindow := TFontWindow.Create( Nil );
420	FontWindow.OwnerDraw := True;
421	FontWindow.CreateWnd;
422	end;
423
424	// Add .subscript to font name for attributes
425	//------------------------------------------------------------------------
426	Function ModifyFontName( const FontName: string;
427	const Attrs: TFontAttributes ): String;
428	Begin
429	Result := FontName;
430	If faItalic in Attrs Then
431	Result := Result + '.Italic';
432	If faBold in Attrs Then
433	Result := Result + '.Bold';
434	If faOutline in Attrs Then
435	Result := Result + '.Outline';
436	If faStrikeOut in Attrs Then
437	Result := Result + '.Strikeout';
438	If faUnderScore in Attrs Then
439	Result := Result + '.Underscore';
440	End;
441
442	// Create a font without attributes
443	//------------------------------------------------------------------------
444	function CreateFontBasic( const FaceName: string;
445	const PointSize: integer ): TLogicalFont;
446	var
447	PPString: string;
448	PresSpace: HPS;
449	FontInfo: FONTMETRICS;
450	begin
451	Result := TLogicalFont.Create( nil );
452
453	if FindFaceName( FaceName ) = nil then
454	exit;
455
456	Result.PointSize := PointSize; // will use later if the result was an outline font...
457	Result.pFaceName := NewStr( FaceName );
458
459	// OK now we have found the font face...
460	PPString := IntToStr( PointSize) + '.' + FaceName;
461
462	PPString := ModifyFontName( PPString, [] );
463	If Not FontWindow.SetPPFontNameSize( PPString ) Then
464	// Gurk!
465	Exit;
466
467	PresSpace := WinGetPS( FontWindow.Handle );
468	If Not GpiQueryFontMetrics( PresSpace,
469	SizeOf( FONTMETRICS ),
470	FontInfo ) Then
471	begin
472	// Clurkle!?
473	WinReleasePS( PresSpace );
474	Exit;
475	end;
476	WinReleasePS( PresSpace );
477
478	if ( FontInfo.fsDefn And FM_DEFN_OUTLINE ) > 0 then
479	Result.FontType := ftOutline
480	else
481	Result.FontType := ftBitmap;
482	end;
483
484	// Provide outline substitutes for some common bitmap fonts
485	// From Mozilla/2 source.
486	//------------------------------------------------------------------------
487	function SubstituteBitmapFontToOutline( const FaceName: string ): string;
488	begin
489	if StrEqualIgnoringCase( FaceName, 'Helv' ) then
490	result := 'Helvetica'
491	else if StrEqualIgnoringCase( FaceName, 'Tms Rmn' ) then
492	result := 'Times New Roman'
493	else if StrEqualIgnoringCase( FaceName, 'System Proportional' ) then
494	result := 'Helvetica'
495	else if StrEqualIgnoringCase( FaceName, 'System Monospaced' ) then
496	result := 'Courier'
497	else if StrEqualIgnoringCase( FaceName, 'System VIO' ) then
498	result := 'Courier'
499	else
500	result := FaceName; // no substitution
501
502	end;
503
504	// NOTE!!! Not currently used or working...
505	// Find a font with exact width and height
506	//------------------------------------------------------------------------
507	function FindXYSizeFont( const Face: TFontFace;
508	const XSize: longint;
509	const YSize: longint ): TLogicalFont;
510	var
511	SizeIndex: longint;
512	F: TLogicalFont;
513	FontInfo: FONTMETRICS;
514	begin
515	for SizeIndex := 0 to Face.Sizes.Count - 1 do
516	begin
517	F := Face.Sizes[ SizeIndex ];
518	if ( F.lMaxbaselineExt = YSize )
519	and ( F.lAveCharWidth = XSize ) then
520	begin
521	// found exact match
522	FontInfo.lMaxbaselineExt := F.lMaxbaselineExt;
523	FontInfo.lAveCharWidth := F.lAveCharWidth;
524	Result.FontType := ftBitmap;
525	end;
526	end;
527	end;
528
529	// Ask OS/2 dummy font window to convert a font spec
530	// into a FONTMETRICS.
531	//------------------------------------------------------------------------
532	procedure AskOS2FontDetails( const FaceName: string;
533	const PointSize: longint;
534	const Attributes: TFontAttributes;
535	var FontInfo: FONTMETRICS );
536	var
537	PPString: string;
538	PresSpace: HPS;
539	begin
540	// Hack from Sibyl code - we don't know WTF the algorithm is
541	// for selecting between outline/bitmap and doing substitutions
542	// so send it to a dummy window and find out the resulting details
543	PPString := IntToStr( PointSize )
544	+ '.'
545	+ FaceName;
546
547	PPString := ModifyFontName( PPString, Attributes );
548
549	FontWindow.SetPPFontNameSize( PPString );
550
551	PresSpace := WinGetPS( FontWindow.Handle );
552	GpiQueryFontMetrics( PresSpace,
553	SizeOf( FontInfo ),
554	FontInfo );
555	WinReleasePS( PresSpace );
556	end;
557
558	// Look for the best match for the given face, size and attributes.
559	// If FixedWidth is set then makes sure that the result is fixed
560	// (if there is any fixed font on the system at all!)
561	// This uses the OS/2 GPI and therefore makes some substitutions,
562	// such as Helv 8 (bitmap) for Helvetica 8 (outline)
563	//------------------------------------------------------------------------
564	procedure FindBestFontMatch( const FaceName: string;
565	const PointSize: longint;
566	const Attributes: TFontAttributes;
567	const FixedWidth: boolean;
568	var FontInfo: FONTMETRICS );
569	var
570	BestBitmapFontMatch: TLogicalFont;
571	begin
572	// First just ask GPI to give us a font
573	AskOS2FontDetails( FaceName,
574	PointSize,
575	Attributes,
576	FontInfo );
577
578	if not FixedWidth then
579	// OK, whatever it gave us.
580	exit;
581
582	// we want a fixed width font...
583	if ( FontInfo.fsType and FM_TYPE_FIXED ) <> 0 then
584	// got a suitable font
585	exit;
586
587	// the stoopid freaking OS/2 GPI has given us
588	// a proportional font for that size
589	if DefaultOutlineFixedFace <> nil then
590	// use the default fixed width outline face
591	AskOS2FontDetails( DefaultOutlineFixedFace.pName^,
592	PointSize,
593	Attributes,
594	FontInfo );
595
596
597	if ( FontInfo.fsType and FM_TYPE_FIXED ) <> 0 then
598	// got a suitable font
599	exit;
600
601	// still got a proportional font,
602	// or we didn't have any fixed width outline face
603	// so see what we can find in the way of a bitmap fixed font
604
605	BestBitmapFontMatch := GetClosestBitmapFixedFont( PointSize );
606	if BestBitmapFontMatch <> nil then
607	begin
608	FontInfo.lMaxbaseLineExt := BestBitmapFontMatch.lMaxbaselineExt;
609	FontInfo.lAveCharWidth := BestBitmapFontMatch.lAveCharWidth;
610	FontInfo.fsDefn := 0;
611	FontInfo.szFaceName := BestBitmapFontMatch.pFaceName^;
612	end;
613	// else - there are no fixed fonts of any kind on the system. Oh dear.
614
615	end;
616
617	//------------------------------------------------------------------------
618	// Font manager
619	//------------------------------------------------------------------------
620
621	// constructor
622	//------------------------------------------------------------------------
623	constructor TCanvasFontManager.Create( Canvas: TCanvas;
624	AllowBitmapFonts: boolean );
625	begin
626	inherited Create;
627
628	if FontFaces = nil then
629	GetFontList;
630
631	FCanvas := Canvas;
632	FLogicalFonts := TList.Create;
633	FCurrentFontSpec.FaceName := 'notafont';
634	FCurrentFont := nil;
635	FAllowBitmapFonts := AllowBitmapFonts;
636
637	// get system default font spec
638	// as default default ;)
639	SibylFontToFontSpec( Screen.DefaultFont,
640	FDefaultFontSpec );
641
642	end;
643
644	// Destructor
645	//------------------------------------------------------------------------
646	destructor TCanvasFontManager.Destroy;
647	var
648	i: integer;
649	Font: TLogicalFont;
650	rc: ERRORID;
651	begin
652	// select default font so none of our logical fonts are in use
653	if not GpiSetCharSet( FCanvas.Handle, LCID_DEFAULT ) then
654	rc := WinGetLastError( AppHandle );
655
656	// delete each logical font and our record of it
657	for i := 0 to FLogicalFonts.Count - 1 do
658	begin
659	Font := FLogicalFonts[ i ];
660	if not GpiDeleteSetID( FCanvas.Handle, Font.ID ) then
661	rc := WinGetLastError( AppHandle );
662	Font.Destroy;
663	end;
664	FLogicalFonts.Destroy;
665	inherited Destroy;
666	end;
667
668	// Create a logical font for the given spec
669	//------------------------------------------------------------------------
670	function TCanvasFontManager.CreateFont( const FontSpec: TFontSpec ): TLogicalFont;
671	var
672	UseFaceName: string;
673	Face: TFontFace;
674	RemoveBoldFromSelection: boolean;
675	RemoveItalicFromSelection: boolean;
676	UseAttributes: TFontAttributes;
677	MatchAttributes: TFontAttributes;
678	BaseFont: TLogicalFont;
679	BaseFontIsBitmapFont: Boolean;
680	FontInfo: FONTMETRICS;
681	FixedWidth: boolean;
682	begin
683	Face := nil;
684	RemoveBoldFromSelection := false;
685	RemoveItalicFromSelection := false;
686
687	UseAttributes := FontSpec.Attributes;
688
689	// see if the originally specified font is a fixed width one.
690	FixedWidth := false;
691	Face := FindFaceName( FontSpec.FaceName );
692	if Face <> nil then
693	FixedWidth := Face.FixedWidth;
694
695	Face := nil;
696
697	if not FAllowBitmapFonts then
698	UseFaceName := SubstituteBitmapFontToOutline( FontSpec.FaceName )
699	else
700	UseFaceName := FontSpec.FaceName;
701
702	if FontSpec.Attributes <> [] then
703	begin
704	BaseFontIsBitmapFont := false;
705	if FAllowBitmapFonts then
706	begin
707	// First see if the base font (without attributes)
708	// would be a bitmap font...
709	BaseFont := CreateFontBasic( UseFaceName, FontSpec.PointSize );
710	if BaseFont <> nil then
711	begin
712	BaseFontIsBitmapFont := BaseFont.FontType = ftBitmap;
713	BaseFont.Destroy;
714	end;
715	end;
716
717	If not BaseFontIsBitmapFont Then
718	begin
719	// Result is an outline font so look for specific bold/italic fonts
720	if ( faBold in FontSpec.Attributes )
721	and ( faItalic in FontSpec.Attributes ) then
722	begin
723	Face := FindFaceName( UseFaceName + ' BOLD ITALIC' );
724	if Face <> nil then
725	begin
726	Exclude( UseAttributes, faBold );
727	Exclude( UseAttributes, faItalic );
728	RemoveBoldFromSelection := true;
729	RemoveItalicFromSelection := true;
730	end;
731	end;
732
733	if Face = nil then
734	if faBold in FontSpec.Attributes then
735	begin
736	Face := FindFaceName( UseFaceName + ' BOLD' );
737	if Face <> nil then
738	begin
739	Exclude( UseAttributes, faBold );
740	RemoveBoldFromSelection := true;
741	end;
742	end;
743
744	if Face = nil then
745	if faItalic in FontSpec.Attributes then
746	begin
747	Face := FindFaceName( UseFaceName + ' ITALIC' );
748	if Face <> nil then
749	begin
750	Exclude( UseAttributes, faItalic );
751	RemoveItalicFromSelection := true;
752	end;
753	end;
754	end;
755	end;
756
757	if Face <> nil then
758	// found a styled face, does it match fixed width?
759	if Face.FixedWidth <> FixedWidth then
760	// no so we don't want to use it.
761	Face := nil;
762
763	if Face = nil then
764	// didn't find a styled face (or no styles set)
765	// so find unmodified, we will use simulation bits
766	Face := FindFaceName( UseFaceName );
767
768	if not FAllowBitmapFonts then
769	if Face.FontType = ftBitmap then
770	// we aren't allowed bitmaps, but that's what this
771	// face is. So use the default outline face of the
772	// appropriate width type
773	if FixedWidth then
774	Face := DefaultOutlineFixedFace
775	else
776	Face := DefaultOutlineProportionalFace;
777
778	if Face = nil then
779	begin
780	// Could not find the specified font name. Bummer.
781	Result := nil;
782	exit;
783	end;
784
785	// OK now we have found the font face...
786
787	Result := TLogicalFont.Create( nil );
788
789	Result.PointSize := FontSpec.PointSize; // will use later if the result was an outline font...
790	Result.pFaceName := NewStr( FontSpec.FaceName );
791	Result.pUseFaceName := NewStr( Face.pName^ );
792	Result.Attributes := FontSpec.Attributes;
793
794	Result.fsSelection := 0;
795
796	Result.FixedWidth := Face.FixedWidth;
797
798	if FAllowBitmapFonts then
799	begin
800	if BaseFontIsBitmapFont then
801	MatchAttributes := []
802	else
803	MatchAttributes := UseAttributes;
804	FindBestFontMatch( Face.pName^,
805	FontSpec.PointSize,
806	MatchAttributes,
807	FixedWidth,
808	FontInfo );
809
810	AssignStr( Result.pUseFaceName, FontInfo.szFaceName );
811
812	// We may actually get a bitmap OR an outline font back
813	If ( FontInfo.fsDefn And FM_DEFN_OUTLINE ) <> 0 Then
814	Result.FontType := ftOutline
815	else
816	Result.FontType := ftBitmap;
817	end
818	else
819	begin
820	// no bitmap fonts please.
821	Result.FontType := ftOutline
822	end;
823
824	// store the baseline and average char width.
825	// For bitmap fonts, these tell GPI which font we really want
826	// For outline fonts, we are just storing them for later ref.
827	Result.lMaxbaseLineExt := FontInfo.lMaxbaselineExt;
828	Result.lAveCharWidth := FontInfo.lAveCharWidth;
829	Result.lMaxCharInc := FontInfo.lMaxCharInc;
830	Result.lEmInc := FontInfo.lEmInc;
831
832	// Set style flags
833	with Result do
834	begin
835	If faBold in UseAttributes Then
836	fsSelection := fsSelection or FM_SEL_BOLD;
837	If faItalic in UseAttributes Then
838	fsSelection := fsSelection or FM_SEL_ITALIC;
839	If faUnderScore in UseAttributes Then
840	fsSelection := fsSelection or FM_SEl_UNDERSCORE;
841	If faStrikeOut in UseAttributes Then
842	fsSelection := fsSelection or FM_SEl_STRIKEOUT;
843	If faOutline in UseAttributes Then
844	fsSelection := fsSelection or FM_SEl_OUTlINE;
845	end;
846
847	Result.pCharWidthArray := Nil;
848	end;
849
850	// Register the given logical font with GPI and store for later use
851	//------------------------------------------------------------------------
852	procedure TCanvasFontManager.RegisterFont( Font: TLogicalFont );
853	var
854	fa: FATTRS;
855	rc: LONG;
856	begin
857	FLogicalFonts.Add( Font );
858	Font.ID := FLogicalFonts.Count + 1; // add 1 to stay out of Sibyl's way
859
860	// Initialise GPI font attributes
861	FillChar( fa, SizeOf( FATTRS ), 0 );
862	fa.usRecordLength := SizeOf( FATTRS );
863
864	// Copy facename and 'simulation' attributes from what we obtained
865	// earlier
866	fa.szFaceName := Font.pUseFaceName^;
867	fa.fsSelection := Font.fsSelection;
868
869	fa.lMatch := 0; // please Mr GPI be helpful and do clever stuff for us, we are ignorant
870
871	fa.idRegistry := 0; // IBM magic number
872	fa.usCodePage := 0; // use current codepage
873
874	If Font.FontType = ftOutline then
875	// Outline font wanted
876	fa.fsFontUse := FATTR_FONTUSE_OUTLINE Or FATTR_FONTUSE_TRANSFORMABLE
877	else
878	// bitmap font
879	fa.fsFontUse := 0;
880
881	// don't need mixing with graphics (for now)
882	fa.fsFontUse := fa.fsFontUse or FATTR_FONTUSE_NOMIX;
883
884	// copy char cell width/height from the (valid) one we
885	// found earlier in GetFont (will be zero for outline)
886	fa.lMaxbaseLineExt := Font.lMaxbaselineExt;
887	fa.lAveCharWidth := Font.lAveCharWidth;
888
889	fa.fsType := 0;
890
891	// create logical font
892	rc := GpiCreateLogFont( FCanvas.Handle,
893	nil,
894	Font.ID,
895	fa );
896	end;
897
898	// Select the given (existing) logical font
899	//------------------------------------------------------------------------
900	procedure TCanvasFontManager.SelectFont( Font: TLogicalFont;
901	Scale: longint );
902	var
903	aHDC: HDC;
904	xRes: LongInt;
905	yRes: LongInt;
906	aSizeF: SIZEF;
907	begin
908	// Select the logical font
909	GpiSetCharSet( FCanvas.Handle, Font.ID );
910	if Font.FontType = ftOutline then
911	begin
912	// For outline fonts, also set character Box
913	aHDC := GpiQueryDevice( FCanvas.Handle );
914	DevQueryCaps( aHDC,
915	CAPS_HORIZONTAL_FONT_RES,
916	1,
917	xRes );
918	DevQueryCaps( aHDC,
919	CAPS_VERTICAL_FONT_RES,
920	1,
921	yRes );
922
923	aSizeF.CX := 65536 * xRes* Font.PointSize Div 72 * Scale;
924	aSizeF.CY := 65536 * yRes* Font.PointSize Div 72 * Scale;
925
926	GpiSetCharBox( FCanvas.Handle, aSizeF );
927	end;
928	end;
929
930	// Get a font to match the given spec, creating or re-using an
931	// existing font as needed.
932	//------------------------------------------------------------------------
933	function TCanvasFontManager.GetFont( const FontSpec: TFontSpec ): TLogicalFont;
934	var
935	AFont: TLogicalFont;
936	FontIndex: integer;
937	begin
938	for FontIndex := 0 to FLogicalFonts.Count - 1 do
939	begin
940	AFont := FLogicalFonts[ FontIndex ];
941	if AFont.PointSize = FontSpec.PointSize then
942	begin
943	if ( AFont.PointSize > 0 )
944	or ( ( AFont.lAveCharWidth = FontSpec.XSize )
945	and ( AFont.lMaxbaselineExt = FontSpec.YSize ) ) then
946	begin
947	if AFont.Attributes = FontSpec.Attributes then
948	begin
949	// search name last since it's the slowest thing
950	if AFont.pFaceName^ = FontSpec.FaceName then
951	begin
952	// Found a logical font already created
953	Result := AFont;
954	// done
955	exit;
956	end;
957	end;
958	end;
959	end;
960	end;
961
962	// Need to create new logical font
963	Result := CreateFont( FontSpec );
964	if Result <> nil then
965	begin
966	RegisterFont( Result );
967	end;
968	end;
969
970	// Set the current font for the canvas to match the given
971	// spec, creating or re-using fonts as needed.
972	//------------------------------------------------------------------------
973	procedure TCanvasFontManager.SetFont( const FontSpec: TFontSpec );
974	var
975	Font: TLogicalFont;
976	DefaultFontSpec: TFontSpec;
977	begin
978	if FCurrentFontSpec = FontSpec then
979	// same font
980	exit;
981
982	Font := GetFont( FontSpec );
983
984	if Font = nil then
985	begin
986	// ack! Pfffbt! Couldn't find the font.
987
988	// Try to get the default font
989	Font := GetFont( FDefaultFontSpec );
990	if Font = nil then
991	begin
992	SibylFontToFontSpec( Screen.DefaultFont,
993	DefaultFontSpec );
994	Font := GetFont( DefaultFontSpec );
995	if Font = nil then
996	// Jimminy! We can't even get the default system font
997	raise Exception.Create( 'Could not access default font '
998	+ 'in place of '
999	+ FontSpec.FaceName
1000	+ ' '
1001	+ IntToStr( FontSpec.PointSize ) );
1002	end;
1003
1004	end;
1005
1006	SelectFont( Font, 1 );
1007	FCurrentFontSpec := FontSpec;
1008	FCurrentFont := Font;
1009	end;
1010
1011	// Get the widths of all characters for current font
1012	// and other dimensions
1013	//------------------------------------------------------------------------
1014	procedure TCanvasFontManager.LoadMetrics;
1015	var
1016	TheChar: Char;
1017	fm: FONTMETRICS;
1018	begin
1019	// Retrieve all character widths
1020	if FCurrentFont.FontType = ftOutline then
1021	begin
1022	SelectFont( FCurrentFont, FontWidthPrecisionFactor );
1023	end;
1024
1025	// allocate memory for storing the char widths
1026	GetMem( FCurrentFont.pCharWidthArray,
1027	sizeof( TCharWidthArray ) );
1028	if not GpiQueryWidthTable( FCanvas.Handle,
1029	0, 256,
1030	FCurrentFont.pCharWidthArray^[ #0 ] ) then
1031	begin
1032	raise Exception.Create( 'Error getting character width table: '
1033	+ 'GpiQueryWidthTable error '
1034	+ IntToStr( WinGetLastError( AppHandle ) ) );
1035	end;
1036
1037	// Convert all widths to positive!
1038	// For unknown reason, sometimes GPI returns negative values...
1039	for TheChar := #0 to #255 do
1040	begin
1041	FCurrentFont.pCharWidthArray^[ TheChar ] := Abs( FCurrentFont.pCharWidthArray^[ TheChar ] );
1042	end;
1043
1044	if FCurrentFont.FontType = ftOutline then
1045	begin
1046	SelectFont( FCurrentFont, 1 );
1047	end
1048	else
1049	begin
1050	// For bitmap fonts, multiply by 256 manually
1051	for TheChar := #0 to #255 do
1052	begin
1053	FCurrentFont.pCharWidthArray^[ TheChar ] :=
1054	FCurrentFont.pCharWidthArray^[ TheChar ]
1055	* FontWidthPrecisionFactor;
1056	end;
1057	end;
1058
1059	GpiQueryFontMetrics( FCanvas.Handle,
1060	sizeof( fm ),
1061	fm );
1062	FCurrentFont.lMaxbaseLineExt := fm.lMaxbaselineExt;
1063	FCurrentFont.lAveCharWidth := fm.lAveCharWidth;
1064	FCurrentFont.lMaxCharInc := fm.lMaxCharInc;
1065	FCurrentFont.lMaxDescender := fm.lMaxDescender;
1066	FCurrentFont.lEmInc := fm.lEmInc;
1067	end;
1068
1069	procedure TCanvasFontManager.EnsureMetricsLoaded;
1070	begin
1071	if FCurrentFont = nil then
1072	raise( Exception.Create( 'No font selected before getting font metrics' ) );
1073
1074	if FCurrentFont.pCharWidthArray = Nil then
1075	LoadMetrics;
1076	end;
1077
1078	function TCanvasFontManager.CharWidth( const C: Char ): longint;
1079	begin
1080	EnsureMetricsLoaded;
1081	Result := FCurrentFont.pCharWidthArray^[ C ];
1082	end;
1083
1084	function TCanvasFontManager.AverageCharWidth: longint;
1085	begin
1086	EnsureMetricsLoaded;
1087	Result := FCurrentFont.lAveCharWidth;
1088	end;
1089
1090	function TCanvasFontManager.MaximumCharWidth: longint;
1091	begin
1092	EnsureMetricsLoaded;
1093	Result := FCurrentFont.lMaxCharInc;
1094	end;
1095
1096	function TCanvasFontManager.CharHeight;
1097	begin
1098	EnsureMetricsLoaded;
1099	Result := FCurrentFont.lMaxBaseLineExt;
1100	end;
1101
1102	function TCanvasFontManager.CharDescender;
1103	begin
1104	EnsureMetricsLoaded;
1105	Result := FCurrentFont.lMaxDescender;
1106	end;
1107
1108	function TCanvasFontManager.IsFixed: boolean;
1109	begin
1110	Result := FCurrentFont.FixedWidth;
1111	end;
1112
1113	// ALT begins
1114	//
1115	// A 'default' average width for DBCS characters; probably not very accurate.
1116	// Should only be used as a fallback in case querying the actual string width
1117	// is impossible/fails.
1118	//
1119	function TCanvasFontManager.CJKCharWidth: longint;
1120	begin
1121	EnsureMetricsLoaded;
1122	if FCurrentFont.lMaxCharInc < FCurrentFont.lEmInc then
1123	Result := FCurrentFont.lMaxCharInc * FontWidthPrecisionFactor
1124	else
1125	Result := FCurrentFont.lEmInc * FontWidthPrecisionFactor;
1126	end;
1127
1128	// Get the render width of a CJK (Chinese/Japanese/Korean) character string.
1129	//
1130	function TCanvasFontManager.CJKTextWidth( const Length: longint; const S: PChar ): longint;
1131	var
1132	aptl: Array[ 0..TXTBOX_COUNT-1 ] Of PointL;
1133	begin
1134	EnsureMetricsLoaded;
1135	GpiQueryTextBox( FCanvas.Handle, Length, S^, TXTBOX_COUNT, aptl[0] );
1136	Result := aptl[ TXTBOX_CONCAT ].x * FontWidthPrecisionFactor;
1137	end;
1138	//
1139	// ALT ends
1140
1141	procedure TCanvasFontManager.DrawString( Var Point: TPoint;
1142	const Length: longint;
1143	const S: PChar );
1144	begin
1145	GpiCharStringAt( FCanvas.Handle,
1146	Point,
1147	Length,
1148	S^ );
1149	Point := FCanvas.PenPos;
1150	end;
1151
1152	end.

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/Components/CanvasFontManager.pas

Download in other formats: