opengl
/
TextSuite
1
0
Форкнуть 0
Код Задачи 0 Pull Request'ы 0 Релизы 0 Вики Активность
Просмотр исходного кода

* implemented main functionality

master
Bergmann89 11 лет назад
Родитель
a226a7e15b
Сommit
0de77cede4
18 измененных файлов: 2880 добавлений и 818 удалений
Разделённый вид
Опции Diff
Показать статистику Скачать Patch файл Скачать Diff файл
  1. +29
    -2
      TextSuiteTest.lpi
  2. +3
    -2
      TextSuiteTest.lpr
  3. +287
    -141
      TextSuiteTest.lps
  4. +918
    -0
      new/utsFontCreatorGDI.pas
  5. +521
    -0
      new/utsRendererOpenGL.pas
  6. +291
    -649
      new/utsTextSuite.pas
  7. +323
    -0
      new/utsTtfUtils.pas
  8. +304
    -0
      new/utsTypes.pas
  9. +144
    -0
      new/utsUtils.pas
  10. +1
    -1
      old/TextSuiteClasses.pas
  11. Двоичные данные
     
  12. Двоичные данные
     
  13. Двоичные данные
     
  14. Двоичные данные
     
  15. Двоичные данные
     
  16. Двоичные данные
     
  17. +1
    -0
      uMainForm.lfm
  18. +58
    -23
      uMainForm.pas

+ 29
- 2
TextSuiteTest.lpi Просмотреть файл

@@ -33,7 +33,7 @@
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="10">
<Units Count="15">
<Unit0>
<Filename Value="TextSuiteTest.lpr"/>
<IsPartOfProject Value="True"/>
@@ -59,6 +59,7 @@
<Unit4>
<Filename Value="old\TextSuiteImports.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TextSuiteImports"/>
</Unit4>
<Unit5>
<Filename Value="old\TextSuiteWideUtils.pas"/>
@@ -77,11 +78,34 @@
<Unit8>
<Filename Value="old\TextSuiteTTFUtils.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TextSuiteTTFUtils"/>
</Unit8>
<Unit9>
<Filename Value="old\TextSuiteVersion.pas"/>
<IsPartOfProject Value="True"/>
</Unit9>
<Unit10>
<Filename Value="new\utsFontCreatorGDI.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="utsFontCreatorGDI"/>
</Unit10>
<Unit11>
<Filename Value="new\utsTtfUtils.pas"/>
<IsPartOfProject Value="True"/>
</Unit11>
<Unit12>
<Filename Value="new\utsTypes.pas"/>
<IsPartOfProject Value="True"/>
</Unit12>
<Unit13>
<Filename Value="new\utsUtils.pas"/>
<IsPartOfProject Value="True"/>
</Unit13>
<Unit14>
<Filename Value="new\utsRendererOpenGL.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="utsRendererOpenGL"/>
</Unit14>
</Units>
</ProjectOptions>
<CompilerOptions>
@@ -92,10 +116,13 @@
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir);old"/>
<OtherUnitFiles Value="old;..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore;new"/>
<OtherUnitFiles Value="old;new;..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseHeaptrc Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>


+ 3
- 2
TextSuiteTest.lpr Просмотреть файл

@@ -7,8 +7,9 @@ uses
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, uMainForm, TextSuite, TextSuiteClasses, TextSuiteImports, TextSuitePostProcess,
TextSuiteTTFUtils, TextSuiteVersion, TextSuiteWideUtils, utsTextSuite;
Forms, uMainForm, TextSuite, TextSuiteClasses, TextSuiteImports, TextSuitePostProcess, TextSuiteTTFUtils,
TextSuiteVersion, TextSuiteWideUtils, utsTextSuite, utsFontCreatorGDI, utsTtfUtils, utsTypes, utsUtils,
utsRendererOpenGL;

{$R *.res}



+ 287
- 141
TextSuiteTest.lps Просмотреть файл

@@ -4,13 +4,13 @@
<PathDelim Value="\"/>
<Version Value="9"/>
<BuildModes Active="Default"/>
<Units Count="19">
<Units Count="42">
<Unit0>
<Filename Value="TextSuiteTest.lpr"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos X="45" Y="17"/>
<UsageCount Value="60"/>
<UsageCount Value="92"/>
</Unit0>
<Unit1>
<Filename Value="uMainForm.pas"/>
@@ -19,9 +19,9 @@
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="uMainForm"/>
<TopLine Value="79"/>
<CursorPos Y="97"/>
<UsageCount Value="60"/>
<IsVisibleTab Value="True"/>
<CursorPos X="3" Y="5"/>
<UsageCount Value="92"/>
<Loaded Value="True"/>
<LoadedDesigner Value="True"/>
</Unit1>
@@ -29,58 +29,59 @@
<Filename Value="new\utsTextSuite.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="utsTextSuite"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="2"/>
<TopLine Value="1988"/>
<CursorPos X="22" Y="2002"/>
<UsageCount Value="59"/>
<TopLine Value="1886"/>
<CursorPos X="33" Y="1904"/>
<UsageCount Value="91"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="old\TextSuite.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TextSuite"/>
<EditorIndex Value="1"/>
<EditorIndex Value="6"/>
<WindowIndex Value="1"/>
<TopLine Value="207"/>
<CursorPos X="3" Y="223"/>
<TopLine Value="391"/>
<CursorPos X="13" Y="408"/>
<ExtraEditorCount Value="1"/>
<ExtraEditor1>
<EditorIndex Value="-1"/>
<TopLine Value="232"/>
<CursorPos X="3" Y="302"/>
</ExtraEditor1>
<UsageCount Value="54"/>
<UsageCount Value="86"/>
<Loaded Value="True"/>
</Unit3>
<Unit4>
<Filename Value="old\TextSuiteImports.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="662"/>
<CursorPos X="3" Y="664"/>
<UsageCount Value="54"/>
<UnitName Value="TextSuiteImports"/>
<EditorIndex Value="5"/>
<WindowIndex Value="1"/>
<TopLine Value="656"/>
<CursorPos X="20" Y="635"/>
<UsageCount Value="86"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="old\TextSuiteWideUtils.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TextSuiteWideUtils"/>
<EditorIndex Value="2"/>
<EditorIndex Value="7"/>
<WindowIndex Value="1"/>
<TopLine Value="1243"/>
<CursorPos X="18" Y="1257"/>
<UsageCount Value="54"/>
<UsageCount Value="86"/>
<Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="old\TextSuiteClasses.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TextSuiteClasses"/>
<IsVisibleTab Value="True"/>
<WindowIndex Value="1"/>
<TopLine Value="4487"/>
<CursorPos X="28" Y="4439"/>
<UsageCount Value="54"/>
<TopLine Value="654"/>
<CursorPos X="25" Y="673"/>
<UsageCount Value="86"/>
<Loaded Value="True"/>
</Unit6>
<Unit7>
@@ -90,16 +91,18 @@
<WindowIndex Value="1"/>
<TopLine Value="163"/>
<CursorPos X="61" Y="141"/>
<UsageCount Value="54"/>
<UsageCount Value="86"/>
</Unit7>
<Unit8>
<Filename Value="old\TextSuiteTTFUtils.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="54"/>
<UnitName Value="TextSuiteTTFUtils"/>
<EditorIndex Value="4"/>
<WindowIndex Value="1"/>
<TopLine Value="83"/>
<CursorPos X="3" Y="91"/>
<UsageCount Value="86"/>
<Loaded Value="True"/>
</Unit8>
<Unit9>
<Filename Value="old\TextSuiteVersion.pas"/>
@@ -108,243 +111,386 @@
<WindowIndex Value="-1"/>
<TopLine Value="-1"/>
<CursorPos X="-1" Y="-1"/>
<UsageCount Value="54"/>
<UsageCount Value="86"/>
</Unit9>
<Unit10>
<Filename Value="..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore\uglcTypes.pas"/>
<UnitName Value="uglcTypes"/>
<EditorIndex Value="1"/>
<TopLine Value="264"/>
<CursorPos X="3" Y="273"/>
<UsageCount Value="30"/>
<Filename Value="new\utsFontCreatorGDI.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="utsFontCreatorGDI"/>
<EditorIndex Value="4"/>
<TopLine Value="655"/>
<CursorPos X="53" Y="662"/>
<UsageCount Value="50"/>
<Loaded Value="True"/>
</Unit10>
<Unit11>
<Filename Value="..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore\dglOpenGL.pas"/>
<UnitName Value="dglOpenGL"/>
<EditorIndex Value="5"/>
<TopLine Value="11398"/>
<CursorPos X="3" Y="11232"/>
<UsageCount Value="30"/>
<Loaded Value="True"/>
<Filename Value="new\utsTtfUtils.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<TopLine Value="128"/>
<CursorPos X="17" Y="144"/>
<UsageCount Value="42"/>
</Unit11>
<Unit12>
<Filename Value="new\uglctextsuite.pas"/>
<Filename Value="new\utsTypes.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos X="3" Y="13"/>
<UsageCount Value="15"/>
<TopLine Value="152"/>
<CursorPos X="5" Y="168"/>
<UsageCount Value="42"/>
</Unit12>
<Unit13>
<Filename Value="new\utsUtils.pas"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="-1"/>
<CursorPos Y="20"/>
<UsageCount Value="42"/>
</Unit13>
<Unit14>
<Filename Value="new\utsRendererOpenGL.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="utsRendererOpenGL"/>
<EditorIndex Value="3"/>
<TopLine Value="356"/>
<CursorPos X="20" Y="376"/>
<UsageCount Value="39"/>
<Loaded Value="True"/>
</Unit14>
<Unit15>
<Filename Value="..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore\uglcTypes.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="261"/>
<CursorPos X="3" Y="277"/>
<UsageCount Value="37"/>
</Unit15>
<Unit16>
<Filename Value="..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore\dglOpenGL.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="1066"/>
<CursorPos X="27" Y="1082"/>
<UsageCount Value="32"/>
</Unit16>
<Unit17>
<Filename Value="new\uglctextsuite.pas"/>
<EditorIndex Value="-1"/>
<CursorPos X="3" Y="13"/>
<UsageCount Value="13"/>
</Unit17>
<Unit18>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\ustringh.inc"/>
<EditorIndex Value="4"/>
<EditorIndex Value="-1"/>
<TopLine Value="110"/>
<CursorPos X="10" Y="126"/>
<UsageCount Value="28"/>
<Loaded Value="True"/>
</Unit13>
<Unit14>
<UsageCount Value="27"/>
</Unit18>
<Unit19>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\ustrings.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="1819"/>
<CursorPos X="37" Y="2066"/>
<UsageCount Value="6"/>
</Unit14>
<Unit15>
<UsageCount Value="4"/>
</Unit19>
<Unit20>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\systemh.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="756"/>
<CursorPos X="32" Y="774"/>
<UsageCount Value="27"/>
</Unit15>
<Unit16>
<UsageCount Value="25"/>
</Unit20>
<Unit21>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\heaph.inc"/>
<EditorIndex Value="3"/>
<TopLine Value="69"/>
<CursorPos X="10" Y="94"/>
<UsageCount Value="27"/>
<Loaded Value="True"/>
</Unit16>
<Unit17>
<EditorIndex Value="-1"/>
<TopLine Value="71"/>
<CursorPos X="10" Y="95"/>
<UsageCount Value="26"/>
</Unit21>
<Unit22>
<Filename Value="old\TextSuiteCPUUtils.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<CursorPos X="23" Y="20"/>
<UsageCount Value="18"/>
</Unit17>
<Unit18>
<UsageCount Value="16"/>
</Unit22>
<Unit23>
<Filename Value="..\glBitmap\glBitmap\glBitmap.pas"/>
<EditorIndex Value="-1"/>
<CursorPos X="14" Y="14"/>
<UsageCount Value="6"/>
</Unit18>
<UsageCount Value="4"/>
</Unit23>
<Unit24>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\objpas\math.pp"/>
<EditorIndex Value="-1"/>
<TopLine Value="1011"/>
<CursorPos X="47" Y="1015"/>
<UsageCount Value="8"/>
</Unit24>
<Unit25>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\mathh.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="84"/>
<CursorPos X="14" Y="101"/>
<UsageCount Value="8"/>
</Unit25>
<Unit26>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\genmath.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="152"/>
<CursorPos X="10" Y="155"/>
<UsageCount Value="8"/>
</Unit26>
<Unit27>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\dynlibs.pas"/>
<EditorIndex Value="-1"/>
<TopLine Value="41"/>
<CursorPos X="10" Y="58"/>
<UsageCount Value="13"/>
</Unit27>
<Unit28>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\win\dynlibs.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="9"/>
<CursorPos X="3" Y="26"/>
<UsageCount Value="13"/>
</Unit28>
<Unit29>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\win\sysosh.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="11"/>
<CursorPos X="3" Y="19"/>
<UsageCount Value="13"/>
</Unit29>
<Unit30>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\objpash.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="177"/>
<CursorPos X="22" Y="195"/>
<UsageCount Value="17"/>
</Unit30>
<Unit31>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\objpas\sysutils\sysunih.inc"/>
<EditorIndex Value="3"/>
<WindowIndex Value="1"/>
<TopLine Value="25"/>
<CursorPos X="34" Y="43"/>
<UsageCount Value="21"/>
<Loaded Value="True"/>
</Unit31>
<Unit32>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\packages\fcl-base\src\syncobjs.pp"/>
<EditorIndex Value="-1"/>
<TopLine Value="113"/>
<CursorPos X="25" Y="115"/>
<UsageCount Value="18"/>
</Unit32>
<Unit33>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\objpas\classes\classesh.inc"/>
<EditorIndex Value="1"/>
<WindowIndex Value="1"/>
<TopLine Value="311"/>
<CursorPos X="14" Y="327"/>
<UsageCount Value="18"/>
<Loaded Value="True"/>
</Unit33>
<Unit34>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\inc\objpas.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="516"/>
<CursorPos X="9" Y="525"/>
<UsageCount Value="16"/>
</Unit34>
<Unit35>
<Filename Value="C:\Zusatzprogramme\Lazarus\lcl\include\control.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="2843"/>
<CursorPos Y="2858"/>
<UsageCount Value="15"/>
</Unit35>
<Unit36>
<Filename Value="C:\Users\Erik\Desktop\RectPacking\unit1.pas"/>
<UnitName Value="Unit1"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="2"/>
<WindowIndex Value="1"/>
<TopLine Value="376"/>
<CursorPos X="7" Y="390"/>
<UsageCount Value="16"/>
<Loaded Value="True"/>
</Unit36>
<Unit37>
<Filename Value="..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore\uglcArrayBuffer.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="102"/>
<CursorPos X="37" Y="112"/>
<UsageCount Value="12"/>
</Unit37>
<Unit38>
<Filename Value="..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\OpenGLCore\uglcBitmap.pas"/>
<EditorIndex Value="-1"/>
<WindowIndex Value="1"/>
<TopLine Value="1047"/>
<CursorPos X="15" Y="1043"/>
<UsageCount Value="10"/>
</Unit38>
<Unit39>
<Filename Value="C:\Zusatzprogramme\Lazarus\fpc\2.7.1\source\rtl\objpas\objpas.pp"/>
<EditorIndex Value="-1"/>
<TopLine Value="19"/>
<CursorPos X="8" Y="35"/>
<UsageCount Value="10"/>
</Unit39>
<Unit40>
<Filename Value="C:\Zusatzprogramme\Lazarus\lcl\include\application.inc"/>
<EditorIndex Value="-1"/>
<TopLine Value="966"/>
<CursorPos Y="981"/>
<UsageCount Value="10"/>
</Unit40>
<Unit41>
<Filename Value="..\bitSpace\_projects\MassiveUniverseOnline\bitSpaceEngine\src\SpaceEngine\uengFrameLimiter.pas"/>
<UnitName Value="uengFrameLimiter"/>
<EditorIndex Value="1"/>
<TopLine Value="14"/>
<CursorPos X="13" Y="14"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit41>
</Units>
<JumpHistory Count="30" HistoryIndex="29">
<JumpHistory Count="30" HistoryIndex="28">
<Position1>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1979" TopLine="1967"/>
<Caret Line="1797" TopLine="1781"/>
</Position1>
<Position2>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1980" TopLine="1967"/>
<Caret Line="1683" TopLine="1657"/>
</Position2>
<Position3>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1981" TopLine="1967"/>
<Caret Line="1679" TopLine="1657"/>
</Position3>
<Position4>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1982" TopLine="1967"/>
<Caret Line="1680" TopLine="1657"/>
</Position4>
<Position5>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1983" TopLine="1967"/>
<Caret Line="1681" TopLine="1657"/>
</Position5>
<Position6>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1984" TopLine="1967"/>
<Caret Line="1683" TopLine="1658"/>
</Position6>
<Position7>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1987" TopLine="1967"/>
<Caret Line="1797" TopLine="1781"/>
</Position7>
<Position8>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2032" TopLine="2015"/>
<Caret Line="1799" TopLine="1781"/>
</Position8>
<Position9>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2037" TopLine="2015"/>
<Caret Line="1800" TopLine="1781"/>
</Position9>
<Position10>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1970" TopLine="1954"/>
<Caret Line="1801" TopLine="1781"/>
</Position10>
<Position11>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1973" TopLine="1954"/>
<Caret Line="1803" TopLine="1781"/>
</Position11>
<Position12>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1974" TopLine="1954"/>
<Caret Line="1804" TopLine="1781"/>
</Position12>
<Position13>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1975" TopLine="1967"/>
<Caret Line="1805" TopLine="1781"/>
</Position13>
<Position14>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1977" TopLine="1967"/>
<Caret Line="1679" TopLine="1663"/>
</Position14>
<Position15>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1991" TopLine="1967"/>
<Caret Line="1465" Column="3" TopLine="1460"/>
</Position15>
<Position16>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1995" TopLine="2008"/>
<Caret Line="288" Column="101" TopLine="274"/>
</Position16>
<Position17>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1997" TopLine="1982"/>
<Caret Line="1470" Column="28" TopLine="1459"/>
</Position17>
<Position18>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2008" TopLine="1982"/>
<Caret Line="1471" Column="73" TopLine="1459"/>
</Position18>
<Position19>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2054" TopLine="2037"/>
<Caret Line="1723" Column="29" TopLine="1713"/>
</Position19>
<Position20>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2032" TopLine="2016"/>
<Caret Line="1685" TopLine="1670"/>
</Position20>
<Position21>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2037" Column="36" TopLine="2013"/>
<Caret Line="1686" TopLine="1670"/>
</Position21>
<Position22>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2011" TopLine="1995"/>
<Caret Line="1687" TopLine="1670"/>
</Position22>
<Position23>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2032" TopLine="2016"/>
<Caret Line="1689" TopLine="1670"/>
</Position23>
<Position24>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1991" Column="51" TopLine="2005"/>
<Caret Line="1686" Column="20" TopLine="1670"/>
</Position24>
<Position25>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2011" TopLine="2006"/>
<Caret Line="290" Column="52" TopLine="281"/>
</Position25>
<Position26>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2034" TopLine="2012"/>
<Caret Line="1761" Column="23" TopLine="1742"/>
</Position26>
<Position27>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2035" TopLine="2012"/>
<Filename Value="uMainForm.pas"/>
<Caret Line="5" Column="2"/>
</Position27>
<Position28>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2051" TopLine="2035"/>
<Filename Value="uMainForm.pas"/>
<Caret Line="21" Column="18" TopLine="5"/>
</Position28>
<Position29>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="1993" Column="28" TopLine="1991"/>
<Filename Value="uMainForm.pas"/>
<Caret Line="57" Column="40" TopLine="50"/>
</Position29>
<Position30>
<Filename Value="new\utsTextSuite.pas"/>
<Caret Line="2011" TopLine="1990"/>
<Filename Value="uMainForm.pas"/>
<Caret Line="23" Column="21" TopLine="22"/>
</Position30>
</JumpHistory>
</ProjectSession>
<Debugging>
<BreakPoints Count="4">
<Item1>
<Kind Value="bpkSource"/>
<WatchScope Value="wpsLocal"/>
<WatchKind Value="wpkWrite"/>
<Source Value="new\utsTextSuite.pas"/>
<Line Value="2011"/>
</Item1>
<Item2>
<Kind Value="bpkSource"/>
<WatchScope Value="wpsLocal"/>
<WatchKind Value="wpkWrite"/>
<Source Value="new\utsTextSuite.pas"/>
<Line Value="2058"/>
</Item2>
<Item3>
<Kind Value="bpkSource"/>
<WatchScope Value="wpsLocal"/>
<WatchKind Value="wpkWrite"/>
<Source Value="new\utsTextSuite.pas"/>
<Line Value="2037"/>
</Item3>
<Item4>
<Kind Value="bpkSource"/>
<WatchScope Value="wpsLocal"/>
<WatchKind Value="wpkWrite"/>
<Source Value="new\utsTextSuite.pas"/>
<Line Value="1991"/>
</Item4>
</BreakPoints>
<Watches Count="4">
<Watches Count="3">
<Item1>
<Expression Value="Text"/>
<Expression Value="aItem"/>
</Item1>
<Item2>
<Expression Value="p^.Text"/>
<Expression Value="aItem^.children[0]"/>
</Item2>
<Item3>
<Expression Value="TextBegin"/>
<Expression Value="aItem^.children[1]"/>
</Item3>
<Item4>
<Expression Value="aText"/>
</Item4>
</Watches>
</Debugging>
</CONFIG>

+ 918
- 0
new/utsFontCreatorGDI.pas Просмотреть файл

@@ -0,0 +1,918 @@
unit utsFontCreatorGDI;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, syncobjs, dynlibs,
utsTextSuite, utsTypes;

type
HDC = Cardinal;

TFixed = packed record
fract: Word;
value: Smallint;
end;

TMat2 = packed record
eM11: TFixed;
eM12: TFixed;
eM21: TFixed;
eM22: TFixed;
end;
PMat2 = ^TMat2;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TtsFontGDI = class(TtsFont)
private
fHandle: THandle;
fMat2: TMat2;
protected
constructor Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator; const aProperties: TtsFontProperties; const aHandle: THandle);
public
destructor Destroy; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TtsFontRegistration = class(TObject)
protected
fIsRegistered: Boolean;
fFontname: String;
procedure UnregisterFont; virtual; abstract;
public
property IsRegistered: Boolean read fIsRegistered;
property Fontname: String read fFontname;

destructor Destroy; override;
end;

TtsFontRegistrationFile = class(TtsFontRegistration)
private
fFilename: String;
protected
procedure UnregisterFont; override;
public
constructor Create(const aFilename: String);
end;

TtsFontRegistrationStream = class(TtsFontRegistration)
private
fHandle: THandle;
protected
procedure UnregisterFont; override;
public
constructor Create(const aStream: TStream);
end;

TtsRegistredFontGDI = class(TtsFontGDI)
private
fRegistration: TtsFontRegistration;
public
constructor Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator;
const aRegistration: TtsFontRegistration; const aProperties: TtsFontProperties; const aHandle: THandle);
destructor Destroy; override;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
TtsFontGeneratorGDI = class(TtsFontGenerator)
private
function ConvertFont(const aFont: TtsFont): TtsFontGDI;
function GetGlyphIndex(const aFont: TtsFontGDI; const aCharCode: WideChar): Integer;
procedure GetCharImageAANone(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);
procedure GetCharImageAANormal(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);

function CreateFont(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing; out aProperties: TtsFontProperties): THandle;
protected
function GetGlyphMetrics(const aFont: TtsFont; const aCharCode: WideChar; out aGlyphOrigin, aGlyphSize: TtsPosition; out aAdvance: Integer): Boolean; override;
procedure GetCharImage(const aFont: TtsFont; const aCharCode: WideChar; const aCharImage: TtsImage); override;
public
function GetFontByName(const aFontname: String; const aRenderer: TtsRenderer; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload;
function GetFontByFile(const aFilename: String; const aRenderer: TtsRenderer; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload;
function GetFontByStream(const aStream: TStream; const aRenderer: TtsRenderer; const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont; overload;

constructor Create;
destructor Destroy; override;
end;

implementation

uses
math, utsTtfUtils;

const
LIB_GDI32 = 'gdi32.dll';
LIB_KERNEL32 = 'kernel32.dll';

GDI_ERROR = DWORD($FFFFFFFF);

FW_NORMAL = 400;
FW_BOLD = 700;

DEFAULT_CHARSET = 1;

NONANTIALIASED_QUALITY = 3;
ANTIALIASED_QUALITY = 4;

GGO_METRICS = 0;
GGO_BITMAP = 1;
GGO_GRAY8_BITMAP = 6;
GGO_GLYPH_INDEX = $80;

FR_PRIVATE = $10;
FR_NOT_ENUM = $20;

LOCALE_USER_DEFAULT = $0400;
LOCALE_ILANGUAGE = $1;

GCP_MAXEXTENT = $100000;

TMPF_FIXED_PITCH = 1;

type
HFONT = Cardinal;
HGDIOBJ = Cardinal;

TLogFontA = record
lfHeight: Longint;
lfWidth: Longint;
lfEscapement: Longint;
lfOrientation: Longint;
lfWeight: Longint;
lfItalic: Byte;
lfUnderline: Byte;
lfStrikeOut: Byte;
lfCharSet: Byte;
lfOutPrecision: Byte;
lfClipPrecision: Byte;
lfQuality: Byte;
lfPitchAndFamily: Byte;
lfFaceName: array[0..31] of AnsiChar;
end;
PLogFontA = ^TLogFontA;

TTextMetricW = record
tmHeight: Longint;
tmAscent: Longint;
tmDescent: Longint;
tmInternalLeading: Longint;
tmExternalLeading: Longint;
tmAveCharWidth: Longint;
tmMaxCharWidth: Longint;
tmWeight: Longint;
tmOverhang: Longint;
tmDigitizedAspectX: Longint;
tmDigitizedAspectY: Longint;
tmFirstChar: WideChar;
tmLastChar: WideChar;
tmDefaultChar: WideChar;
tmBreakChar: WideChar;
tmItalic: Byte;
tmUnderlined: Byte;
tmStruckOut: Byte;
tmPitchAndFamily: Byte;
tmCharSet: Byte;
end;
PTextMetricW = ^TTextMetricW;

TGlyphMetrics = record
gmBlackBoxX: Cardinal;
gmBlackBoxY: Cardinal;
gmptGlyphOrigin: TtsPosition;
gmCellIncX: Smallint;
gmCellIncY: Smallint;
end;
PGlyphMetrics = ^TGlyphMetrics;

TGCPResultsW = record
lStructSize: DWORD;
lpOutString: PWideChar;
lpOrder: PDWORD;
lpDx: PInteger;
lpCaretPos: PInteger;
lpClass: PChar;
lpGlyphs: PCardinal;
nGlyphs: Cardinal;
nMaxFit: Cardinal;
end;
PGCPResultsW = ^TGCPResultsW;

TPanose = record
bFamilyType: Byte;
bSerifStyle: Byte;
bWeight: Byte;
bProportion: Byte;
bContrast: Byte;
bStrokeVariation: Byte;
bArmStyle: Byte;
bLetterform: Byte;
bMidline: Byte;
bXHeight: Byte;
end;
PPanose = ^TPanose;

TOutlineTextmetricW = record
otmSize: LongWord;
otmTextMetrics: TTextMetricW;
otmFiller: Byte;
otmPanoseNumber: TPanose;
otmfsSelection: LongWord;
otmfsType: LongWord;
otmsCharSlopeRise: Integer;
otmsCharSlopeRun: Integer;
otmItalicAngle: Integer;
otmEMSquare: LongWord;
otmAscent: Integer;
otmDescent: Integer;
otmLineGap: LongWord;
otmsCapEmHeight: LongWord;
otmsXHeight: LongWord;
otmrcFontBox: TtsRect;
otmMacAscent: Integer;
otmMacDescent: Integer;
otmMacLineGap: LongWord;
otmusMinimumPPEM: LongWord;
otmptSubscriptSize: TtsPosition;
otmptSubscriptOffset: TtsPosition;
otmptSuperscriptSize: TtsPosition;
otmptSuperscriptOffset: TtsPosition;
otmsStrikeoutSize: LongWord;
otmsStrikeoutPosition: Integer;
otmsUnderscoreSize: Integer;
otmsUnderscorePosition: Integer;
otmpFamilyName: PWideChar;
otmpFaceName: PWideChar;
otmpStyleName: PWideChar;
otmpFullName: PWideChar;
end;
POutlineTextmetricW = ^TOutlineTextmetricW;

TCreateFontIndirectA = function (const p1: TLogFontA): HFONT; stdcall;

TAddFontResourceA = function(Filename: PAnsiChar): Integer; stdcall;
TAddFontResourceExA = function(Filename: PAnsiChar; Flag: DWORD; pdv: Pointer): Integer; stdcall;
TAddFontMemResourceEx = function(pbFont: Pointer; cbFont: DWORD; pdv: Pointer; pcFonts: PDWORD): THandle; stdcall;
TRemoveFontResourceA = function(Filename: PAnsiChar): Boolean; stdcall;
TRemoveFontResourceExA = function(filename: PAnsiChar; Flag: DWORD; pdv: Pointer): Boolean; stdcall;
TRemoveFontMemResourceEx = function(fh: THandle): Boolean; stdcall;

TGetTextMetricsW = function(DC: HDC; var TM: TTextMetricW): Boolean; stdcall;
TGetGlyphOutlineA = function(DC: HDC; uChar, uFormat: Cardinal; lpgm: PGlyphMetrics; cbBuffer: DWORD; lpvBuffer: Pointer; lpmat2: PMat2): DWORD; stdcall;

TGetCharacterPlacementW = function(DC: HDC; Str: PWideChar; Count, MaxExtent: Integer; Result: PGCPResultsW; Flags: DWORD): DWORD; stdcall;
TGetFontData = function(DC: HDC; TableName, Offset: DWORD; Buffer: Pointer; Data: DWORD): DWORD; stdcall;

TCreateCompatibleDC = function(DC: HDC): HDC; stdcall;
TDeleteDC = function(DC: HDC): Boolean; stdcall;
TSelectObject = function(DC: HDC; p2: HGDIOBJ): HGDIOBJ; stdcall;
TDeleteObject = function(p1: HGDIOBJ): Boolean; stdcall;

TGetOutlineTextMetricsW = function(DC: HDC; p2: LongWord; var OTMetricStructs: TOutlineTextmetricW): LongWord; stdcall;

TGetLocaleInfoA = function(Locale: DWORD; LCType: DWORD; lpLCData: pAnsiChar; cchData: Integer): Integer; stdcall;

var
gdiRefCount: Integer;
gdiCritSec: TCriticalSection;
gdiInitialized: Boolean;
gdiLibHandle: TLibHandle = 0;
kernel32LibHandle: TLibHandle = 0;

CreateFontIndirectA: TCreateFontIndirectA;
AddFontResourceA: TAddFontResourceA;
AddFontResourceExA: TAddFontResourceExA;
AddFontMemResourceEx: TAddFontMemResourceEx;
RemoveFontResourceA: TRemoveFontResourceA;
RemoveFontResourceExA: TRemoveFontResourceExA;
RemoveFontMemResourceEx: TRemoveFontMemResourceEx;
GetTextMetricsW: TGetTextMetricsW;
GetGlyphOutlineA: TGetGlyphOutlineA;
GetCharacterPlacementW: TGetCharacterPlacementW;
GetFontData: TGetFontData;
CreateCompatibleDC: TCreateCompatibleDC;
DeleteDC: TDeleteDC;
SelectObject: TSelectObject;
DeleteObject: TDeleteObject;
GetOutlineTextMetricsW: TGetOutlineTextMetricsW;

GetLocaleInfoA: TGetLocaleInfoA;

procedure InitGDI;

function GetProcAddr(const aLibHandle: TLibHandle; const aName: String): Pointer;
begin
result := GetProcAddress(aLibHandle, aName);
if not Assigned(result) then
raise EtsException.Create('unable to load procedure from library: ' + aName);
end;

begin
try
if (gdiLibHandle = 0) then begin
gdiLibHandle := LoadLibrary(LIB_GDI32);
if (gdiLibHandle = 0) then
raise EtsException.Create('unable to load gdi lib: ' + LIB_GDI32);
end;

if (kernel32LibHandle = 0) then begin
kernel32LibHandle := LoadLibrary(LIB_KERNEL32);
if (kernel32LibHandle = 0) then
raise EtsException.Create('unable to load kernel lib: ' + LIB_KERNEL32);
end;

CreateFontIndirectA := TCreateFontIndirectA( GetProcAddr(gdiLibHandle, 'CreateFontIndirectA'));
AddFontResourceA := TAddFontResourceA( GetProcAddr(gdiLibHandle, 'AddFontResourceA'));
AddFontResourceExA := TAddFontResourceExA( GetProcAddr(gdiLibHandle, 'AddFontResourceExA'));
AddFontMemResourceEx := TAddFontMemResourceEx( GetProcAddr(gdiLibHandle, 'AddFontMemResourceEx'));
RemoveFontResourceA := TRemoveFontResourceA( GetProcAddr(gdiLibHandle, 'RemoveFontResourceA'));
RemoveFontResourceExA := TRemoveFontResourceExA( GetProcAddr(gdiLibHandle, 'RemoveFontResourceExA'));
RemoveFontMemResourceEx := TRemoveFontMemResourceEx(GetProcAddr(gdiLibHandle, 'RemoveFontMemResourceEx'));
GetTextMetricsW := TGetTextMetricsW( GetProcAddr(gdiLibHandle, 'GetTextMetricsW'));
GetGlyphOutlineA := TGetGlyphOutlineA( GetProcAddr(gdiLibHandle, 'GetGlyphOutlineA'));
GetCharacterPlacementW := TGetCharacterPlacementW( GetProcAddr(gdiLibHandle, 'GetCharacterPlacementW'));
GetFontData := TGetFontData( GetProcAddr(gdiLibHandle, 'GetFontData'));
CreateCompatibleDC := TCreateCompatibleDC( GetProcAddr(gdiLibHandle, 'CreateCompatibleDC'));
DeleteDC := TDeleteDC( GetProcAddr(gdiLibHandle, 'DeleteDC'));
SelectObject := TSelectObject( GetProcAddr(gdiLibHandle, 'SelectObject'));
DeleteObject := TDeleteObject( GetProcAddr(gdiLibHandle, 'DeleteObject'));
GetOutlineTextMetricsW := TGetOutlineTextMetricsW( GetProcAddr(gdiLibHandle, 'GetOutlineTextMetricsW'));

GetLocaleInfoA := TGetLocaleInfoA(GetProcAddr(kernel32LibHandle, 'GetLocaleInfoA'));

gdiInitialized := true;
except
gdiInitialized := false;
FreeLibrary(gdiLibHandle);
FreeLibrary(kernel32LibHandle);
end;
end;

procedure QuitGDI;
begin
CreateFontIndirectA := nil;
AddFontResourceA := nil;
AddFontResourceExA := nil;
RemoveFontResourceA := nil;
RemoveFontResourceExA := nil;
GetTextMetricsW := nil;
GetGlyphOutlineA := nil;
GetCharacterPlacementW := nil;
GetFontData := nil;
CreateCompatibleDC := nil;
DeleteDC := nil;
SelectObject := nil;
DeleteObject := nil;

GetLocaleInfoA := nil;

if (gdiLibHandle <> 0) then begin
FreeLibrary(gdiLibHandle);
gdiLibHandle := 0;
end;

if (kernel32LibHandle <> 0) then begin
FreeLibrary(kernel32LibHandle);
kernel32LibHandle := 0;
end;

gdiInitialized := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontGDI////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontGDI.Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator; const aProperties: TtsFontProperties; const aHandle: THandle);
begin
inherited Create(aRenderer, aCreator, aProperties);
FillByte(fMat2, SizeOf(fMat2), 0);
fMat2.eM11.value := 1;
fMat2.eM22.value := 1;
fHandle := aHandle;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsFontGDI.Destroy;
begin
DeleteObject(fHandle);
inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontRegistration///////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsFontRegistration.Destroy;
begin
if fIsRegistered then
UnregisterFont;
inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontRegistrationFile///////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontRegistrationFile.UnregisterFont;
begin
if Assigned(RemoveFontResourceExA) then
RemoveFontResourceExA(PAnsiChar(fFilename), 0, nil)
else if Assigned(RemoveFontResourceA) then
RemoveFontResourceA(PAnsiChar(fFilename));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontRegistrationFile.Create(const aFilename: String);
var
lang: AnsiString;
begin
inherited Create;
fFilename := aFilename;

// get Fontname
SetLength(lang, 4);
GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @lang[1], 4);
fFontname := GetTTFontFullNameFromFile(aFilename, StrToInt('$' + String(lang)));

// register font
if Assigned(AddFontResourceExA) then
fIsRegistered := (AddFontResourceExA(PAnsiChar(fFilename), 0, nil) > 0)
else if Assigned(AddFontResourceA) then
fIsRegistered := (AddFontResourceA(PAnsiChar(fFilename)) > 0)
else
fIsRegistered := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontRegistrationStream/////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontRegistrationStream.UnregisterFont;
begin
if Assigned(RemoveFontMemResourceEx) then
RemoveFontMemResourceEx(fHandle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontRegistrationStream.Create(const aStream: TStream);
var
lang: AnsiString;
ms: TMemoryStream;
cnt: DWORD;
begin
inherited Create;
fHandle := 0;
fIsRegistered := false;

// get Fontname
SetLength(Lang, 4);
GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @lang[1], 4);
fFontname := GetTTFontFullNameFromStream(aStream, StrToInt('$' + String(Lang)));

// register font
ms := TMemoryStream.Create;
try
ms.CopyFrom(aStream, 0);
if Assigned(AddFontMemResourceEx) then
fHandle := AddFontMemResourceEx(ms.Memory, ms.Size, nil, @cnt);
fIsRegistered := (fHandle > 0);
finally
FreeAndNil(ms);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsRegistredFontGDI///////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsRegistredFontGDI.Create(const aRenderer: TtsRenderer; const aCreator: TtsFontGenerator;
const aRegistration: TtsFontRegistration; const aProperties: TtsFontProperties; const aHandle: THandle);
begin
inherited Create(aRenderer, aCreator, aProperties, aHandle);
fRegistration := aRegistration;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsRegistredFontGDI.Destroy;
begin
FreeAndNil(fRegistration);
inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsFontCreatorGDIFontFace/////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.ConvertFont(const aFont: TtsFont): TtsFontGDI;
begin
if not (aFont is TtsFontGDI) then
raise EtsException.Create('aFont need to be a TtsFontGDI object');
result := (aFont as TtsFontGDI);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetGlyphIndex(const aFont: TtsFontGDI; const aCharCode: WideChar): Integer;
var
DC: HDC;
GCPRes: TGCPResultsW;
begin
result := -1;
DC := CreateCompatibleDC(0);
try
SelectObject(DC, aFont.fHandle);
if Assigned(GetCharacterPlacementW) then begin
FillByte(GCPRes, SizeOf(GCPRes), 0);
GetMem(GCPRes.lpGlyphs, SizeOf(Cardinal));
try
GCPRes.lStructSize := SizeOf(GCPRes);
GCPRes.lpGlyphs^ := 0;
GCPRes.nGlyphs := 1;
if (GetCharacterPlacementW(DC, @aCharCode, 1, GCP_MAXEXTENT, @GCPRes, 0) <> GDI_ERROR) and
(GCPRes.nGlyphs = 1) and
(GCPRes.lpGlyphs <> nil) then
begin
result := GCPRes.lpGlyphs^;
end;
finally
FreeMem(GCPRes.lpGlyphs);
end;
end;
finally
DeleteDC(DC);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontGeneratorGDI.GetCharImageAANone(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);
var
Metric: TGlyphMetrics;
GlyphIndex, srcW, srcX, w, h, x, y: Integer;
Size, OutlineRes: Cardinal;
Buffer, pSrc, pDst: PByte;

procedure ExpandByte;
var
i, cnt, srcCnt: Integer;
c: TtsColor4f;
begin
srcCnt := min(8, srcX);
cnt := min(8, x);
for i := 1 to cnt do begin
c := tsColor4f(1, 1, 1, 1);
if ((pSrc^ and $80) > 0) then
c.a := 1
else
c.a := 0;
pSrc^ := (pSrc^ and not $80) shl 1;
tsFormatMap(aFont.Renderer.Format, pDst, c);
end;
dec(srcX, srcCnt);
dec(x, cnt);
inc(pSrc);
end;

begin
if (aFont.fMat2.eM11.value <> 1) then
raise EtsException.Create('invalid value');
FillByte(Metric, SizeOf(Metric), 0);

GlyphIndex := GetGlyphIndex(aFont, aCharCode);
if (GlyphIndex < 0) then
exit;

Size := GetGlyphOutlineA(aDC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @aFont.fMat2);
if (Size = GDI_ERROR) or (Size = 0) then
exit;

GetMem(Buffer, Size);
try
OutlineRes := GetGlyphOutlineA(aDC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, Size, Buffer, @aFont.fMat2);
if (OutlineRes = GDI_ERROR) then
exit;
w := Metric.gmBlackBoxX;
h := Metric.gmBlackBoxY;
srcW := (Size div h) * 8;
if (w <= 0) or (h <= 0) then
exit;
aImage.CreateEmpty(aFont.Renderer.Format, w, h);
pSrc := Buffer;
for y := 0 to h-1 do begin
pDst := aImage.Scanline[y];
srcX := srcW;
while (srcX > 0) do
ExpandByte;
end;
finally
Freemem(Buffer);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontGeneratorGDI.GetCharImageAANormal(const aDC: HDC; const aFont: TtsFontGDI; const aCharCode: WideChar; const aImage: TtsImage);
var
Metric: TGlyphMetrics;
GlyphIndex, OutlineRes, tmp, Spacer, x, y, w, h: Integer;
Size: Cardinal;
Buffer, pSrc, pDst: PByte;

procedure CopyPixel;
var
i: Integer;
tmp, cnt: Cardinal;
c: TtsColor4f;
begin
cnt := min(x, aFont.fMat2.eM11.value);
tmp := 0;
for i := 0 to cnt-1 do begin
tmp := tmp + pSrc^;
inc(pSrc, 1);
end;
dec(x, cnt);
c := tsColor4f(1, 1, 1, tmp / ($40 * Cardinal(aFont.fMat2.eM11.value)));
tsFormatMap(aFont.Renderer.Format, pDst, c);
end;

begin
FillByte(Metric, SizeOf(Metric), 0);

GlyphIndex := GetGlyphIndex(aFont, aCharCode);
if (GlyphIndex < 0) then
exit;

Size := GetGlyphOutlineA(aDC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @aFont.fMat2);
if (Size = GDI_ERROR) or (Size = 0) then
exit;

GetMem(Buffer, Size);
try
OutlineRes := GetGlyphOutlineA(aDC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, Size, Buffer, @aFont.fMat2);
if (OutlineRes = GDI_ERROR) then
exit;
w := Integer(Metric.gmBlackBoxX) div aFont.fMat2.eM11.value;
h := Metric.gmBlackBoxY;
tmp := Integer(Metric.gmBlackBoxX) mod aFont.fMat2.eM11.value;
if (tmp <> 0) then
w := w + aFont.fMat2.eM11.value - tmp;
if (w <= 0) or (h <= 0) then
exit;

// spacer
Spacer := Metric.gmBlackBoxX mod 4;
if (Spacer <> 0) then
Spacer := 4 - Spacer;

// copy image
aImage.CreateEmpty(aFont.Renderer.Format, w, h);
pSrc := Buffer;
for y := 0 to h-1 do begin
pDst := aImage.Scanline[y];
x := Metric.gmBlackBoxX;
while (x > 0) do
CopyPixel;
inc(pSrc, Spacer);
end;
finally
FreeMem(Buffer);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.CreateFont(const aFontname: String; const aSize: Integer; const aStyle: TtsFontStyles;
const aAntiAliasing: TtsAntiAliasing; out aProperties: TtsFontProperties): THandle;
var
LogFont: TLogFontA;
i: Integer;
DC: HDC;
TableName, BufSize: Cardinal;
Buffer: PByte;
Lang: AnsiString;
TextMetric: TTextMetricW;
OutlineMetric: TOutlineTextmetricW;

function _(e: Boolean; a, b: Integer): Integer;
begin
if e then
result := a
else
result := b;
end;

begin
result := 0;

FillByte(aProperties, SizeOf(aProperties), 0);
aProperties.Size := aSize;
aProperties.Style := aStyle;
aProperties.AntiAliasing := aAntiAliasing;
aProperties.Fontname := aFontname;

// prepare font attribs
FillByte(LogFont, SizeOf(LogFont), 0);
for i := 1 to min(Length(aFontname), Length(LogFont.lfFaceName)) do
LogFont.lfFaceName[i-1] := aFontname[i];
LogFont.lfCharSet := DEFAULT_CHARSET;
LogFont.lfHeight := -aSize;
LogFont.lfWeight := _(tsStyleBold in aStyle, FW_BOLD, FW_NORMAL);
LogFont.lfItalic := _(tsStyleItalic in aStyle, 1, 0);
LogFont.lfUnderline := _(tsStyleUnderline in aStyle, 1, 0);
LogFont.lfQuality := _(aAntiAliasing = tsAANormal, ANTIALIASED_QUALITY, NONANTIALIASED_QUALITY);

result := CreateFontIndirectA(LogFont);
DC := CreateCompatibleDC(0);
try try
SelectObject(DC, result);
TableName := MakeTTTableName('n', 'a', 'm', 'e');
BufSize := GetFontData(DC, TableName, 0, nil, 0);
if (BufSize <> GDI_ERROR) then begin
GetMem(Buffer, BufSize);
try
if (GetFontData(DC, TableName, 0, Buffer, BufSize) <> GDI_ERROR) then begin
SetLength(Lang, 4);
GetLocaleInfoA(LOCALE_USER_DEFAULT, LOCALE_ILANGUAGE, @Lang[1], 4);

GetTTString(Buffer, BufSize, NAME_ID_COPYRIGHT, StrToInt('$' + String(Lang)), aProperties.Copyright);
GetTTString(Buffer, BufSize, NAME_ID_FACE_NAME, StrToInt('$' + String(Lang)), aProperties.FaceName);
GetTTString(Buffer, BufSize, NAME_ID_STYLE_NAME, StrToInt('$' + String(Lang)), aProperties.StyleName);
GetTTString(Buffer, BufSize, NAME_ID_FULL_NAME, StrToInt('$' + String(Lang)), aProperties.FullName);
end;
finally
FreeMem(Buffer);
end;
end;

if GetTextMetricsW(DC, TextMetric) then begin
aProperties.Ascent := TextMetric.tmAscent;
aProperties.Descent := TextMetric.tmDescent;
aProperties.ExternalLeading := TextMetric.tmExternalLeading;
aProperties.DefaultChar := TextMetric.tmDefaultChar;
end;

if (GetOutlineTextMetricsW(DC, SizeOf(OutlineMetric), OutlineMetric) > 0) then begin
aProperties.UnderlinePos := OutlineMetric.otmsUnderscorePosition;
aProperties.UnderlineSize := Min(1, OutlineMetric.otmsUnderscoreSize);
aProperties.StrikeoutPos := OutlineMetric.otmsStrikeoutPosition;
aProperties.StrikeoutSize := Min(1, OutlineMetric.otmsStrikeoutSize);
end;
except
DeleteObject(result);
result := 0;
end;
finally
DeleteDC(DC);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetGlyphMetrics(const aFont: TtsFont; const aCharCode: WideChar; out aGlyphOrigin, aGlyphSize: TtsPosition; out aAdvance: Integer): Boolean;
var
GlyphIndex: Integer;
font: TtsFontGDI;
DC: HDC;
Metric: TGlyphMetrics;
Size: Cardinal;
begin
result := false;

aGlyphOrigin.x := 0;
aGlyphOrigin.x := 0;
aGlyphSize.x := 0;
aGlyphSize.y := 0;
aAdvance := 0;

font := ConvertFont(aFont);
GlyphIndex := GetGlyphIndex(font, aCharCode);
if (GlyphIndex < 0) then
exit;

DC := CreateCompatibleDC(0);
try
SelectObject(DC, font.fHandle);
case font.Properties.AntiAliasing of
tsAANone: begin
Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @font.fMat2);
end;
tsAANormal: begin
Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_GRAY8_BITMAP or GGO_GLYPH_INDEX, @Metric, 0, nil, @font.fMat2);
end;
else
Size := GDI_ERROR;
end;

if (Size = GDI_ERROR) then
Size := GetGlyphOutlineA(DC, GlyphIndex, GGO_METRICS or GGO_GLYPH_INDEX, @Metric, 0, nil, @font.fMat2);

if (Size <> GDI_ERROR) then begin
aGlyphOrigin.x := Round(Metric.gmptGlyphOrigin.x / font.fMat2.eM11.value);
aGlyphOrigin.y := Metric.gmptGlyphOrigin.y;
aGlyphSize.x := Round(Metric.gmBlackBoxX / font.fMat2.eM11.value);
aGlyphSize.y := Metric.gmBlackBoxY;
aAdvance := Round(Metric.gmCellIncX / font.fMat2.eM11.value);
result := true;
end;
finally
DeleteDC(DC);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsFontGeneratorGDI.GetCharImage(const aFont: TtsFont; const aCharCode: WideChar; const aCharImage: TtsImage);
var
DC: HDC;
font: TtsFontGDI;
begin
font := ConvertFont(aFont);
DC := CreateCompatibleDC(0);
try
SelectObject(DC, font.fHandle);
case font.Properties.AntiAliasing of
tsAANone:
GetCharImageAANone(DC, font, aCharCode, aCharImage);
tsAANormal:
GetCharImageAANormal(DC, font, aCharCode, aCharImage);
end;
finally
DeleteDC(DC);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetFontByName(const aFontname: String; const aRenderer: TtsRenderer;
const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
var
handle: THandle;
prop: TtsFontProperties;
begin
handle := CreateFont(aFontname, aSize, aStyle, aAntiAliasing, prop);
if (handle = 0) then
raise EtsException.Create('unable to create font from name: ' + aFontname);
result := TtsFontGDI.Create(aRenderer, self, prop, handle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetFontByFile(const aFilename: String; const aRenderer: TtsRenderer;
const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
var
reg: TtsFontRegistrationFile;
handle: THandle;
prop: TtsFontProperties;
begin
reg := TtsFontRegistrationFile.Create(aFilename);
if not reg.IsRegistered then
raise EtsException.Create('unable to register font file: ' + aFilename);
handle := CreateFont(reg.Fontname, aSize, aStyle, aAntiAliasing, prop);
if (handle = 0) then
raise EtsException.Create('unable to create font from file: ' + aFilename);
result := TtsRegistredFontGDI.Create(aRenderer, self, reg, prop, handle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsFontGeneratorGDI.GetFontByStream(const aStream: TStream; const aRenderer: TtsRenderer;
const aSize: Integer; const aStyle: TtsFontStyles; const aAntiAliasing: TtsAntiAliasing): TtsFont;
var
reg: TtsFontRegistrationStream;
handle: THandle;
prop: TtsFontProperties;
begin
reg := TtsFontRegistrationStream.Create(aStream);
if not reg.IsRegistered then
raise EtsException.Create('unable to register font from stream');
handle := CreateFont(reg.Fontname, aSize, aStyle, aAntiAliasing, prop);
if (handle = 0) then
raise EtsException.Create('unable to create font from stream: ' + reg.Fontname);
result := TtsRegistredFontGDI.Create(aRenderer, self, reg, prop, handle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsFontGeneratorGDI.Create;
begin
inherited Create;
gdiCritSec.Enter;
try
inc(gdiRefCount, 1);
if not gdiInitialized then
InitGDI;
finally
gdiCritSec.Leave;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor TtsFontGeneratorGDI.Destroy;
begin
gdiCritSec.Enter;
try
dec(gdiRefCount, 1);
if (gdiRefCount <= 0) then
QuitGDI;
finally
gdiCritSec.Leave;
end;
inherited Destroy;
end;

initialization
gdiRefCount := 0;
gdiInitialized := false;
gdiCritSec := TCriticalSection.Create;

finalization
if gdiInitialized then
QuitGDI;
FreeAndNil(gdiCritSec);

end.

+ 521
- 0
new/utsRendererOpenGL.pas Просмотреть файл

@@ -0,0 +1,521 @@
unit utsRendererOpenGL;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, syncobjs, dglOpenGL,
utsTextSuite, utsTypes;

type
TtsQuadPosF = array[0..3] of TtsPositionF;
TtsCharRenderRefOpenGL = class(TtsCharRenderRef)
private
TextureID: GLint; // ID of OpenGL texture where the char is stored in
TexCoordSize: TtsPositionF; // size of the char in texture coords (0.0 - 1.0)
TexCoordPos: TtsPositionF; // position of the char in texture coords (0.0 - 1.0)
VertexSize: TtsPositionF; // size of the char in world coords
VertexPos: TtsPositionF; // size of the char in world coords
public
constructor Create;
end;

PtsTextureUsageItem = ^TtsTextureUsageItem;
TtsTextureUsageItem = packed record
children: array[0..3] of PtsTextureUsageItem;
end;

PtsTextureTreeItem = ^TtsTextureTreeItem;
TtsTextureTreeItem = packed record
value: SmallInt;
children: array[0..1] of PtsTextureTreeItem;
ref: TtsCharRenderRefOpenGL;
end;

PtsFontTexture = ^TtsFontTexture;
TtsFontTexture = packed record
ID: GLint; // OpenGL texture ID
Usage: PtsTextureTreeItem ; // tree of used texture space
Next: PtsFontTexture; // next texture in list
Prev: PtsFontTexture; // previouse texture in list
Size: Integer; // size of this texture
Count: Integer; // number of chars stored in this texture
end;

TtsRendererOpenGL = class(TtsRenderer)
private
fVBO: GLuint;
fTextureSize: Integer;
fColor: TtsColor4f;
fRenderPos: TtsPosition;
fIsRendering: Boolean;
fFirstTexture: PtsFontTexture;
fLastTexture: PtsFontTexture;

function CreateNewTexture: PtsFontTexture;
procedure FreeTexture(var aTexture: PtsFontTexture);
procedure FreeTextures(var aTexture: PtsFontTexture);
procedure FreeTextureTreeItem(var aItem: PtsTextureTreeItem);
protected
function CreateRenderRef(const aChar: TtsChar; const aCharImage: TtsImage): TtsCharRenderRef; override;
procedure FreeRenderRef(const aCharRef: TtsCharRenderRef); override;

procedure BeginRender; override;
procedure EndRender; override;

procedure SetDrawPos(const X, Y: Integer); override;
function GetDrawPos: TtsPosition; override;
procedure MoveDrawPos(const X, Y: Integer); override;
procedure SetColor(const aColor: TtsColor4f); override;
procedure Render(const aCharRef: TtsCharRenderRef); override;
public
property TextureSize: Integer read fTextureSize write fTextureSize;

constructor Create(const aContext: TtsContext; const aFormat: TtsFormat);
destructor Destroy; override;
end;

EtsRendererOpenGL = class(EtsRenderer);

implementation

type
TVertex = packed record
pos: array[0..1] of GLfloat;
tex: array[0..1] of GLfloat;
end;

const
FORMAT_TYPES: array[TtsFormat] of packed record
InternalFormat: GLenum;
Format: GLenum;
DataFormat: GLenum;
end = (
( //tsFormatEmpty
InternalFormat: 0;
Format: 0;
DataFormat: 0),
( //tsFormatRGBA8
InternalFormat: GL_RGBA8;
Format: GL_RGBA;
DataFormat: GL_UNSIGNED_BYTE),
( //tsFormatLumAlpha8
InternalFormat: GL_LUMINANCE8_ALPHA8;
Format: GL_LUMINANCE_ALPHA;
DataFormat: GL_UNSIGNED_BYTE),
( //tsFormatAlpha8
InternalFormat: GL_ALPHA8;
Format: GL_ALPHA;
DataFormat: GL_UNSIGNED_BYTE)
);

VBO_DATA: array[0..3] of TVertex = (
(pos: (0.0, 0.0); tex: (0.0, 0.0)),
(pos: (0.0, 1.0); tex: (0.0, 1.0)),
(pos: (1.0, 1.0); tex: (1.0, 1.0)),
(pos: (1.0, 0.0); tex: (1.0, 0.0))
);

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsCharRenderRefOpenGL////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsCharRenderRefOpenGL.Create;
begin
inherited Create;
TextureID := 0;
FillByte(TexCoordPos, SizeOf(TexCoordPos), 0);
FillByte(TexCoordSize, SizeOf(TexCoordSize), 0);
FillByte(VertexPos, SizeOf(VertexPos), 0);
FillByte(VertexSize, SizeOf(VertexSize), 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TtsRendererOpenGL/////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsRendererOpenGL.CreateNewTexture: PtsFontTexture;
begin
new(result);
try
FillByte(result^, SizeOf(result^), 0);
new(result^.Usage);
FillByte(result^.Usage^, SizeOf(result^.Usage^), 0);
result^.Size := TextureSize;
glGenTextures(1, @result^.ID);
glBindTexture(GL_TEXTURE_2D, result^.ID);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
glTexImage2D(
GL_TEXTURE_2D,
0,
FORMAT_TYPES[Format].InternalFormat,
result^.Size,
result^.Size,
0,
FORMAT_TYPES[Format].Format,
FORMAT_TYPES[Format].DataFormat,
nil);

result^.Prev := fLastTexture;
if Assigned(fLastTexture) then
fLastTexture^.Next := result
else
fFirstTexture := result;
fLastTexture := result;
except
if Assigned(result^.Usage) then
Dispose(result^.Usage);
Dispose(result);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.FreeTexture(var aTexture: PtsFontTexture);
begin
if not Assigned(aTexture) then
exit;
glDeleteTextures(1, @aTexture^.ID);
FreeTextureTreeItem(aTexture^.Usage);
if Assigned(aTexture^.Prev) then
aTexture^.Prev^.Next := aTexture^.Next;
if Assigned(aTexture^.Next) then
aTexture^.Next^.Prev := aTexture^.Prev;
Dispose(aTexture);
aTexture := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.FreeTextures(var aTexture: PtsFontTexture);
begin
if not Assigned(aTexture) then
exit;
FreeTextures(aTexture^.Next);
FreeTexture(aTexture);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.FreeTextureTreeItem(var aItem: PtsTextureTreeItem);
begin
if not Assigned(aItem) then
exit;
FreeTextureTreeItem(aItem^.children[0]);
FreeTextureTreeItem(aItem^.children[1]);
Dispose(aItem);
aItem := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsRendererOpenGL.CreateRenderRef(const aChar: TtsChar; const aCharImage: TtsImage): TtsCharRenderRef;
var
GlyphWidth, GlyphHeight: Integer;

function InsertToTree(const aItem: PtsTextureTreeItem; const X1, Y1, X2, Y2: SmallInt; out X, Y: Integer): PtsTextureTreeItem;
var
w, h: Integer;
begin
result := nil;
w := X2 - X1;
h := Y2 - Y1;
if not Assigned(aItem) or
Assigned(aItem^.ref) or
(w < GlyphWidth) or
(h < GlyphHeight) then
exit;

if (aItem^.value > 0) then begin
result := InsertToTree(aItem^.children[0], X1, Y1, X2, aItem^.value, X, Y);
if not Assigned(result) then
result := InsertToTree(aItem^.children[1], X1, aItem^.value, X2, Y2, X, Y);
end else if (aItem^.value < 0) then begin
result := InsertToTree(aItem^.children[0], X1, Y1, -aItem^.value, Y2, X, Y);
if not Assigned(result) then
result := InsertToTree(aItem^.children[1], -aItem^.value, Y1, X2, Y2, X, Y);
end else if (w = GlyphWidth) and (h = GlyphHeight) then begin
X := X1;
Y := Y1;
result := aItem;
end else begin
new(aItem^.children[0]);
new(aItem^.children[1]);
FillByte(aItem^.children[0]^, SizeOf(aItem^.children[0]^), 0);
FillByte(aItem^.children[1]^, SizeOf(aItem^.children[1]^), 0);
if (w - GlyphWidth) < (h - GlyphHeight) then begin
aItem^.value := Y1 + GlyphHeight;
result := InsertToTree(aItem^.children[0], X1, Y1, X2, aItem^.value, X, Y);
end else begin
aItem^.value := -(X1 + GlyphWidth);
result := InsertToTree(aItem^.children[0], X1, Y1, -aItem^.value, Y2, X, Y)
end;
end;
end;

function AddToTexture(const aTexture: PtsFontTexture): TtsCharRenderRefOpenGL;
var
x, y: Integer;
item: PtsTextureTreeItem;
begin
item := InsertToTree(aTexture^.Usage, 0, 0, aTexture^.Size, aTexture^.Size, x, y);
if not Assigned(item) then
raise EtsRendererOpenGL.Create('unable to add glyph to texture');
item^.ref := TtsCharRenderRefOpenGL.Create;
result := item^.ref;

// Text Coords
result.TextureID := aTexture^.ID;
result.TexCoordPos.x := x / aTexture^.Size;
result.TexCoordPos.y := y / aTexture^.Size;
result.TexCoordSize.x := aCharImage.Width / aTexture^.Size;
result.TexCoordSize.y := aCharImage.Height / aTexture^.Size;

// Vertex Coords
result.VertexPos.x := -aChar.GlyphRect.Left;
result.VertexPos.y := -aChar.GlyphRect.Top - aChar.GlyphOrigin.y;
result.VertexSize.x := aCharImage.Width;
result.VertexSize.y := aCharImage.Height;

glBindTexture(GL_TEXTURE_2D, result.TextureID);
glTexSubImage2D(GL_TEXTURE_2D, 0,
x, y, aCharImage.Width, aCharImage.Height,
FORMAT_TYPES[aCharImage.Format].Format,
FORMAT_TYPES[aCharImage.Format].DataFormat,
aCharImage.Data);
end;

var
tex: PtsFontTexture;
begin
result := nil;
if aCharImage.IsEmpty then
exit;

GlyphWidth := aCharImage.Width + 1;
GlyphHeight := aCharImage.Height + 1;

// try to add to existing texture
tex := fFirstTexture;
while Assigned(tex) and not Assigned(result) do begin
result := AddToTexture(tex);
tex := tex^.Next;
end;

// create new texture
if not Assigned(result) then begin
if (aCharImage.Width > TextureSize) or (aCharImage.Height > TextureSize) then
raise EtsRendererOpenGL.Create('char is to large to fit into a texture: ' + aChar.CharCode + ' (0x' + IntToHex(Ord(aChar.CharCode), 4) + ')');
tex := CreateNewTexture;
result := AddToTexture(tex);
end;

if not Assigned(result) then
raise EtsRendererOpenGL.Create('unable to creat render reference for char: ' + aChar.CharCode + ' (0x' + IntToHex(Ord(aChar.CharCode), 4) + ')');
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.FreeRenderRef(const aCharRef: TtsCharRenderRef);
var
ref: TtsCharRenderRefOpenGL;
tex: PtsFontTexture;

function IsEmtpy(const aItem: PtsTextureTreeItem): Boolean;
begin
result :=
Assigned(aItem) and
not Assigned(aItem^.children[0]) and
not Assigned(aItem^.children[1]) and
not Assigned(aItem^.ref);
end;

function RemoveFromTree(const aItem: PtsTextureTreeItem; const X1, Y1, X2, Y2: Integer): Boolean;
var
w, h: Integer;
begin
w := X2 - X1;
h := Y2 - Y1;
if not Assigned(aItem) or
(w < ref.VertexSize.x) or
(h < ref.VertexSize.y) then
exit;

result := (aItem^.ref = ref);
if not result then begin
if (aItem^.value > 0) then begin
result := result or RemoveFromTree(aItem^.children[0], X1, Y1, X2, aItem^.value);
result := result or RemoveFromTree(aItem^.children[1], X1, aItem^.value, X2, Y2);
end else if (aItem^.value < 0) then begin
result := result or RemoveFromTree(aItem^.children[0], X1, Y1, -aItem^.value, Y2);
result := result or RemoveFromTree(aItem^.children[1], -aItem^.value, Y1, X2, Y2);
end;
end else
aItem^.ref := nil;

if result and
IsEmtpy(aItem^.children[0]) and
IsEmtpy(aItem^.children[1]) then
begin
FreeTextureTreeItem(aItem^.children[0]);
FreeTextureTreeItem(aItem^.children[1]);
FillByte(aItem^, SizeOf(aItem^), 0);
end;
end;

begin
try
if not Assigned(aCharRef) or not (aCharRef is TtsCharRenderRefOpenGL) then
exit;
ref := (aCharRef as TtsCharRenderRefOpenGL);
tex := fFirstTexture;
while Assigned(tex) do begin
if (tex^.ID = ref.TextureID) then begin
if not RemoveFromTree(tex^.Usage, 0, 0, tex^.Size, tex^.Size) then
raise EtsRendererOpenGL.Create('unable to remove render ref from texture');
if IsEmtpy(tex^.Usage) then begin
if (tex = fFirstTexture) then
fFirstTexture := nil;
FreeTexture(tex);
end;
tex := nil;
end else
tex := tex^.Next;
end;
finally
if Assigned(aCharRef) then
aCharRef.Free;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.BeginRender;
begin
inherited BeginRender;
fIsRendering := true;
fRenderPos.x := 0;
fRenderPos.y := 0;
glPushMatrix;
glColor4fv(@fColor.arr[0]);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.EndRender;
begin
if fIsRendering then begin
glPopMatrix;
fIsRendering := false;
end;
inherited EndRender;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.SetDrawPos(const X, Y: Integer);
begin
fRenderPos.x := X;
fRenderPos.y := Y;
glPopMatrix;
glPushMatrix;
glTranslatef(X, Y, 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TtsRendererOpenGL.GetDrawPos: TtsPosition;
begin
result := fRenderPos;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.MoveDrawPos(const X, Y: Integer);
begin
fRenderPos.x := fRenderPos.x + X;
fRenderPos.y := fRenderPos.y + Y;
glTranslatef(X, Y, 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.SetColor(const aColor: TtsColor4f);
begin
fColor := aColor;
glColor4fv(@fColor.arr[0]);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TtsRendererOpenGL.Render(const aCharRef: TtsCharRenderRef);
var
ref: TtsCharRenderRefOpenGL;

procedure RenderTreeItem(const aItem: PtsTextureTreeItem; const X1, Y1, X2, Y2: Integer);
begin
glBegin(GL_LINE_LOOP);
glVertex2f(X1, Y1);
glVertex2f(X2, Y1);
glVertex2f(X2, Y2);
glVertex2f(X1, Y2);
glEnd;
if (aItem^.value > 0) then begin
RenderTreeItem(aItem^.children[0], X1, Y1, X2, aItem^.value);
RenderTreeItem(aItem^.children[1], X1, aItem^.value, X2, Y2);
end else if (aItem^.value < 0) then begin
RenderTreeItem(aItem^.children[0], X1, Y1, -aItem^.value, Y2);
RenderTreeItem(aItem^.children[1], -aItem^.value, Y1, X2, Y2);
end;
end;

begin
if Assigned(aCharRef) and (aCharRef is TtsCharRenderRefOpenGL) then begin
ref := (aCharRef as TtsCharRenderRefOpenGL);

glEnable(GL_TEXTURE_2D);
glBindTexture(GL_TEXTURE_2D, ref.TextureID);

glMatrixMode(GL_TEXTURE);
glPushMatrix;
glLoadIdentity;
glTranslatef(ref.TexCoordPos.x, ref.TexCoordPos.y, 0);
glScalef(ref.TexCoordSize.x, ref.TexCoordSize.y, 1);

glMatrixMode(GL_MODELVIEW);
glPushMatrix;
glTranslatef(ref.VertexPos.x, ref.VertexPos.y, 0);
glScalef(ref.VertexSize.x, ref.VertexSize.y, 1);

glBindBuffer(GL_ARRAY_BUFFER, fVBO);
glEnableClientState(GL_VERTEX_ARRAY);
glVertexPointer(2, GL_FLOAT, SizeOf(TVertex), Pointer(0));
glEnableClientState(GL_TEXTURE_COORD_ARRAY);
glTexCoordPointer(2, GL_FLOAT, SizeOf(TVertex), Pointer(8));

glDrawArrays(GL_QUADS, 0, 4);

glDisableClientState(GL_TEXTURE_COORD_ARRAY);
glDisableClientState(GL_VERTEX_ARRAY);

glMatrixMode(GL_TEXTURE);
glPopMatrix;
glMatrixMode(GL_MODELVIEW);
glPopMatrix;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TtsRendererOpenGL.Create(const aContext: TtsContext; const aFormat: TtsFormat);
begin
inherited Create(aContext, aFormat);
fIsRendering := false;
fFirstTexture := nil;
fLastTexture := nil;
fTextureSize := 2048;
fColor := tsColor4f(1, 1, 1, 1);
fRenderPos := tsPosition(0, 0);

glGenBuffers(1, @fVBO);
glBindBuffer(GL_ARRAY_BUFFER, fVBO);
glBufferData(GL_ARRAY_BUFFER, SizeOf(TVertex) * Length(VBO_DATA), @VBO_DATA[0].pos[0], GL_STATIC_DRAW);
glBindBuffer(GL_ARRAY_BUFFER, 0);
end;

destructor TtsRendererOpenGL.Destroy;
begin
glDeleteBuffers(1, @fVBO);
FreeTextures(fFirstTexture);
inherited Destroy;
end;

end.


+ 291
- 649
new/utsTextSuite.pas
Разница между файлами не показана из-за своего большого размера
Просмотреть файл


+ 323
- 0
new/utsTtfUtils.pas Просмотреть файл

@@ -0,0 +1,323 @@
unit utsTtfUtils;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils;

const
NAME_ID_COPYRIGHT = 0;
NAME_ID_FACE_NAME = 1;
NAME_ID_STYLE_NAME = 2;
NAME_ID_FULL_NAME = 4;

function MakeTTTableName(const ch1, ch2, ch3, ch4: Char): Cardinal;
function GetTTString(pBuffer: Pointer; BufferSize: Integer; NameID, LanguageID: Cardinal; var Text: AnsiString): Boolean;

function GetTTFontFullNameFromStream(Stream: TStream; LanguageID: Cardinal): AnsiString;
function GetTTFontFullNameFromFile(Filename: AnsiString; LanguageID: Cardinal): AnsiString;

implementation

uses
utsUtils;

type
TT_OFFSET_TABLE = packed record
uMajorVersion: Word;
uMinorVersion: Word;
uNumOfTables: Word;
uSearchRange: Word;
uEntrySelector: Word;
uRangeShift: Word;
end;


TT_TABLE_DIRECTORY = packed record
TableName: Cardinal; // table name
uCheckSum: Cardinal; // Check sum
uOffset: Cardinal; // Offset from beginning of file
uLength: Cardinal; // length of the table in bytes
end;


TT_NAME_TABLE_HEADER = packed record
uFSelector: Word; //format selector. Always 0
uNRCount: Word; //Name Records count
uStorageOffset: Word; //Offset for strings storage, from start of the table
end;

TT_NAME_RECORD = packed record
uPlatformID: Word;
uEncodingID: Word;
uLanguageID: Word;
uNameID: Word;
uStringLength: Word;
uStringOffset: Word; //from start of storage area
end;

const
PLATFORM_ID_APPLE_UNICODE = 0;
PLATFORM_ID_MACINTOSH = 1;
PLATFORM_ID_MICROSOFT = 3;

function SWAPWORD(x: Word): Word;
begin
Result := x and $FF;
Result := Result shl 8;
Result := Result or (x shr 8);
end;

function SWAPLONG(x: Cardinal): Cardinal;
begin
Result := (x and $FF) shl 24;
x := x shr 8;

Result := Result or ((x and $FF) shl 16);
x := x shr 8;

Result := Result or ((x and $FF) shl 8);
x := x shr 8;

Result := Result or x;
end;

function GetTTTableData(Stream: TStream; TableName: Cardinal; pBuff: Pointer; var Size: Integer): Boolean;
var
Pos: Int64;
OffsetTable: TT_OFFSET_TABLE;
TableDir: TT_TABLE_DIRECTORY;
Idx: Integer;
begin
Result := False;

Pos := Stream.Position;

// Reading table header
Stream.Read(OffsetTable, sizeof(TT_OFFSET_TABLE));
OffsetTable.uNumOfTables := SWAPWORD(OffsetTable.uNumOfTables);
OffsetTable.uMajorVersion := SWAPWORD(OffsetTable.uMajorVersion);
OffsetTable.uMinorVersion := SWAPWORD(OffsetTable.uMinorVersion);

//check is this is a true type font and the version is 1.0
if (OffsetTable.uMajorVersion <> 1) or (OffsetTable.uMinorVersion <> 0) then
Exit;

// seaching table with name
for Idx := 0 to OffsetTable.uNumOfTables -1 do begin
Stream.Read(TableDir, sizeof(TT_TABLE_DIRECTORY));

if (TableName = TableDir.TableName) then begin
TableDir.uOffset := SWAPLONG(TableDir.uOffset);
TableDir.uLength := SWAPLONG(TableDir.uLength);

// copying tabledata
if (pBuff <> nil) and (Size >= Integer(TableDir.uLength)) then begin
Stream.Seek(TableDir.uOffset, soBeginning);
Size := Stream.Read(pBuff^, TableDir.uLength);

Result := Size = Integer(TableDir.uLength);
end else

begin
// restoring streamposition
Stream.Position := Pos;

Size := TableDir.uLength;
Result := True;
end;

break;
end;
end;
end;

function MakeTTTableName(const ch1, ch2, ch3, ch4: Char): Cardinal;
begin
Result := ord(ch4) shl 24 or ord(ch3) shl 16 or ord(ch2) shl 8 or ord(ch1);
end;

function GetTTString(pBuffer: Pointer; BufferSize: Integer; NameID, LanguageID: Cardinal; var Text: AnsiString): Boolean;
var
pActBuffer: pByte;
ttNTHeader: TT_NAME_TABLE_HEADER;
ttRecord: TT_NAME_RECORD;
Idx: Integer;
Prio: Integer;

procedure ExtractName;
var
pTempBuffer: pByte;
pTemp: pWideChar;
uStringLengthH2: Word;

procedure SwapText(pText: pWideChar; Length: Word);
begin
while Length > 0 do begin
pWord(pText)^ := SWAPWORD(pWord(pText)^);
Inc(pText);
Dec(Length);
end;
end;

begin
Result := True;

ttRecord.uStringLength := SWAPWORD(ttRecord.uStringLength);
ttRecord.uStringOffset := SWAPWORD(ttRecord.uStringOffset);

uStringLengthH2 := ttRecord.uStringLength shr 1;

pTempBuffer := pBuffer;
Inc(pTempBuffer, ttNTHeader.uStorageOffset + ttRecord.uStringOffset);

// Unicode
if ((ttRecord.uPlatformID = PLATFORM_ID_MICROSOFT) and (ttRecord.uEncodingID in [0, 1])) or
((ttRecord.uPlatformID = PLATFORM_ID_APPLE_UNICODE) and (ttRecord.uEncodingID > 0)) then begin
pTemp := tsStrAlloc(uStringLengthH2);
try
// uStringLengthH2 * 2 because possible buffer overrun
Move(pTempBuffer^, pTemp^, uStringLengthH2 * 2);

SwapText(pTemp, uStringLengthH2);

WideCharLenToStrVar(pTemp, uStringLengthH2, Text);
finally
tsStrDispose(pTemp);
end;
end else

// none unicode
begin
SetLength(Text, ttRecord.uStringLength);
Move(pTempBuffer^, Text[1], ttRecord.uStringLength);
end;
end;

begin
Result := False;

pActBuffer := pBuffer;

Move(pActBuffer^, ttNTHeader, sizeof(TT_NAME_TABLE_HEADER));
inc(pActBuffer, sizeof(TT_NAME_TABLE_HEADER));

ttNTHeader.uNRCount := SWAPWORD(ttNTHeader.uNRCount);
ttNTHeader.uStorageOffset := SWAPWORD(ttNTHeader.uStorageOffset);

Prio := -1;

for Idx := 0 to ttNTHeader.uNRCount -1 do begin
Move(pActBuffer^, ttRecord, sizeof(TT_NAME_RECORD));
Inc(pActBuffer, sizeof(TT_NAME_RECORD));

ttRecord.uNameID := SWAPWORD(ttRecord.uNameID);

if ttRecord.uNameID = NameID then begin
ttRecord.uPlatformID := SWAPWORD(ttRecord.uPlatformID);
ttRecord.uEncodingID := SWAPWORD(ttRecord.uEncodingID);
ttRecord.uLanguageID := SWAPWORD(ttRecord.uLanguageID);

// highest priority
if (ttRecord.uPlatformID = PLATFORM_ID_MICROSOFT) then begin
// system language
if (ttRecord.uLanguageID = languageID) then begin
if Prio <= 7 then begin
ExtractName;

Prio := 7;
end;
end else

// english
if (ttRecord.uLanguageID = 1033) then begin
if Prio <= 6 then begin
ExtractName;

Prio := 6;
end;
end else

// all else
if Prio <= 5 then begin
ExtractName;

Prio := 5;
end;
end else

// apple unicode
if (ttRecord.uPlatformID = PLATFORM_ID_APPLE_UNICODE) then begin
ExtractName;

Prio := 4;
end else

// macintosh
if (ttRecord.uPlatformID = PLATFORM_ID_MACINTOSH) then begin
// english
if (ttRecord.uLanguageID = 0) then begin
if Prio <= 3 then begin
ExtractName;

Prio := 3;
end;
end else

// all other
begin
ExtractName;

Prio := 2;
end;
end else

begin
if Prio <= 1 then begin
ExtractName;

Prio := 1;
end;
end;
end;
end;
end;

function GetTTFontFullNameFromStream(Stream: TStream; LanguageID: Cardinal): AnsiString;
var
TableName: Cardinal;
Buffer: Pointer;
BufferSize: Integer;
begin
TableName := MakeTTTableName('n', 'a', 'm', 'e');

if GetTTTableData(Stream, TableName, nil, BufferSize) then begin
GetMem(Buffer, BufferSize);
try
if GetTTTableData(Stream, TableName, Buffer, BufferSize) then begin
if not GetTTString(Buffer, BufferSize, NAME_ID_FULL_NAME, LanguageID, Result) then
if not GetTTString(Buffer, BufferSize, NAME_ID_FACE_NAME, LanguageID, Result) then
Result := '';
end;
finally
FreeMem(Buffer);
end;
end;
end;

function GetTTFontFullNameFromFile(Filename: AnsiString; LanguageID: Cardinal): AnsiString;
var
fs: TFileStream;
begin
fs := TFileStream.Create(String(Filename), fmOpenRead or fmShareDenyWrite);
try
result := GetTTFontFullNameFromStream(fs, LanguageID);
finally
fs.Free;
end;
end;

end.


+ 304
- 0
new/utsTypes.pas Просмотреть файл

@@ -0,0 +1,304 @@
unit utsTypes;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils;

type
TtsCodePage = (
tsUTF8,
tsISO_8859_1,
tsISO_8859_2,
tsISO_8859_3,
tsISO_8859_4,
tsISO_8859_5,
tsISO_8859_6,
tsISO_8859_7,
tsISO_8859_8,
tsISO_8859_9,
tsISO_8859_10,
tsISO_8859_11,
tsISO_8859_13,
tsISO_8859_14,
tsISO_8859_15,
tsISO_8859_16,
tsISO_037,
tsISO_437,
tsISO_500,
tsISO_737,
tsISO_775,
tsISO_850,
tsISO_852,
tsISO_855,
tsISO_857,
tsISO_860,
tsISO_861,
tsISO_862,
tsISO_863,
tsISO_864,
tsISO_865,
tsISO_866,
tsISO_869,
tsISO_874,
tsISO_875,
tsISO_1026,
tsISO_1250,
tsISO_1251,
tsISO_1252,
tsISO_1253,
tsISO_1254,
tsISO_1255,
tsISO_1256,
tsISO_1257,
tsISO_1258);

TtsFontStyle = (
tsStyleBold,
tsStyleItalic,
tsStyleUnderline,
tsStyleStrikeout);
TtsFontStyles = set of TtsFontStyle;

TtsVertAlignment = (
tsVertAlignTop,
tsVertAlignCenter,
tsVertAlignBottom);

TtsHorzAlignment = (
tsHorzAlignLeft,
tsHorzAlignCenter,
tsHorzAlignRight,
tsHorzAlignJustify);

TtsFormat = (
tsFormatEmpty,
tsFormatRGBA8,
tsFormatLumAlpha8,
tsFormatAlpha8);

TtsAntiAliasing = (
tsAANone,
tsAANormal);

TtsColorChannel = (
tsChannelRed,
tsChannelGreen,
tsChannelBlue,
tsChannelAlpha);
TtsColorChannels = set of TtsColorChannel;

TtsImageMode = (
tsModeIgnore,
tsModeReplace,
tsModeModulate);
TtsImageModes = array[TtsColorChannel] of TtsImageMode;
TtsImageModeFunc = function(const aSource, aDest: Single): Single;

TtsFontProperties = packed record
Fontname: String;
Copyright: String;
FaceName: String;
StyleName: String;
FullName: String;

Size: Integer;
Style: TtsFontStyles;
AntiAliasing: TtsAntiAliasing;
DefaultChar: WideChar;

Ascent: Integer;
Descent: Integer;
ExternalLeading: Integer;
BaseLineOffset: Integer;

UnderlinePos: Integer;
UnderlineSize: Integer;
StrikeoutPos: Integer;
StrikeoutSize: Integer;
end;

TtsPosition = packed record
x, y: Integer;
end;
PtsPosition = ^TtsPosition;

TtsPositionF = packed record
x, y: Single;
end;
PtsPositionF = ^TtsPositionF;

TtsRect = packed record
case Byte of
0: (TopLeft: TtsPosition; BottomRight: TtsPosition);
1: (Left, Top, Right, Bottom: Integer);
end;
PtsRect = ^TtsRect;

TtsRectF = packed record
case Byte of
0: (TopLeft: TtsPositionF; BottomRight: TtsPositionF);
1: (Left, Top, Right, Bottom: Single);
end;
PtsRectF = ^TtsRectF;

TtsColor4f = packed record
case Boolean of
true: (r, g, b, a: Single);
false: (arr: array[0..3] of Single);
end;
PtsColor4f = ^TtsColor4f;

TtsColor4ub = packed record
case Boolean of
true: (r, g, b, a: Byte);
false: (arr: array[0..3] of Byte);
end;
PtsColor4ub = ^TtsColor4ub;

TtsTextMetric = packed record
Ascent: Integer;
Descent: Integer;
ExternalLeading: Integer;
BaseLineOffset: Integer;
CharSpacing: Integer;
LineHeight: Integer;
LineSpacing: Integer;
end;

TtsAnsiToWideCharFunc = procedure(aDst: PWideChar; const aSize: Integer; aSource: PAnsiChar; const aCodePage: TtsCodePage; const aDefaultChar: WideChar);

function tsColor4f(r, g, b, a: Single): TtsColor4f;
function tsRect(const l, t, r, b: Integer): TtsRect;
function tsPosition(const x, y: Integer): TtsPosition;

function tsFormatSize(const aFormat: TtsFormat): Integer;
procedure tsFormatMap(const aFormat: TtsFormat; var aData: PByte; const aColor: TtsColor4f);
procedure tsFormatUnmap(const aFormat: TtsFormat; var aData: PByte; out aColor: TtsColor4f);

function tsImageModeFuncIgnore(const aSource, aDest: Single): Single;
function tsImageModeFuncReplace(const aSource, aDest: Single): Single;
function tsImageModeFuncModulate(const aSource, aDest: Single): Single;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsColor4f(r, g, b, a: Single): TtsColor4f;
begin
result.r := r;
result.g := g;
result.b := b;
result.a := a;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsRect(const l, t, r, b: Integer): TtsRect;
begin
result.Left := l;
result.Top := t;
result.Right := r;
result.Bottom := b;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsPosition(const x, y: Integer): TtsPosition;
begin
result.x := x;
result.y := y;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsFormatSize(const aFormat: TtsFormat): Integer;
begin
case aFormat of
tsFormatRGBA8: result := 4;
tsFormatLumAlpha8: result := 2;
tsFormatAlpha8: result := 1;
else
result := 0;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure tsFormatMap(const aFormat: TtsFormat; var aData: PByte; const aColor: TtsColor4f);
var
i: Integer;
s: Single;
begin
case aFormat of
tsFormatRGBA8: begin
for i := 0 to 3 do begin
aData^ := Trunc($FF * aColor.arr[i]);
inc(aData);
end;
end;

tsFormatLumAlpha8: begin
s := 0.30 * aColor.r + 0.59 * aColor.g + 0.11 * aColor.b;
aData^ := Trunc($FF * s); inc(aData);
aData^ := Trunc($FF * s); inc(aData);
aData^ := Trunc($FF * s); inc(aData);
aData^ := Trunc($FF * aColor.a); inc(aData);
end;

tsFormatAlpha8: begin
aData^ := Trunc($FF * aColor.a);
inc(aData);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure tsFormatUnmap(const aFormat: TtsFormat; var aData: PByte; out aColor: TtsColor4f);
var
i: Integer;
begin
case aFormat of
tsFormatRGBA8: begin
for i := 0 to 3 do begin
aColor.arr[i] := aData^ / $FF;
inc(aData);
end;
end;

tsFormatLumAlpha8: begin
aColor.r := aData^ / $FF;
aColor.g := aData^ / $FF;
aColor.b := aData^ / $FF;
inc(aData);
aColor.a := aData^ / $FF;
inc(aData);
end;

tsFormatAlpha8: begin
aColor.r := 1.0;
aColor.g := 1.0;
aColor.b := 1.0;
aColor.a := aData^ / $FF;
inc(aData);
end;
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsImageModeFuncIgnore(const aSource, aDest: Single): Single;
begin
result := aDest;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsImageModeFuncReplace(const aSource, aDest: Single): Single;
begin
result := aSource;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsImageModeFuncModulate(const aSource, aDest: Single): Single;
begin
result := aSource * aDest;
end;

end.


+ 144
- 0
new/utsUtils.pas Просмотреть файл

@@ -0,0 +1,144 @@
unit utsUtils;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils;

function tsStrAlloc(aSize: Cardinal): PWideChar;
function tsStrNew(const aText: PWideChar): PWideChar;
procedure tsStrDispose(const aText: PWideChar);
function tsStrLength(aText: PWideChar): Cardinal;
function tsStrCopy(aDst, aSrc: PWideChar): PWideChar;
function tsISO_8859_1ToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar): Integer;
function tsUTF8ToWide(aDst: PWideChar; const aSize: Integer; const aSrc: PAnsiChar; const aDefaultChar: WideChar): Integer;

implementation

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsStrAlloc(aSize: Cardinal): PWideChar;
begin
aSize := (aSize + 1) shl 1;
GetMem(result, aSize);
FillChar(result^, aSize, 0);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsStrNew(const aText: PWideChar): PWideChar;
begin
result := tsStrAlloc(tsStrLength(aText));
tsStrCopy(result, aText);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure tsStrDispose(const aText: PWideChar);
begin
FreeMem(aText);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsStrLength(aText: PWideChar): Cardinal;
begin
result := 0;
if Assigned(aText) then
while (ord(aText^) <> 0) do begin
inc(result);
inc(aText);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsStrCopy(aDst, aSrc: PWideChar): PWideChar;
begin
result := aDst;
if Assigned(aDst) and Assigned(aSrc) then
while ord(aSrc^) <> 0 do begin
aDst^ := aSrc^;
inc(aDst);
inc(aSrc);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsISO_8859_1ToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar): Integer;
begin
result := 0;
if Assigned(aDst) and Assigned(aSrc) then
while (ord(aSrc^) <> 0) do begin
aDst^ := WideChar(aSrc^);
inc(aDst);
inc(aSrc);
inc(result);
end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function tsUTF8ToWide(aDst: PWideChar; const aSize: Integer; const aSrc: PAnsiChar; const aDefaultChar: WideChar): Integer;

procedure AddToDest(aCharCode: UInt64);
begin
if (aCharCode > $FFFF) then
aCharCode := ord(aDefaultChar);

PWord(aDst)^ := aCharCode;
inc(aDst);
result := result + 1;
end;

const
STATE_STARTBYTE = 0;
STATE_FOLLOWBYTE = 1;
var
cc: QWord;
len, state, c: Integer;
p: PByte;
tmp: Byte;
begin
result := 0;
if not Assigned(aDst) or not Assigned(aSrc) or (aSize <= 0) then
exit;

p := PByte(aSrc);
len := Length(aSrc);
state := STATE_STARTBYTE;
while (len > 0) do begin
case state of
STATE_STARTBYTE: begin
if (p^ and %10000000 = 0) then begin
AddToDest(p^);
end else if (p^ and %01000000 > 0) then begin
tmp := p^;
c := 0;
while (tmp and %10000000) > 0 do begin
inc(c);
tmp := tmp shl 1;
end;
cc := p^ and ((1 shl (7 - c)) - 1);
state := STATE_FOLLOWBYTE;
c := c - 1;
end;
end;

STATE_FOLLOWBYTE: begin
if ((p^ and %11000000) = %10000000) then begin
cc := (cc shl 6) or (p^ and %00111111);
c := c - 1;
if (c = 0) then begin
AddToDest(cc);
state := STATE_STARTBYTE;
end;
end else
state := STATE_STARTBYTE;
end;
end;

if (result >= aSize) then
exit;
inc(p);
end;
end;

end.


+ 1
- 1
old/TextSuiteClasses.pas Просмотреть файл

@@ -3082,7 +3082,7 @@ begin

// name
fFontname := Fontname;
for Idx := 1 to Min(Length(Fontname), Length(LogFont.lfFaceName)) do
for Idx := 1 to min(Length(Fontname), Length(LogFont.lfFaceName)) do
LogFont.lfFaceName[Idx -1] := Fontname[Idx];

// char set


Двоичные данные
Просмотреть файл


Двоичные данные
Просмотреть файл


Двоичные данные
Просмотреть файл


Двоичные данные
Просмотреть файл


Двоичные данные
Просмотреть файл


Двоичные данные
Просмотреть файл


+ 1
- 0
uMainForm.lfm Просмотреть файл

@@ -4,6 +4,7 @@ object MainForm: TMainForm
Top = 255
Width = 682
OnCreate = FormCreate
OnDestroy = FormDestroy
OnPaint = FormPaint
LCLVersion = '1.3'
object ApplicationProperties: TApplicationProperties


+ 58
- 23
uMainForm.pas Просмотреть файл

@@ -2,27 +2,36 @@ unit uMainForm;

{$mode objfpc}{$H+}

{.$DEFINE USE_OLD_TS}

interface

uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, uglcContext, TextSuite, uglcTypes, utsTextSuite;
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, uglcContext, TextSuite, uglcTypes,
utsTextSuite, utsTypes, utsFontCreatorGDI, utsRendererOpenGL;

type
TMainForm = class(TForm)
ApplicationProperties: TApplicationProperties;
procedure ApplicationPropertiesIdle(Sender: TObject; var Done: Boolean);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
fFrameTime: QWord;
fFrameCount: Integer;
fSecTime: QWord;

fContext: TglcContext;
{$IFDEF USE_OLD_TS}
fTextSuiteContext: tsContextID;
fFontID: tsFontID;

ftsContext: TtsContext;
ftsRenderer: TtsRenderer;
ftsCreator: TtsFontCreator;
ftsFont: TtsFont;
{$ELSE}
ftsContext: TtsContext;
ftsRenderer: TtsRendererOpenGL;
ftsGenerator: TtsFontGeneratorGDI;
ftsFont: TtsFont;
{$ENDIF}
procedure Render;
public
{ public declarations }
@@ -48,19 +57,31 @@ begin
pf := TglcContext.MakePF();
fContext := TglcContext.GetPlatformClass.Create(self, pf);
fContext.BuildContext;
{$IFDEF USE_OLD_TS}
tsInit(TS_INIT_TEXTSUITE or TS_INIT_OPENGL or TS_INIT_GDI);
tsContextCreate(@fTextSuiteContext);
tsSetParameteri(TS_RENDERER, TS_RENDERER_OPENGL);
tsSetParameteri(TS_CREATOR, TS_CREATOR_GDI);
tsSetParameteri(TS_CREATOR, TS_CREATOR_GDI_FACENAME);
tsContextBind(fTextSuiteContext);
tsFontCreateCreatorA('ttf/calibri.ttf', 24, 0, TS_ANTIALIASING_NORMAL, TS_DEFAULT, @fFontID);
tsFontCreateCreatorA('Calibri', 25, 0, TS_ANTIALIASING_NORMAL, TS_DEFAULT, @fFontID);
tsFontBind(fFontID);
{$ELSE}
ftsContext := TtsContext.Create;
ftsRenderer := TtsRendererOpenGL.Create(ftsContext, tsFormatRGBA8);
ftsGenerator := TtsFontGeneratorGDI.Create;
ftsFont := ftsGenerator.GetFontByName('Calibri', ftsRenderer, 25, [], tsAANormal);
ftsFont.LineSpacing := 0;
{$ENDIF}
end;

ftsContext := TtsContext.Create;
ftsRenderer := TtsRenderer.Create(ftsContext, tsFormatRGBA8);
ftsCreator := TtsFontCreator.Create;
ftsFont := TtsFont.Create(ftsRenderer, ftsCreator, '', '', '', '', 12, 0, 0, [], tsAANormal);
procedure TMainForm.FormDestroy(Sender: TObject);
begin
{$IFNDEF USE_OLD_TS}
FreeAndNil(ftsFont);
FreeAndNil(ftsGenerator);
FreeAndNil(ftsRenderer);
FreeAndNil(ftsContext);
{$ENDIF}
end;

procedure TMainForm.FormPaint(Sender: TObject);
@@ -71,7 +92,22 @@ end;
procedure TMainForm.Render;
var
block: TtsTextBlock;
t: QWord;
dif: Integer;
begin
t := GetTickCount64;
if (fFrameTime <> 0) then begin
dif := t - fFrameTime;
inc(fFrameCount, 1);
inc(fSecTime, dif);
if (fSecTime > 1000) then begin
Caption := IntToStr(fFrameCount) + ' FPS';
fFrameCount := 0;
dec(fSecTime, 1000);
end;
end;
fFrameTime := t;

glViewport(0, 0, ClientWidth, ClientHeight);
glClearColor(0, 0, 0, 0);
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
@@ -82,23 +118,22 @@ begin
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;

glDisable(GL_CULL_FACE);
glDisable(GL_DEPTH_TEST);
glEnable(GL_BLEND);

glcBlendFunc(TglcBlendMode.bmAdditiveAlphaBlend);
//tsTextBeginBlock(10, 10, ClientWidth-10, ClientHeight-10, TS_ALIGN_BLOCK);
//tsTextOutA(TEST_STRING);
//tsTextEndBlock;

block := ftsRenderer.BeginBlock(10, 10, ClientWidth-10, ClientHeight-10, [tsBlockFlagWordWrap]);
{$IFDEF USE_OLD_TS}
tsTextBeginBlock(0, 0, ClientWidth, ClientHeight, TS_ALIGN_BLOCK);
tsTextOutA(TEST_STRING);
tsTextEndBlock;
{$ELSE}
block := ftsRenderer.BeginBlock(0, 0, ClientWidth, ClientHeight, [tsBlockFlagWordWrap]);
try
block.ChangeFont(ftsFont);
block.TextOutW('test'#13#10#13#10'test'#13#13'test'#10#10'test'#13#10#10'test'#13#13#10);
block.TextOutW(TEST_STRING);
finally
ftsRenderer.EndBlock(block);
end;
{$ENDIF}
fContext.SwapBuffers;
end;



Редактирование Предпросмотр
Загрузка…
Отмена
Сохранить