Persona/tim2view
3
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Many new features! Have to be used.

Browse Source
This commit is contained in:
meffi@lab313.ru
2014-02-17 23:30:50 +00:00
commit b84a8264a2
22 changed files with 16228 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
PROGRAMICON.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 15 KiB

65
tim2view.dpr Normal file
View File

@@ -0,0 +1,65 @@
program tim2view;
uses
Windows,
Vcl.Forms,
Vcl.Themes,
Vcl.Styles,
ecc in 'units\ecc.pas',
edc in 'units\edc.pas',
uCDIMAGE in 'units\uCDIMAGE.pas',
uCommon in 'Units\uCommon.pas',
uMain in 'Units\uMain.pas' {frmMain},
uScanThread in 'Units\uScanThread.pas',
uTIM in 'units\uTIM.pas',
uDrawTIM in 'units\uDrawTIM.pas',
uEventWaitThread in 'units\uEventWaitThread.pas',
uBrowseForFolder in 'units\uBrowseForFolder.pas';
{$R *.res}
const
cMailslot = '\\.\mailslot\t2v_slot';
cEventNname = 't2v_open_event';
var
ClientMailSlot: THandle;
path: string;
BytesWritten: DWORD;
begin
ServerMailSlot := CreateMailslot(cMailslot, 0, MAILSLOT_WAIT_FOREVER, nil);
if ServerMailSlot = INVALID_HANDLE_VALUE then
begin
if GetLastError = ERROR_ALREADY_EXISTS then
begin
ClientMailSlot := CreateFile(cMailslot, GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if ParamCount > 0 then
path := ParamStr(1)
else
path := '';
WriteFile(ClientMailSlot, path[1], Length(path) * SizeOf(Char), BytesWritten, nil);
CommandEvent := OpenEvent(EVENT_MODIFY_STATE, False, cEventNname);
SetEvent(CommandEvent);
CloseHandle(CommandEvent);
CloseHandle(ClientMailSlot);
end;
end
else
begin
CommandEvent := CreateEvent(nil, False, False, cEventNname);
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TfrmMainT2V, frmMain);
Application.Run;
CloseHandle(ServerMailSlot);
CloseHandle(CommandEvent);
end;
end.

193
tim2view.dproj Normal file
View File

@@ -0,0 +1,193 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{20D93FC8-189B-40E7-8CB2-DBD3BD57B0B5}</ProjectGuid>
<ProjectVersion>14.6</ProjectVersion>
<FrameworkType>VCL</FrameworkType>
<MainSource>tim2view.dpr</MainSource>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>1</TargetedPlatforms>
<AppType>Application</AppType>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
<Base_Win32>true</Base_Win32>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
<Base_Win64>true</Base_Win64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
<Cfg_1_Win32>true</Cfg_1_Win32>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''">
<Cfg_2_Win32>true</Cfg_2_Win32>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_UsePackage>bindcompfmx;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;bindcomp;inetdb;DataSnapClient;DataSnapServer;DataSnapCommon;DBXInterBaseDriver;DataSnapProviderClient;xmlrtl;DbxCommonDriver;IndyProtocols;dbxcds;DBXMySQLDriver;bindengine;soaprtl;DBXOracleDriver;CustomIPTransport;dsnap;DBXInformixDriver;IndyCore;fmxase;DBXFirebirdDriver;inet;fmxobj;inetdbxpress;DBXSybaseASADriver;fmxdae;IPIndyImpl;dbexpress;DataSnapIndy10ServerTransport;$(DCC_UsePackage)</DCC_UsePackage>
<DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
<Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon>
<DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput>
<DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput>
<DCC_E>false</DCC_E>
<DCC_N>false</DCC_N>
<DCC_S>false</DCC_S>
<DCC_F>false</DCC_F>
<DCC_K>false</DCC_K>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_UnitSearchPath>.\units;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
<DCC_UsePackage>vcldbx;TeeDB;inetdbbde;vclib;DBXOdbcDriver;Tee;DBXSybaseASEDriver;ibxpress;svnui;vclimg;fmi;intrawebdb_120_160;vclactnband;vcldb;FMXTee;vcldsnap;bindcompvcl;TeeUI;vclie;DBXDb2Driver;Intraweb_120_160;vcltouch;websnap;vclribbon;VclSmp;vcl;DataSnapConnectors;CloudService;DBXMSSQLDriver;FmxTeeUI;dsnapcon;vclx;webdsnap;svn;bdertl;adortl;$(DCC_UsePackage)</DCC_UsePackage>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<VerInfo_Locale>1033</VerInfo_Locale>
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''">
<DCC_UsePackage>DBXOdbcDriver;DBXSybaseASEDriver;vclimg;vclactnband;vcldb;vcldsnap;bindcompvcl;vclie;DBXDb2Driver;vcltouch;websnap;VclSmp;vcl;DBXMSSQLDriver;dsnapcon;vclx;webdsnap;adortl;$(DCC_UsePackage)</DCC_UsePackage>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<Manifest_File>None</Manifest_File>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
<VerInfo_Locale>1049</VerInfo_Locale>
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
<DCC_Optimize>false</DCC_Optimize>
<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
<DCC_DebugInfoInExe>true</DCC_DebugInfoInExe>
<DCC_RemoteDebug>true</DCC_RemoteDebug>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
<DCC_SUSPICIOUS_TYPECAST>false</DCC_SUSPICIOUS_TYPECAST>
<DCC_MapFile>3</DCC_MapFile>
<DCC_Optimize>true</DCC_Optimize>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.435;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
<VerInfo_Build>435</VerInfo_Build>
<Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
<DCC_IOChecking>false</DCC_IOChecking>
<DCC_IntegerOverflowCheck>true</DCC_IntegerOverflowCheck>
<VerInfo_AutoIncVersion>true</VerInfo_AutoIncVersion>
<DCC_RangeChecking>true</DCC_RangeChecking>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<Icon_MainIcon>PROGRAMICON.ico</Icon_MainIcon>
<VerInfo_Locale>1033</VerInfo_Locale>
<DCC_RemoteDebug>false</DCC_RemoteDebug>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_DebugInformation>false</DCC_DebugInformation>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Win32)'!=''">
<DCC_MapFile>3</DCC_MapFile>
<DCC_LocalDebugSymbols>true</DCC_LocalDebugSymbols>
<DCC_Define>madExcept;LeakChecking;$(DCC_Define)</DCC_Define>
<DCC_DebugInformation>true</DCC_DebugInformation>
<VerInfo_Locale>1033</VerInfo_Locale>
<DCC_IOChecking>false</DCC_IOChecking>
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
</PropertyGroup>
<ItemGroup>
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="units\ecc.pas"/>
<DCCReference Include="units\edc.pas"/>
<DCCReference Include="units\uCDIMAGE.pas"/>
<DCCReference Include="Units\uCommon.pas"/>
<DCCReference Include="Units\uMain.pas">
<Form>frmMain</Form>
</DCCReference>
<DCCReference Include="Units\uScanThread.pas"/>
<DCCReference Include="units\uTIM.pas"/>
<DCCReference Include="units\uDrawTIM.pas"/>
<DCCReference Include="units\uEventWaitThread.pas"/>
<DCCReference Include="units\uBrowseForFolder.pas"/>
<BuildConfiguration Include="Release">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
<BuildConfiguration Include="Debug">
<Key>Cfg_1</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Delphi.Personality>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">False</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">1049</VersionInfo>
<VersionInfo Name="CodePage">1251</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName"/>
<VersionInfoKeys Name="FileDescription"/>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"/>
<VersionInfoKeys Name="LegalCopyright"/>
<VersionInfoKeys Name="LegalTrademarks"/>
<VersionInfoKeys Name="OriginalFilename"/>
<VersionInfoKeys Name="ProductName"/>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/>
</VersionInfoKeys>
<Source>
<Source Name="MainSource">tim2view.dpr</Source>
</Source>
<Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\bcboffice2k170.bpl">Embarcadero C++Builder Office 2000 Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\bcbofficexp170.bpl">Embarcadero C++Builder Office XP Servers Package</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k170.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp170.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages>
</Delphi.Personality>
<Deployment/>
<Platforms>
<Platform value="Win32">True</Platform>
<Platform value="Win64">False</Platform>
</Platforms>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/>
<Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/>
</Project>

10
tim2view.dproj.local Normal file
View File

@@ -0,0 +1,10 @@
<?xml version="1.0" encoding="utf-8"?>
<BorlandProject>
<Transactions>
<Transaction>1899.12.30 00:00:00.000.267,D:\Tim2View\units\uTIMClass.pas=</Transaction>
<Transaction>2014.02.18 01:41:36.622,=D:\TimView2\units\EventWaitThread.pas</Transaction>
<Transaction>2014.02.18 02:21:20.250,D:\TimView2\units\BrowseForFolderU.pas=</Transaction>
<Transaction>2014.02.18 02:21:57.121,=D:\TimView2\units\uEventWaitThread.pas</Transaction>
<Transaction>2014.02.18 02:22:03.673,=D:\TimView2\units\uBrowseForFolder.pas</Transaction>
</Transactions>
</BorlandProject>

BIN
tim2view.identcache Normal file
View File

Binary file not shown.

10011
units/NativeXml.pas Normal file
View File

File diff suppressed because it is too large Load Diff

104
units/ecc.pas Normal file
View File

@@ -0,0 +1,104 @@
unit ecc;
interface
uses
uCommon;
const
L1_RAW = 24;
L1_Q = 4;
L1_P = 4;
L2_RAW = (1024 * 2);
L2_Q = (26 * 2 * 2);
L2_P = (43 * 2 * 2);
Procedure encode_L2_Q(Data: PBytesArray);
Procedure encode_L2_P(Data: PBytesArray);
implementation
{$INCLUDE l2sq_table.pas}
Procedure encode_L2_Q(Data: PBytesArray);
var
i, j, PQ, PD, PD_S, PD_P: Integer;
a, b: Word;
begin
// unsigned char inout[4 + L2_RAW + 4 + 8 + L2_P + L2_Q];
PD := 0;
PQ := PD + 4 + L2_RAW + 4 + 8 + L2_P;
// Q := Pointer(LongWord(Data) + 4 + L2_RAW + 4 + 8 + L2_P);
PD_S := PD;
For j := 0 To 26 - 1 do
begin
a := 0;
b := 0;
PD_P := PD_S;
For i := 0 To 43 - 1 do
begin
(* LSB *)
a := a XOR L2sq[i][Data^[PD_P]];
Inc(PD_P);
(* MSB *)
b := b XOR L2sq[i][Data^[PD_P]];
Inc(PD_P, 2 * 44 - 1);
if PD_P >= PD + (4 + L2_RAW + 4 + 8 + L2_P) Then
Dec(PD_P, (4 + L2_RAW + 4 + 8 + L2_P));
end;
Data^[PQ + 0] := a SHR 8;
Move(a, Data^[PQ + 26 * 2], 1);
// Q^[26*2] := a;
Data^[PQ + 1] := b SHR 8;
Move(b, Data^[PQ + 26 * 2 + 1], 1);
// Q^[26*2+1] := b;
Inc(PQ, 2);
Inc(PD_S, 2 * 43);
end;
end;
Procedure encode_L2_P(Data: PBytesArray);
// unsigned char inout[4 + L2_RAW + 4 + 8 + L2_P];
var
i, j, PD, PD_PP, PD_P: Integer;
a, b: Word;
begin
PD := 0;
PD_PP := PD + 4 + L2_RAW + 4 + 8;
// LongWord(P) := PD + 4 + L2_RAW + 4 + 8;
For j := 0 To 43 - 1 do
begin
a := 0;
b := 0;
PD_P := PD;
For i := 19 to 43 - 1 do
begin
(* LSB *)
a := a xor L2sq[i][Data^[PD_P]];
Inc(PD_P);
(* MSB *)
b := b xor L2sq[i][Data^[PD_P]];
Inc(PD_P, 2 * 43 - 1);
end;
Data^[PD_PP + 0] := a SHR 8;
Move(a, Data^[PD_PP + 43 * 2], SizeOf(a));
// P^[43*2] := a;
Data^[PD_PP + 1] := b SHR 8;
Move(b, Data^[PD_PP + 43 * 2 + 1], SizeOf(b));
// P^[43*2+1] := b;
Inc(PD_PP, 2);
Inc(PD, 2);
end;
end;
end.

73
units/edc.pas Normal file
View File

@@ -0,0 +1,73 @@
unit edc;
interface
const
EDC_crctable: Array [Byte] of LongWord = ($00000000, $90910101, $91210201,
$01B00300, $92410401, $02D00500, $03600600, $93F10701, $94810801, $04100900,
$05A00A00, $95310B01, $06C00C00, $96510D01, $97E10E01, $07700F00, $99011001,
$09901100, $08201200, $98B11301, $0B401400, $9BD11501, $9A611601, $0AF01700,
$0D801800, $9D111901, $9CA11A01, $0C301B00, $9FC11C01, $0F501D00, $0EE01E00,
$9E711F01, $82012001, $12902100, $13202200, $83B12301, $10402400, $80D12501,
$81612601, $11F02700, $16802800, $86112901, $87A12A01, $17302B00, $84C12C01,
$14502D00, $15E02E00, $85712F01, $1B003000, $8B913101, $8A213201, $1AB03300,
$89413401, $19D03500, $18603600, $88F13701, $8F813801, $1F103900, $1EA03A00,
$8E313B01, $1DC03C00, $8D513D01, $8CE13E01, $1C703F00, $B4014001, $24904100,
$25204200, $B5B14301, $26404400, $B6D14501, $B7614601, $27F04700, $20804800,
$B0114901, $B1A14A01, $21304B00, $B2C14C01, $22504D00, $23E04E00, $B3714F01,
$2D005000, $BD915101, $BC215201, $2CB05300, $BF415401, $2FD05500, $2E605600,
$BEF15701, $B9815801, $29105900, $28A05A00, $B8315B01, $2BC05C00, $BB515D01,
$BAE15E01, $2A705F00, $36006000, $A6916101, $A7216201, $37B06300, $A4416401,
$34D06500, $35606600, $A5F16701, $A2816801, $32106900, $33A06A00, $A3316B01,
$30C06C00, $A0516D01, $A1E16E01, $31706F00, $AF017001, $3F907100, $3E207200,
$AEB17301, $3D407400, $ADD17501, $AC617601, $3CF07700, $3B807800, $AB117901,
$AAA17A01, $3A307B00, $A9C17C01, $39507D00, $38E07E00, $A8717F01, $D8018001,
$48908100, $49208200, $D9B18301, $4A408400, $DAD18501, $DB618601, $4BF08700,
$4C808800, $DC118901, $DDA18A01, $4D308B00, $DEC18C01, $4E508D00, $4FE08E00,
$DF718F01, $41009000, $D1919101, $D0219201, $40B09300, $D3419401, $43D09500,
$42609600, $D2F19701, $D5819801, $45109900, $44A09A00, $D4319B01, $47C09C00,
$D7519D01, $D6E19E01, $46709F00, $5A00A000, $CA91A101, $CB21A201, $5BB0A300,
$C841A401, $58D0A500, $5960A600, $C9F1A701, $CE81A801, $5E10A900, $5FA0AA00,
$CF31AB01, $5CC0AC00, $CC51AD01, $CDE1AE01, $5D70AF00, $C301B001, $5390B100,
$5220B200, $C2B1B301, $5140B400, $C1D1B501, $C061B601, $50F0B700, $5780B800,
$C711B901, $C6A1BA01, $5630BB00, $C5C1BC01, $5550BD00, $54E0BE00, $C471BF01,
$6C00C000, $FC91C101, $FD21C201, $6DB0C300, $FE41C401, $6ED0C500, $6F60C600,
$FFF1C701, $F881C801, $6810C900, $69A0CA00, $F931CB01, $6AC0CC00, $FA51CD01,
$FBE1CE01, $6B70CF00, $F501D001, $6590D100, $6420D200, $F4B1D301, $6740D400,
$F7D1D501, $F661D601, $66F0D700, $6180D800, $F111D901, $F0A1DA01, $6030DB00,
$F3C1DC01, $6350DD00, $62E0DE00, $F271DF01, $EE01E001, $7E90E100, $7F20E200,
$EFB1E301, $7C40E400, $ECD1E501, $ED61E601, $7DF0E700, $7A80E800, $EA11E901,
$EBA1EA01, $7B30EB00, $E8C1EC01, $7850ED00, $79E0EE00, $E971EF01, $7700F000,
$E791F101, $E621F201, $76B0F300, $E541F401, $75D0F500, $7460F600, $E4F1F701,
$E381F801, $7310F900, $72A0FA00, $E231FB01, $71C0FC00, $E151FD01, $E0E1FE01,
$7070FF00);
Function build_edc(Data: Pointer; Size: Integer): LongWord;
implementation
Function build_edc(Data: Pointer; Size: Integer): LongWord;
var
P: PByte;
begin
P := Data;
Result := 0;
Size := Size div 4;
while (Size > 0) do
begin
Dec(Size);
// result = EDC_crctable[(result ^ *p++) & 0xffL] ^ (result >> 8);
If Result = $2D5E3B78 Then
ReadLn;
Result := EDC_crctable[(Result xor P^) and $FF] xor (Result SHR 8);
Inc(P);
Result := EDC_crctable[(Result xor P^) and $FF] xor (Result SHR 8);
Inc(P);
Result := EDC_crctable[(Result xor P^) and $FF] xor (Result SHR 8);
Inc(P);
Result := EDC_crctable[(Result xor P^) and $FF] xor (Result SHR 8);
Inc(P);
end;
end;
end.

1164
units/l2sq_table.pas Normal file
View File

File diff suppressed because it is too large Load Diff

219
units/sdDebug.pas Normal file
View File

@@ -0,0 +1,219 @@
{ unit sdDebug
universal method for debugging
Exceptions often are a hindrance, so instead use these classes
to give important info to the application or user with these
three basic classes
Besides debug methods, this unit also defines a few compatibility types:
The include file simdesign.inc defines $D5UP and after the
uses-clause these types for D5 are defined. This way, many simdesign
projects are compatible with Delphi 5.
fpc: if lazarus + freepascal is defined, Utf8String just reverts to "string".
Author: Nils Haeck M.Sc.
Original Date: 08nov2010
copyright (c) SimDesign BV (www.simdesign.nl)
}
unit sdDebug;
{$i simdesign.inc}
interface
uses
Classes;
{$ifdef D5UP}
// D5 compatibility types
const
MinsPerHour = 60;
MinsPerDay = MinsPerHour * 24;
soCurrent = soFromCurrent;
soBeginning = soFromBeginning;
soEnd = soFromEnd;
type
Utf8String = AnsiString;
TSeekOrigin = word;
PIntegerArray = ^TIntegerArray;
TIntegerArray = array of Integer;
PByte = ^Byte;
PInteger = ^Integer;
PSingle = ^Single;
PDouble = ^Double;
// TFormatSettings stub
TFormatSettings = record
end;
PWord = ^Word;
function StrToFloatDef(S: AnsiString; Default: Double; AFormatSettings: TFormatSettings): Double;
function StrToBool(S: AnsiString): Boolean;
function StrToBoolDef(S: AnsiString; Default: Boolean): Boolean;
{$endif}
// lazarus compatibility
{$ifdef fpc}
type
Utf8String = string;
{$endif fpc}
// Delphi unicode compatibility
{$ifndef UNICODE}
type
UnicodeString = WideString;
RawByteString = AnsiString;
{$endif UNICODE}
type
TsdWarnStyle = (wsInfo, wsHint, wsWarn, wsFail);
const
cWarnStyleNames: array[TsdWarnStyle] of Utf8String = ('info', 'hint', 'warn', 'fail');
type
// event with debug data
TsdDebugEvent = procedure(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String) of object;
// simple update event
TsdUpdateEvent = procedure(Sender: TObject) of object;
TDebugComponent = class(TComponent)
protected
FOnDebugOut: TsdDebugEvent;
public
procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual;
// Connect to OnDebugOut to get debug information in the client application
property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut;
end;
TDebugObject = class(TObject)
protected
FOnDebugOut: TsdDebugEvent;
procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual;
public
property OnDebugOut: TsdDebugEvent read FOnDebugOut write FOnDebugOut;
end;
TDebugPersistent = class(TPersistent)
protected
FOwner: TDebugComponent;
procedure DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String); virtual;
public
constructor CreateDebug(AOwner: TDebugComponent); virtual;
end;
{ Functions }
function sdDebugMessageToString(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String): Utf8String;
function sdClassName(AObject: TObject): Utf8String;
implementation
{$ifdef D5UP}
// D5 compatibility types
uses
SysUtils;
function StrToFloatDef(S: AnsiString; Default: Double; AFormatSettings: TFormatSettings): Double;
begin
try
Result:= StrToFloat(S);
except
Result:= Default;
end;
end;
// Only basic support
function StrToBool(S: AnsiString): Boolean;
begin
S := LowerCase(S);
if (S = 'no') or (S = '0') or (S = 'false') then
Result := False
else
if (S = 'yes') or (S = '1') or (S = 'true') then
Result:= True
else
raise EConvertError.Create('');
end;
function StrToBoolDef(S: AnsiString; Default: Boolean): Boolean;
begin
try
Result := StrToBool(S);
except
Result := Default;
end;
end;
{$endif}
{ TDebugComponent }
procedure TDebugComponent.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String);
var
AOwner: TComponent;
begin
AOwner := Self;
while AOwner is TDebugComponent do
begin
if assigned(TDebugComponent(AOwner).FOnDebugOut) then
begin
TDebugComponent(AOwner).FOnDebugOut(Sender, WarnStyle, AMessage);
exit;
end;
AOwner := AOwner.Owner;
end;
end;
{ TDebugObject }
procedure TDebugObject.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String);
begin
if assigned(FOnDebugOut) then
FOnDebugOut(Sender, WarnStyle, AMessage);
end;
{ TDebugPersistent }
constructor TDebugPersistent.CreateDebug(AOwner: TDebugComponent);
begin
inherited Create;
FOwner := AOwner;
end;
procedure TDebugPersistent.DoDebugOut(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String);
begin
if FOwner is TDebugComponent then
TDebugComponent(FOwner).DoDebugOut(Sender, WarnStyle, AMessage);
end;
{ Functions }
function sdDebugMessageToString(Sender: TObject; WarnStyle: TsdWarnStyle; const AMessage: Utf8String): Utf8String;
var
SenderString: Utf8String;
begin
if assigned(Sender) then
SenderString := Utf8String(Sender.ClassName)
else
SenderString := '';
Result := '[' + cWarnStyleNames[WarnStyle] + '] ' + SenderString + ': ' + AMessage;
end;
function sdClassName(AObject: TObject): Utf8String;
begin
Result := 'nil';
if assigned(AObject) then
Result := Utf8String(AObject.ClassName);
end;
end.

309
units/sdStreams.pas Normal file
View File

@@ -0,0 +1,309 @@
{ sdStreams.pas
- TsdFastMemStream with improved capacity setting
- TsdStringStream
- TsdBufferWriter
Author: Nils Haeck M.Sc.
copyright (c) 2002 - 2011 SimDesign BV (www.simdesign.nl)
}
unit sdStreams;
{$ifdef lcl}{$MODE Delphi}{$endif}
{$define simdesign.inc}
interface
uses
Classes, SysUtils, sdDebug;
type
// TsdFastMemStream deals differently with capacity compared to a normal
// TMemoryStream; it increases the capacity with the natural growing function
// (fibonacci) each time, and has an initial capacity of $1000. The initial
// capacity is configurable with the create parameter.
TsdFastMemStream = class(TStream)
private
FMemory: Pointer;
FPosition: longint;
FFib1: longint;
FCapacity: longint;
FSize: longint;
protected
procedure SetCapacity(Value: longint);
procedure SetSize(NewSize: Longint); override;
public
constructor Create(InitialCapacity: longint = $1000);
destructor Destroy; override;
procedure Clear;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure LoadFromFile(AFilename: string);
procedure LoadFromStream(Stream: TStream);
procedure SaveToFile(AFilename: string);
procedure SaveToStream(Stream: TStream);
property Memory: Pointer read FMemory;
property Size: longint read FSize write SetSize;
end;
// Delphi's implementation of TStringStream is severely flawed, it does a SetLength
// on each write, which slows down everything to a crawl. This implementation over-
// comes this issue.
TsdStringStream = class(TsdFastMemStream)
public
constructor Create(const S: Utf8String);
function DataString: Utf8String;
end;
// TsdBufferWriter is a buffered stream that takes another stream (ASource)
// and writes only buffer-wise to it, and writes to the stream are first
// done to the buffer. This stream type can only support writing.
TsdBufferWriter = class(TsdFastMemStream)
private
FSource: TStream;
FChunkSize: integer;
FRawBuffer: array of byte;
FRawPosition: Integer;
protected
procedure WriteChunk(Count: integer);
public
// Create the buffered writer stream by passing the destination stream in ASource,
// this destination stream must already be initialized.
constructor Create(ASource: TStream; AChunkSize: integer);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
end;
implementation
{ TsdFastMemStream }
procedure TsdFastMemStream.Clear;
begin
SetCapacity(0);
FSize := 0;
FPosition := 0;
end;
constructor TsdFastMemStream.Create(InitialCapacity: Integer);
begin
inherited Create;
FFib1 := InitialCapacity div 2;
FCapacity := InitialCapacity;
if FFib1 < 4 then
FFib1 := 4;
if FCapacity < 4 then
FCapacity := 4;
ReallocMem(FMemory, FCapacity);
end;
destructor TsdFastMemStream.Destroy;
begin
ReallocMem(FMemory, 0);
inherited;
end;
procedure TsdFastMemStream.LoadFromFile(AFilename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TsdFastMemStream.LoadFromStream(Stream: TStream);
var
Count: Longint;
begin
Stream.Position := 0;
Count := Stream.Size;
SetSize(Count);
if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
end;
function TsdFastMemStream.Read(var Buffer; Count: Integer): Longint;
begin
if (FPosition >= 0) and (Count >= 0) then
begin
Result := FSize - FPosition;
if Result > 0 then
begin
if Result > Count then
Result := Count;
Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
Inc(FPosition, Result);
Exit;
end;
end;
Result := 0;
end;
procedure TsdFastMemStream.SaveToFile(AFilename: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(AFileName, fmCreate);
try
SaveToStream(Stream);
finally
Stream.Free;
end;
end;
procedure TsdFastMemStream.SaveToStream(Stream: TStream);
begin
if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
end;
function TsdFastMemStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
case Origin of
soFromBeginning: FPosition := Offset;
soFromCurrent: Inc(FPosition, Offset);
soFromEnd: FPosition := FSize + Offset;
end;
Result := FPosition;
end;
procedure TsdFastMemStream.SetCapacity(Value: longint);
// Fibonacci 0,1,1,2,3,5,8,... FCapacity is Fib2.
// Fibonacci is a natural growing function where
// 0 + 1 = 1; 1 + 1 = 2; 1 + 2 = 3; 2 + 3 = 5; etc
var
Fib3: longint;
begin
while FCapacity < Value do
begin
Fib3 := FFib1 + FCapacity;
FFib1 := FCapacity;
FCapacity := Fib3;
end;
ReallocMem(FMemory, FCapacity);
end;
procedure TsdFastMemStream.SetSize(NewSize: longint);
var
OldPosition: Longint;
begin
OldPosition := FPosition;
SetCapacity(NewSize);
FSize := NewSize;
if OldPosition > NewSize then
Seek(0, soFromEnd);
end;
function TsdFastMemStream.Write(const Buffer; Count: Integer): Longint;
var
NewPos: Longint;
begin
if (FPosition >= 0) and (Count >= 0) then
begin
NewPos := FPosition + Count;
if NewPos > 0 then
begin
if NewPos > FSize then
begin
if NewPos > FCapacity then
SetCapacity(NewPos);
FSize := NewPos;
end;
System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
FPosition := NewPos;
Result := Count;
Exit;
end;
end;
Result := 0;
end;
{ TsdStringStream }
constructor TsdStringStream.Create(const S: Utf8String);
begin
inherited Create;
SetSize(length(S));
if Size > 0 then
begin
Write(S[1], Size);
Position := 0;
end;
end;
function TsdStringStream.DataString: Utf8String;
begin
SetLength(Result, Size);
if Size > 0 then
begin
Position := 0;
Read(Result[1], length(Result));
end;
end;
{ TsdBufferWriter }
constructor TsdBufferWriter.Create(ASource: TStream; AChunkSize: integer);
begin
inherited Create;
FSource := ASource;
FChunkSize := AChunkSize;
SetLength(FRawBuffer, FChunkSize);
end;
destructor TsdBufferWriter.Destroy;
begin
// write the last chunk, if any
WriteChunk(FRawPosition);
// free the rawbuffer
SetLength(FRawBuffer, 0);
inherited;
end;
function TsdBufferWriter.Read(var Buffer; Count: Integer): Longint;
begin
// not implemented
raise Exception.Create('not implemented');
end;
function TsdBufferWriter.Write(const Buffer; Count: Integer): Longint;
var
Idx, Siz: integer;
begin
// index in the source buffer
Idx := 0;
// remaining size
Siz := Count;
// surplus
while FRawPosition + Siz >= FChunkSize do
begin
Move(TByteArray(Buffer)[Idx], FRawBuffer[FRawPosition], FChunkSize - FRawPosition);
WriteChunk(FChunkSize);
dec(Siz, FChunkSize - FRawPosition);
inc(Idx, FChunkSize - FRawPosition);
FRawPosition := 0;
end;
// copy the raw buffer
Move(TByteArray(Buffer)[Idx], FRawBuffer[FRawPosition], Siz);
inc(FRawPosition, Siz);
Result := Count;
end;
procedure TsdBufferWriter.WriteChunk(Count: integer);
begin
if Count > 0 then
begin
FSource.WriteBuffer(FRawBuffer[0], Count);
end;
end;
end.

765
units/sdStringTable.pas Normal file
View File

@@ -0,0 +1,765 @@
{ unit sdStringTable
An optimized table of *unique* strings, using two separate sorted indices:
- by (string) ID
- by sdCompareRefString method
The sdCompareRefString method does not use common alphabetical compare, but
rather a comparison from first character, then last character, then 2nd,
then before-last, etc. until all characters are compared, or a mismatch is
found.
Since many (programmer) strings have numbers at the end of the string,
(e.g. "MyNewNode1", "MyNewNode2", etc), the comparison terminates earlier than
with a common alphabetical compare.
sdStringTable is used by NativeXml but can also be used independently in
your projects.
Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl)
Original Date: 28 May 2007
Modified:
05jan2011: enhancement, no longer uses stringrec
17jun2011: changed TStringTable ancestor from TDebugPersistent to TDebugComponent
24jun2011: "find" fix
18jul2011: renamed TsdStringTable to TsdSymbolTable and added TsdSymbolStyle
It is NOT allowed under ANY circumstances to publish or copy this code
without accepting the license conditions in accompanying LICENSE.txt
first!
This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
ANY KIND, either express or implied.
Please visit http://www.simdesign.nl/xml.html for more information.
Copyright (c) 2007 - 2011 Simdesign BV
}
unit sdStringTable;
{$ifdef lcl}{$MODE Delphi}{$endif}
interface
uses
Classes, SysUtils, Contnrs, sdDebug;
// symbol styles (cardinal)
// Default symbol style is ssUnknown, but highlevel code can
// distinguish between symbol styles. TsdSymbolTable just stores
// the symbol as counted Utf8String.
const
ssUnknown = 0; // data not determined yet
ssString = 1; // data is a string
ssBase64Binary = 2; // data is binary and will be handled by Base64 funcs
ssHexBinary = 3; // data is binary and will be handled by BinHex funcs
ssBoolean = 4; // boolean (stored in a byte, just 0 and 1 of cardinal)
ssCardinal = 5; // cardinal (1..N bytes, see TBinaryXml.ReadCardinal)
ssInteger = 6; // integer (1..N bytes)
ssDecimal = 7; // decimal value (see TNativeXml.EncodeDecimalSymbol)
ssDate = 8; // date (see TNativeXml.EncodeDateSymbol)
ssTime = 9; // time (see TNativeXml.EncodeTimeSymbol)
ssDateTime = 10; // datetime (see TNativeXml.EncodeDateTimeSymbol)
// These were the default symbol styles as used by NativeXml. Other units may
// define more symbols after the last default symbol
type
// A symbol table, holding a collection of unique strings, sorted in 2 ways
// for fast access. Strings can be added with AddString or AddStringRec.
// When a string is added or updated, an ID is returned which the application
// can use to retrieve the string, using GetString.
TsdSymbolTable = class(TDebugComponent)
private
FByID: TObjectList;
FBySymbol: TObjectList;
FPluralSymbolCount: integer;
function GetSymbolCount: integer;
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// Clear the string table
procedure Clear;
// Add a potentially new string S to the table, the function
// returns its string ID.
function AddString(const S: Utf8String): integer;
// retrieve the string based on its string ID. The string ID is only unique
// within this string table, so do not use IDs from other tables.
function GetString(ID: integer): Utf8String;
// total number of symbols in the table
property SymbolCount: integer read GetSymbolCount;
// plural symbols in the table. plural symbols are symbols that have
// a frequency > 1. ie the symbol is found more than once in the app.
// PluralCount is only valid after method SortByFrequency.
property PluralSymbolCount: integer read FPluralSymbolCount;
procedure LoadFromFile(const AFileName: string);
procedure LoadFromStream(S: TStream);
function LoadSymbol(S: TStream): Cardinal;
procedure SaveToFile(const AFileName: string);
procedure SaveToStream(S: TStream; ACount: integer);
procedure SaveSymbol(S: TStream; ASymbolID: Cardinal);
procedure ClearFrequency;
procedure IncrementFrequency(ID: integer);
procedure SortByFrequency(var ANewIDs: array of Cardinal);
end;
{utility functions}
// compare two bytes
function sdCompareByte(Byte1, Byte2: byte): integer;
// compare two integers
function sdCompareInteger(Int1, Int2: integer): integer;
// unicode UTF8 <> UTF16LE coversion functions
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
// stream methods
function sdStreamReadCardinal(S: TStream): Cardinal;
function sdStreamReadString(S: TStream; ACharCount: Cardinal): Utf8String;
procedure sdStreamWriteCardinal(S: TStream; ACardinal: Cardinal);
procedure sdStreamWriteString(S: TStream; const AString: Utf8String);
implementation
type
// A symbol item used in symbol lists (do not use directly)
TsdSymbol = class
private
FID: integer;
FFreq: Cardinal;
FSymbolStyle: Cardinal;
FFirst: Pbyte;
FCharCount: integer;
public
destructor Destroy; override;
function AsString: Utf8String;
property SymbolStyle: Cardinal read FSymbolStyle;
property CharCount: integer read FCharCount;
end;
// A list of symbols (do not use directly)
TsdSymbolList = class(TObjectList)
private
function GetItems(Index: integer): TsdSymbol;
protected
// Assumes list is sorted by refstring
function Find(ASymbol: TsdSymbol; var Index: integer): boolean;
public
property Items[Index: integer]: TsdSymbol read GetItems; default;
end;
// compare two symbols. This is NOT an alphabetic compare. symbols are first
// compared by length, then by first byte, then last byte then second, then
// N-1, until all bytes are compared.
function sdCompareSymbol(Symbol1, Symbol2: TsdSymbol): integer;
var
CharCount: integer;
First1, First2, Last1, Last2: Pbyte;
IsEqual: boolean;
begin
// Compare string length first
Result := sdCompareInteger(Symbol1.CharCount, Symbol2.CharCount);
if Result <> 0 then
exit;
// Compare FFirst
Result := sdCompareByte(Symbol1.FFirst^, Symbol2.FFirst^);
if Result <> 0 then
exit;
// CharCount of RS1 (and RS2, since they are equal)
CharCount := Symbol1.CharCount;
// Setup First & Last pointers
First1 := Symbol1.FFirst;
First2 := Symbol2.FFirst;
// compare memory (boolean op). CompareMem might have optimized code depending
// on memory manager (ASM, MMX, SSE etc) to binary compare the block.
// Since sdCompareRefString may be used to compare relatively large blocks of
// text, which are often exact copies, using CompareMem before special comparison
// is warrented.
IsEqual := CompareMem(First1, First2, CharCount);
if IsEqual then
begin
Result := 0;
exit;
end;
// finally the special conparison: Compare each time last ptrs then first ptrs,
// until they meet in the middle
Last1 := First1;
inc(Last1, CharCount);
Last2 := First2;
inc(Last2, CharCount);
repeat
dec(Last1);
dec(Last2);
if First1 = Last1 then
exit;
Result := sdCompareByte(Last1^, Last2^);
if Result <> 0 then
exit;
inc(First1);
inc(First2);
if First1 = Last1 then
exit;
Result := sdCompareByte(First1^, First2^);
if Result <> 0 then
exit;
until False;
end;
{ TsdSymbol }
function TsdSymbol.AsString: Utf8String;
begin
SetString(Result, PAnsiChar(FFirst), FCharCount);
end;
destructor TsdSymbol.Destroy;
begin
FreeMem(FFirst);
inherited;
end;
{ TsdSymbolList }
function TsdSymbolList.GetItems(Index: integer): TsdSymbol;
begin
Result := Get(Index);
end;
function TsdSymbolList.Find(ASymbol: TsdSymbol; var Index: integer): boolean;
var
AMin, AMax: integer;
begin
Result := False;
// Find position - binary method
AMin := 0;
AMax := Count;
while AMin < AMax do
begin
Index := (AMin + AMax) div 2;
case sdCompareSymbol(Items[Index], ASymbol) of
-1: AMin := Index + 1;
0: begin
Result := True;
exit;
end;
1: AMax := Index;
end;
end;
Index := AMin;
end;
{ TsdSymbolTable }
function TsdSymbolTable.AddString(const S: Utf8String): integer;
var
Found: boolean;
L, BySymbolIndex: integer;
ASymbol, Item: TsdSymbol;
begin
Result := 0;
L := length(S);
// zero-length string
if L = 0 then
exit;
ASymbol := TsdSymbol.Create;
try
ASymbol.FFirst := PByte(@S[1]);
ASymbol.FCharCount := L;
// Try to find the new string
Found := TsdSymbolList(FBySymbol).Find(ASymbol, BySymbolIndex);
if Found then
begin
// yes it is found
Item := TsdSymbol(FBySymbol[BySymbolIndex]);
Result := Item.FID;
exit;
end;
// Not found.. must make new item
Item := TsdSymbol.Create;
Item.FCharCount := ASymbol.FCharCount;
// reallocate memory and copy the string data
ReallocMem(Item.FFirst, Item.FCharCount);
Move(S[1], Item.FFirst^, Item.FCharCount);
// add to the ByID objectlist
FByID.Add(Item);
Item.FID := FByID.Count;
Result := Item.FID;
// insert into the ByRS list
FBySymbol.Insert(BySymbolIndex, Item);
finally
// this ensures we do not deallocate the memory that may be in use elsewhere
ASymbol.FFirst := nil;
ASymbol.Free;
end;
end;
procedure TsdSymbolTable.Clear;
begin
FByID.Clear;
FBySymbol.Clear;
end;
procedure TsdSymbolTable.ClearFrequency;
var
i: integer;
begin
for i := 0 to FByID.Count - 1 do
TsdSymbol(FByID[i]).FFreq := 0;
end;
constructor TsdSymbolTable.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FByID := TObjectList.Create(True);
FBySymbol := TsdSymbolList.Create(False);
end;
destructor TsdSymbolTable.Destroy;
begin
FreeAndNil(FBySymbol);
FreeAndNil(FByID);
inherited;
end;
function TsdSymbolTable.GetSymbolCount: integer;
begin
Result := FByID.Count;
end;
function TsdSymbolTable.GetString(ID: integer): Utf8String;
begin
// Find the ID
// zero string
if ID <= 0 then
begin
Result := '';
exit;
end;
// out of bounds?
if ID > FByID.Count then
begin
// output warning
DoDebugOut(Self, wsWarn, 'string ID not found');
Result := '';
end;
Result := TsdSymbol(FByID[ID - 1]).AsString;
end;
procedure TsdSymbolTable.IncrementFrequency(ID: integer);
var
RS: TsdSymbol;
begin
RS := TsdSymbol(FByID[ID - 1]);
inc(RS.FFreq);
end;
procedure TsdSymbolTable.LoadFromFile(const AFileName: string);
var
S: TMemoryStream;
begin
S := TMemoryStream.Create;
try
S.LoadFromFile(AFileName);
LoadFromStream(S);
finally
S.Free;
end;
end;
procedure TsdSymbolTable.LoadFromStream(S: TStream);
var
i: integer;
TableCount: Cardinal;
begin
Clear;
// DoDebugOut(Self, wsInfo, format('stream position: %d', [S.Position]));
// table count
TableCount := sdStreamReadCardinal(S);
if TableCount = 0 then
exit;
for i := 0 to TableCount - 1 do
begin
LoadSymbol(S);
end;
end;
function TsdSymbolTable.LoadSymbol(S: TStream): Cardinal;
var
Symbol: TsdSymbol;
BySymbolIndex: integer;
Found: boolean;
begin
Symbol := TsdSymbol.Create;
// For now, we just use ssString uniquely as symbol style,.
// In updates, different symbol styles can be added.
Symbol.FSymbolStyle := sdStreamReadCardinal(S);
Symbol.FCharCount := sdStreamReadCardinal(S);
if Symbol.FCharCount > 0 then
begin
// reallocate memory and copy the string data
ReallocMem(Symbol.FFirst, Symbol.FCharCount);
S.Read(Symbol.FFirst^, Symbol.FCharCount);
end;
// add to the ByID objectlist
FByID.Add(Symbol);
Symbol.FID := FByID.Count;
Result := Symbol.FID;
// find the symbol
Found := TsdSymbolList(FBySymbol).Find(Symbol, BySymbolIndex);
if Found then
begin
DoDebugOut(Self, wsFail, 'duplicate symbol!');
exit;
end;
// insert into the ByRS list
FBySymbol.Insert(BySymbolIndex, Symbol);
end;
procedure TsdSymbolTable.SaveToFile(const AFileName: string);
var
S: TMemoryStream;
begin
S := TMemoryStream.Create;
try
SaveToStream(S, SymbolCount);
S.SaveToFile(AFileName);
finally
S.Free;
end;
end;
procedure TsdSymbolTable.SaveToStream(S: TStream; ACount: integer);
var
i: integer;
begin
// write (part of the) symbol table
sdStreamWriteCardinal(S, ACount);
for i := 0 to ACount - 1 do
begin
SaveSymbol(S, i + 1);
end;
end;
procedure TsdSymbolTable.SaveSymbol(S: TStream; ASymbolID: Cardinal);
var
RS: TsdSymbol;
StringVal: Utf8String;
CharCount: Cardinal;
begin
if ASymbolID <= 0 then
DoDebugOut(Self, wsFail, 'symbol ID <= 0');
RS := TsdSymbol(FByID[ASymbolID - 1]);
// For now, we just use ssString uniquely as symbol style.
// In updates, different symbol styles can be added.
sdStreamWriteCardinal(S, RS.SymbolStyle);
StringVal := RS.AsString;
CharCount := length(StringVal);
sdStreamWriteCardinal(S, CharCount);
sdStreamWriteString(S, StringVal);
end;
procedure TsdSymbolTable.SortByFrequency(var ANewIDs: array of Cardinal);
// local
function CompareFreq(Pos1, Pos2: integer): integer;
var
RS1, RS2: TsdSymbol;
begin
RS1 := TsdSymbol(FByID[Pos1]);
RS2 := TsdSymbol(FByID[Pos2]);
if RS1.FFreq > RS2.FFreq then
Result := -1
else
if RS1.FFreq < RS2.FFreq then
Result := 1
else
Result := 0;
end;
// local
procedure QuickSort(iLo, iHi: Integer);
var
Lo, Hi, Mid: longint;
begin
Lo := iLo;
Hi := iHi;
Mid:= (Lo + Hi) div 2;
repeat
while CompareFreq(Lo, Mid) < 0 do
Inc(Lo);
while CompareFreq(Hi, Mid) > 0 do
Dec(Hi);
if Lo <= Hi then
begin
// Swap pointers;
FByID.Exchange(Lo, Hi);
if Mid = Lo then
Mid := Hi
else
if Mid = Hi then
Mid := Lo;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then
QuickSort(iLo, Hi);
if Lo < iHi then
QuickSort(Lo, iHi);
end;
// main
var
i: integer;
begin
// sort by frequency
QuickSort(0, FByID.Count - 1);
// plural count
FPluralSymbolCount := 0;
i := 0;
while i < FByID.Count do
begin
if TsdSymbol(FByID[i]).FFreq >= 2 then
inc(FPluralSymbolCount)
else
break;
inc(i);
end;
// tell app about new ID
for i := 0 to FByID.Count - 1 do
begin
ANewIDs[TsdSymbol(FByID[i]).FID] := i + 1;
end;
// then rename IDs
for i := 0 to FByID.Count - 1 do
begin
TsdSymbol(FByID[i]).FID := i + 1;
end;
end;
{utility functions}
function sdCompareByte(Byte1, Byte2: byte): integer;
begin
if Byte1 < Byte2 then
Result := -1
else
if Byte1 > Byte2 then
Result := 1
else
Result := 0;
end;
function sdCompareInteger(Int1, Int2: integer): integer;
begin
if Int1 < Int2 then
Result := -1
else
if Int1 > Int2 then
Result := 1
else
Result := 0;
end;
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
// Convert an Unicode (UTF16 LE) memory block to UTF8. This routine will process
// Count wide characters (2 bytes size) to Count UTF8 characters (1-3 bytes).
// Therefore, the block at Dst must be at least 1.5 the size of the source block.
// The function returns the number of *bytes* written.
var
W: word;
DStart: Pbyte;
begin
DStart := Dst;
while Count > 0 do
begin
W := Src^;
inc(Src);
if W <= $7F then
begin
Dst^ := byte(W);
inc(Dst);
end else
begin
if W > $7FF then
begin
Dst^ := byte($E0 or (W shr 12));
inc(Dst);
Dst^ := byte($80 or ((W shr 6) and $3F));
inc(Dst);
Dst^ := byte($80 or (W and $3F));
inc(Dst);
end else
begin // $7F < W <= $7FF
Dst^ := byte($C0 or (W shr 6));
inc(Dst);
Dst^ := byte($80 or (W and $3F));
inc(Dst);
end;
end;
dec(Count);
end;
Result := integer(Dst) - integer(DStart);
end;
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
// Convert an UTF8 memory block to Unicode (UTF16 LE). This routine will process
// Count *bytes* of UTF8 (each character 1-3 bytes) into UTF16 (each char 2 bytes).
// Therefore, the block at Dst must be at least 2 times the size of Count, since
// many UTF8 characters consist of just one byte, and are mapped to 2 bytes. The
// function returns the number of *wide chars* written. Note that the Src block must
// have an exact number of UTF8 characters in it, if Count doesn't match then
// the last character will be converted anyway (going past the block boundary!)
var
W: word;
C: byte;
DStart: Pword;
SClose: Pbyte;
begin
DStart := Dst;
SClose := Src;
inc(SClose, Count);
while integer(Src) < integer(SClose) do
begin
// 1st byte
W := Src^;
inc(Src);
if W and $80 <> 0 then
begin
W := W and $3F;
if W and $20 <> 0 then
begin
// 2nd byte
C := Src^;
inc(Src);
if C and $C0 <> $80 then
// malformed trail byte or out of range char
Continue;
W := (W shl 6) or (C and $3F);
end;
// 2nd or 3rd byte
C := Src^;
inc(Src);
if C and $C0 <> $80 then
// malformed trail byte
Continue;
Dst^ := (W shl 6) or (C and $3F);
inc(Dst);
end else
begin
Dst^ := W;
inc(Dst);
end;
end;
Result := (integer(Dst) - integer(DStart)) div 2;
end;
{ stream methods }
function sdStreamReadCardinal(S: TStream): Cardinal;
var
C: byte;
Bits: integer;
begin
Result := 0;
Bits := 0;
repeat
S.Read(C, 1);
if C > 0 then
begin
inc(Result, (C and $7F) shl Bits);
inc(Bits, 7)
end;
until(C and $80) = 0;
end;
function sdStreamReadString(S: TStream; ACharCount: Cardinal): Utf8String;
begin
SetLength(Result, ACharCount);
if ACharCount = 0 then
exit;
S.Read(Result[1], ACharCount);
end;
procedure sdStreamWriteCardinal(S: TStream; ACardinal: Cardinal);
var
C: byte;
begin
repeat
if ACardinal <= $7F then
begin
C := ACardinal;
S.Write(C, 1);
exit;
end else
C := (ACardinal and $7F) or $80;
S.Write(C, 1);
ACardinal := ACardinal shr 7;
until ACardinal = 0;
end;
procedure sdStreamWriteString(S: TStream; const AString: Utf8String);
var
L: integer;
begin
L := Length(AString);
if L > 0 then
begin
S.Write(AString[1], L);
end;
end;
end.

95
units/simdesign.inc Normal file
View File

@@ -0,0 +1,95 @@
{ simdesign.inc
include file for many simdesign projects
default path: \simlib\general
Author: Nils Haeck M.Sc.
Copyright (c) 2007 - 2011 Simdesign B.V.
}
// unicode avoid implicit string cast warning
{$ifdef UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$endif UNICODE}
// Delphi and FPC versions
// Freepascal
{$ifdef FPC}
{$MODE DELPHI}
{$define D7UP}
{$endif FPC}
// Delphi 5
{$ifdef VER130}
{$define D5UP}
{$endif}
//Delphi 6
{$ifdef VER140}
{$define D5UP}
{$endif}
//Delphi 7
{$ifdef VER150}
{$define D7UP}
{$endif}
//Delphi 8
{$ifdef VER160}
{$define D7UP}
{$endif}
// Delphi 2005 / 9
{$ifdef VER170}
{$define D7UP}
{$endif}
// Delphi 2006 / 10
{$ifdef VER180}
{$define D7UP}
// D10 publishes OnMouseEnter / OnMouseLeave
{$define D10UP}
{$endif}
// Delphi 2007 Rad studio / 11?
{$ifdef VER185}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi 2007 - NET / 11?
{$ifdef VER190}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi 2009 / 12
// first UNICODE version, so then directive UNICODE is defined, no need for directive D12UP
{$ifdef VER200}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi 2010 / 14?
{$ifdef VER210}
{$define D7UP}
{$define D10UP}
{$endif}
// Delphi XE / 15
{$ifdef VER220}
{$define D7UP}
{$define D10UP}
{$define D15UP}
{$endif}
// Delphi XE2 / 16
{$ifdef VER230}
{$define D7UP}
{$define D10UP}
{$define D15UP}
{$endif}

73
units/uBrowseForFolder.pas Normal file
View File

@@ -0,0 +1,73 @@
unit uBrowseForFolder;
interface
function BrowseForFolder(const appHWND: THandle; const browseTitle: String;
const initialFolder: String = ''): String;
implementation
uses
Windows, shlobj;
var
lg_StartFolder: String;
/// /////////////////////////////////////////////////////////////////////
// Call back function used to set the initial browse directory.
/// /////////////////////////////////////////////////////////////////////
function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam)
: Integer stdcall;
begin
if uMsg = BFFM_INITIALIZED then
SendMessage(Wnd, BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1]));
result := 0;
end;
/// /////////////////////////////////////////////////////////////////////
// This function allows the user to browse for a folder
//
// Arguments:-
// browseTitle : The title to display on the browse dialog.
// initialFolder : Optional argument. Use to specify the folder
// initially selected when the dialog opens.
// mayCreateNewFolder : Flag indicating whether the user can create a
// new folder.
//
// Returns: The empty string if no folder was selected (i.e. if the user
// clicked cancel), otherwise the full folder path.
/// /////////////////////////////////////////////////////////////////////
function BrowseForFolder(const appHWND: THandle; const browseTitle: String;
const initialFolder: String = ''): String;
var
browse_info: TBrowseInfo;
folder: array [0 .. MAX_PATH] of char;
find_context: PItemIDList;
begin
// --------------------------
// Initialise the structure.
// --------------------------
FillChar(browse_info, SizeOf(browse_info), #0);
lg_StartFolder := initialFolder;
browse_info.pszDisplayName := @folder[0];
browse_info.lpszTitle := PChar(browseTitle);
browse_info.ulFlags := BIF_DONTGOBELOWDOMAIN or BIF_RETURNONLYFSDIRS or
BIF_STATUSTEXT or BIF_VALIDATE or BIF_USENEWUI or BIF_NONEWFOLDERBUTTON;
browse_info.hwndOwner := appHWND;
if initialFolder <> '' then
browse_info.lpfn := BrowseForFolderCallBack;
find_context := SHBrowseForFolder(browse_info);
if Assigned(find_context) then
begin
if SHGetPathFromIDList(find_context, folder) then
result := folder
else
result := '';
GlobalFreePtr(find_context);
end
else
result := '';
end;
end.

227
units/uCDIMAGE.pas Normal file
View File

@@ -0,0 +1,227 @@
unit uCDIMAGE;
interface
uses
Windows, uTIM;
const
cSectorHeaderSize = 12;
cSectorAddressSize = 3;
cSectorModeSize = 1;
cSectorSubHeaderSize = 8;
cSectorInfoSize = cSectorHeaderSize + cSectorAddressSize + cSectorModeSize +
cSectorSubHeaderSize;
cSectorDataSize = 2048;
cSectorECCSize = 4;
cSectorEDCSize = 276;
cSectorECCEDCSize = cSectorECCSize + cSectorEDCSize;
cSectorSize = cSectorInfoSize + cSectorDataSize + cSectorECCEDCSize;
type
TCDSector = packed record
dwHeader: array [0 .. cSectorHeaderSize - 1] of byte;
dwAddress: array [0 .. cSectorAddressSize - 1] of byte;
bMode: byte;
dwSubHeader: array [0 .. cSectorSubHeaderSize - 1] of byte;
dwData: array [0 .. cSectorDataSize - 1] of byte;
dwECC: array [0 .. cSectorECCSize - 1] of byte;
dwEDC: array [0 .. cSectorEDCSize - 1] of byte;
end;
PCDSector = ^TCDSector;
function GetImageScan(const FileName: string): Boolean;
function ReplaceTimInFile(const FileName, TimToInsert: string; InsertTo: DWORD;
ImageScan: Boolean): Boolean;
procedure ReplaceTimInFileFromMemory(const FileName: string; TIM: PTIM;
InsertTo: DWORD; ImageScan: Boolean);
implementation
uses
uCommon, ecc, edc, System.SysUtils, System.Classes;
function bin2bcd(P: Integer): byte;
begin
Result := ((P div 10) shl 4) or (P mod 10);
end;
procedure BuildAdress(LBA: Integer; var Dest);
var
P: PByte;
begin
Inc(LBA, 75 * 2); // 2 seconds
P := @Dest;
P^ := bin2bcd(LBA div (60 * 75));
Inc(P);
P^ := bin2bcd((LBA div 75) mod 60);
Inc(P);
P^ := bin2bcd(LBA mod 75);
Inc(P);
P^ := 2;
end;
function GetImageScan(const FileName: string): Boolean;
const
cSectorHeader: array [0 .. cSectorHeaderSize - 1] of byte = ($00, $FF, $FF,
$FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $00);
var
Sz: cardinal;
pFile: PBytesArray;
tmp: TFileStream;
begin
Result := False;
Sz := GetFileSizeAPI(FileName);
if (Sz > cMaxFileSize) or (Sz = 0) then
Exit;
pFile := GetMemory(cSectorHeaderSize);
tmp := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
tmp.Read(pFile^[0], cSectorHeaderSize);
Result := ((Sz mod cSectorSize) = 0) and
(CompareMem(@cSectorHeader, pFile, cSectorHeaderSize));
tmp.free;
FreeMemory(pFile);
end;
procedure ReplaceTimInFileFromMemory(const FileName: string; TIM: PTIM;
InsertTo: DWORD; ImageScan: Boolean);
type
TSecAddrAndMode = array [0 .. cSectorAddressSize + cSectorModeSize - 1] of byte;
var
sImageStream: TFileStream;
TimOffsetInSector, FirstPartSize, LastPartSize: DWORD;
TimSectorNumber, TimStartSectorPos: DWORD;
Sector: TCDSector;
ecc: DWORD;
P, TIM_FULL_SECTORS: DWORD;
SecAddrAndMode: TSecAddrAndMode;
begin
sImageStream := TFileStream.Create(FileName, fmOpenReadWrite or
fmShareDenyWrite);
if not ImageScan then
begin
sImageStream.Seek(InsertTo, soBeginning);
sImageStream.Write(TIM^.DATA^[0], TIM^.dwSIZE);
end
else
begin
P := 0;
TimSectorNumber := InsertTo div cSectorSize + 1;
TimOffsetInSector := InsertTo mod cSectorSize - cSectorInfoSize;
TimStartSectorPos := (TimSectorNumber - 1) * cSectorSize;
FirstPartSize := cSectorDataSize - TimOffsetInSector;
if TIM^.dwSIZE < FirstPartSize then
FirstPartSize := TIM^.dwSIZE;
sImageStream.Seek(TimStartSectorPos, soBeginning);
FillChar(Sector, cSectorSize, 0);
sImageStream.Read(Sector, cSectorSize);
sImageStream.Seek(TimStartSectorPos + cSectorHeaderSize, soBeginning);
Move(Sector.dwAddress[0], SecAddrAndMode[0], cSectorAddressSize + cSectorModeSize);
FillChar(Sector.dwAddress[0], cSectorAddressSize + cSectorModeSize, 0);
Move(TIM^.DATA^[P], Sector.dwData[TimOffsetInSector], FirstPartSize);
Inc(P, FirstPartSize);
ecc := build_edc(@(Sector.dwSubHeader[0]), cSectorSubHeaderSize + cSectorDataSize);
Move(ecc, Sector.dwECC, cSectorECCSize);
encode_L2_P(@(Sector.dwAddress[0]));
encode_L2_Q(@(Sector.dwAddress[0]));
BuildAdress(TimSectorNumber, Sector.dwAddress[0]);
sImageStream.Seek(TimStartSectorPos, soBeginning);
sImageStream.Write(Sector, cSectorSize);
sImageStream.Seek(TimStartSectorPos + cSectorHeaderSize, soBeginning);
sImageStream.Write(SecAddrAndMode[0], cSectorAddressSize + cSectorModeSize);
Inc(TimStartSectorPos, cSectorSize);
sImageStream.Seek(TimStartSectorPos, soBeginning);
TIM_FULL_SECTORS := (TIM^.dwSIZE - P) div cSectorDataSize;
while TIM_FULL_SECTORS > 0 do
begin
Inc(TimSectorNumber);
sImageStream.Read(Sector, cSectorSize);
Move(Sector.dwAddress[0], SecAddrAndMode[0], cSectorAddressSize + cSectorModeSize);
FillChar(Sector.dwAddress[0], cSectorAddressSize + cSectorModeSize, 0);
Move(TIM^.DATA^[P], Sector.dwData[0], cSectorDataSize);
Inc(P, cSectorDataSize);
ecc := build_edc(@(Sector.dwSubHeader[0]), cSectorSubHeaderSize + cSectorDataSize);
Move(ecc, Sector.dwECC, cSectorECCSize);
encode_L2_P(@(Sector.dwAddress[0]));
encode_L2_Q(@(Sector.dwAddress[0]));
BuildAdress(TimSectorNumber, Sector.dwAddress[0]);
sImageStream.Seek(TimStartSectorPos, soBeginning);
sImageStream.Write(Sector, cSectorSize);
sImageStream.Seek(TimStartSectorPos + cSectorHeaderSize, soBeginning);
sImageStream.Write(SecAddrAndMode[0], cSectorAddressSize + cSectorModeSize);
Inc(TimStartSectorPos, cSectorSize);
sImageStream.Seek(TimStartSectorPos, soBeginning);
Dec(TIM_FULL_SECTORS);
end;
Inc(TimSectorNumber);
sImageStream.Read(Sector, cSectorSize);
Move(Sector.dwAddress[0], SecAddrAndMode[0], cSectorAddressSize + cSectorModeSize);
FillChar(Sector.dwAddress[0], cSectorAddressSize + cSectorModeSize, 0);
if TIM^.dwSIZE > P then
begin
LastPartSize := TIM^.dwSIZE - P;
Move(TIM^.DATA^[P], Sector.dwData[0], LastPartSize);
ecc := build_edc(@(Sector.dwSubHeader[0]), cSectorSubHeaderSize + cSectorDataSize);
Move(ecc, Sector.dwECC, cSectorECCSize);
encode_L2_P(@(Sector.dwAddress[0]));
encode_L2_Q(@(Sector.dwAddress[0]));
BuildAdress(TimSectorNumber, Sector.dwAddress[0]);
sImageStream.Seek(TimStartSectorPos, soBeginning);
sImageStream.Write(Sector, cSectorSize);
sImageStream.Seek(TimStartSectorPos + cSectorHeaderSize, soBeginning);
sImageStream.Write(SecAddrAndMode[0], cSectorAddressSize + cSectorModeSize);
end;
end;
sImageStream.free;
end;
function ReplaceTimInFile(const FileName, TimToInsert: string; InsertTo: DWORD;
ImageScan: Boolean): Boolean;
var
SIZE, P: DWORD;
TIM: PTIM;
begin
Result := False;
SIZE := GetFileSizeAPI(TimToInsert);
P := 0;
TIM := LoadTimFromFile(TimToInsert, P, False, SIZE);
// SaveTimToFile('test.tim', TIM);
if TIM = nil then
Exit;
ReplaceTimInFileFromMemory(FileName, TIM, InsertTo, ImageScan);
FreeTIM(TIM);
Result := True;
end;
end.

154
units/uCommon.pas Normal file
View File

@@ -0,0 +1,154 @@
unit uCommon;
interface
uses
NativeXML, Windows;
const
cProgramName = 'Tim2View by [Lab 313]';
cProgramVersion = '2.0';
cMaxFileSize = $2EAEED80;
cExtractedTimsDir = 'TIMS';
cResRootName = 'TVSCANRESULT';
cResInfoNode = 'INFO';
cResAttrFile = 'FILENAME';
cResAttrVersion = 'VERSION';
cResAttrImageFile = 'CDIMAGE';
cResAttrTimsCount = 'TIMSCOUNT';
cResTimsNode = 'TIMS';
cResTimNode = 'TIM';
cResTimAttrPos = 'POSITION';
cResTimAttrSize = 'SIZE';
cResTimAttrWidth = 'WIDTH';
cResTimAttrHeight = 'HEIGHT';
cResTimAttrBitMode = 'BITMODE';
cResTimAttrGood = 'GOODTIM';
cAutoExtractionTimFormat = '%s_%.6d_%.2db' + '.tim';
cCLUTGridColsCount = 32;
sStatusBarScanningFile = 'Scanning File...';
sStatusBarTimsExtracting = 'TIM''s Extracting...';
sStatusBarParsingResult = 'Parsing Result...';
sScanResultGood = 'Scan completed!';
sSelectDirCaption = 'Please, select directory for scan...';
sThisTimHasNoCLUT = 'This TIM has no CLUT';
type
PNativeXML = ^TNativeXML;
type
TBytesArray = array [0 .. cMaxFileSize - 1] of byte;
PBytesArray = ^TBytesArray;
function GetStartDir: string;
function GetFileSizeAPI(const FileName: string): Int64;
function CheckFileExists(const FileName: string): boolean;
// function cHex2Int( const Value : string) : Integer;
function ExtractFileNameWOext(const Path: string): string;
procedure Text2Clipboard(const S: string);
function Min(A, B: Integer): Integer;
implementation
uses
uCDIMAGE, System.SysUtils, System.Classes, Clipbrd;
function Min(A, B: Integer): Integer;
begin
if A < B then
Result := A
else
Result := B;
end;
procedure Text2Clipboard(const S: string);
begin
Clipboard.AsText := S;
end;
function ExtractFileNameWOext(const Path: string): string;
begin
Result := ExtractFileName(Path);
Result := Copy(Result, 1, Length(Result) - Length(ExtractFileExt(Result)));
end;
function Hex2Int(const Value: string): Integer;
var
I: Integer;
begin
Result := 0;
I := 1;
if Value = '' then
Exit; { >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> }
if Value[1] = '$' then
Inc(I);
while I <= Length(Value) do
begin
if (Value[I] >= '0') and (Value[I] <= '9') then
Result := (Result shl 4) or (Ord(Value[I]) - Ord('0'))
else if (Value[I] >= 'A') and (Value[I] <= 'F') then
Result := (Result shl 4) or (Ord(Value[I]) - Ord('A') + 10)
else if (Value[I] >= 'a') and (Value[I] <= 'f') then
Result := (Result shl 4) or (Ord(Value[I]) - Ord('a') + 10)
else
break;
Inc(I);
end;
end;
function CopyEnd(const S: string; Idx: Integer): string;
begin
Result := Copy(S, Idx, MaxInt);
end;
function cHex2Int(const Value: string): Integer;
begin
if (Length(Value) > 2) and (Value[1] = '0') and
((Value[2] = 'x') or (Value[2] = 'X')) then
Result := Hex2Int(CopyEnd(Value, 3))
else
Result := Hex2Int(Value);
end;
function CheckFileExists(const FileName: string): boolean;
begin
Result := FileExists(FileName);
end;
function GetFileSizeAPI(const FileName: string): Int64;
var
FindData: TWin32FindData;
hFind: THandle;
begin
Result := -1;
hFind := FindFirstFile(PChar(FileName), FindData);
if hFind <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(hFind);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
Result := FindData.nFileSizeLow;
end;
end;
function GetStartDir: string;
const
MAX_PATH = 260;
var
Buffer: array [0 .. MAX_PATH] of Char;
I: Integer;
begin
I := GetModuleFileName(0, Buffer, MAX_PATH);
for I := I downto 0 do
if Buffer[I] = '\' then
begin
Buffer[I + 1] := #0;
break;
end;
Result := Buffer;
end;
end.

307
units/uDrawTIM.pas Normal file
View File

@@ -0,0 +1,307 @@
unit uDrawTIM;
interface
uses
Vcl.Graphics, uTIM, System.Types, Vcl.Imaging.pngimage, Vcl.Grids;
type
PCanvas = ^TCanvas;
PPNGImage = ^TPngImage;
PDrawGrid = ^TDrawGrid;
procedure DrawTIM(TIM: PTIM; CLUT_NUM: Integer; ACanvas: PCanvas; Rect: TRect;
var PNG: PPNGImage; TranspMode: Byte);
procedure TimToPNG(TIM: PTIM; CLUT_NUM: Integer; var PNG: PPNGImage;
TranspMode: Byte);
procedure DrawPNG(PNG: PPNGImage; ACanvas: PCanvas; Rect: TRect);
procedure DrawClutCell(TIM: PTIM; CLUT_NUM: Integer; Grid: PDrawGrid;
X, Y: Integer);
procedure DrawCLUT(TIM: PTIM; CLUT_NUM: Integer; Grid: PDrawGrid);
procedure ClearCanvas(CHandle: THandle; Rect: TRect);
procedure ClearGrid(Grid: PDrawGrid);
implementation
uses
Windows, uCommon;
function PrepareCLUT(TIM: PTIM; CLUT_NUM: Integer): PCLUT_COLORS;
var
I: Integer;
begin
Result := nil;
if (not TIMHasCLUT(TIM)) and (not(TIM^.HEAD^.bBPP in [cTIM4NC, cTIM8NC])) then
Exit;
New(Result);
if (TIM^.HEAD^.bBPP in [cTIM4NC, cTIM8NC]) then
begin
Randomize;
for I := 1 to cRandomPaletteSize do
Result^[I - 1] := GetCLUTColor(TIM, CLUT_NUM, I - 1);
Exit;
end;
for I := 1 to GetTimColorsCount(TIM) do
Result^[I - 1] := GetCLUTColor(TIM, CLUT_NUM, I - 1);
end;
function PrepareIMAGE(TIM: PTIM): PIMAGE_INDEXES;
var
I, OFFSET: Integer;
RW: Word;
P24: DWORD;
begin
New(Result);
OFFSET := cTIMHeadSize + GetTIMCLUTSize(TIM) + cIMAGEHeadSize;
RW := GetTimRealWidth(TIM);
case TIM^.HEAD^.bBPP of
cTIM4C, cTIM4NC:
for I := 1 to TIM^.IMAGE^.wWidth * TIM^.IMAGE^.wHeight * 2 do
begin
Result^[(I - 1) * 2] := TIM^.DATA^[OFFSET + I - 1] and $F;
Result^[(I - 1) * 2 + 1] := (TIM^.DATA^[OFFSET + I - 1] and $F0) shr 4;
end;
cTIM8C, cTIM8NC:
for I := 1 to TIM^.IMAGE^.wWidth * TIM^.IMAGE^.wHeight * 2 do
Result^[I - 1] := TIM^.DATA^[OFFSET + I - 1];
cTIM16C, cTIM16NC:
for I := 1 to TIM^.IMAGE^.wWidth * TIM^.IMAGE^.wHeight do
Move(TIM^.DATA^[OFFSET + (I - 1) * 2], Result^[I - 1], 2);
cTIM24C, cTIM24NC:
begin
I := 1;
P24 := 0;
while I <= (TIM^.IMAGE^.wWidth * TIM^.IMAGE^.wHeight * 2) do
begin
Result^[P24] := 0;
Move(TIM^.DATA^[OFFSET + (I - 1)], Result^[P24], 3);
Inc(I, 3);
if Odd(RW) and (((P24 + 1) mod RW) = 0) then
Inc(OFFSET);
Inc(P24);
end;
end;
end;
end;
procedure TimToPNG(TIM: PTIM; CLUT_NUM: Integer; var PNG: PPNGImage;
TranspMode: Byte);
var
RW, RH, CW: Word;
CLUT_DATA: PCLUT_COLORS;
IMAGE_DATA: PIMAGE_INDEXES;
X, Y, INDEX, IMAGE_DATA_POS: Integer;
R, G, B, STP, ALPHA: Byte;
COLOR: TCLUT_COLOR;
CL: DWORD;
Transparent, SemiTransparent: boolean;
begin
RW := GetTimRealWidth(TIM);
RH := GetTimHeight(TIM);
PNG^ := TPngImage.CreateBlank(COLOR_RGBALPHA, 16, RW, RH);
PNG^.CompressionLevel := 9;
PNG^.Filters := [];
CLUT_DATA := PrepareCLUT(TIM, CLUT_NUM);
IMAGE_DATA := PrepareIMAGE(TIM);
IMAGE_DATA_POS := 0;
R := 0;
G := 0;
B := 0;
STP := 0;
Transparent := TranspMode in [0, 1];
SemiTransparent := TranspMode in [0, 2];
for Y := 1 to RH do
for X := 1 to RW do
begin
case TIM^.HEAD^.bBPP of
cTIM4C, cTIM4NC, cTIM8C, cTIM8NC:
begin
INDEX := IMAGE_DATA^[IMAGE_DATA_POS];
R := CLUT_DATA^[INDEX].R;
G := CLUT_DATA^[INDEX].G;
B := CLUT_DATA^[INDEX].B;
STP := CLUT_DATA^[INDEX].STP;
end;
cTIM16C, cTIM16NC, cTIMMix:
begin
Move(IMAGE_DATA^[IMAGE_DATA_POS], CW, 2);
COLOR := ConvertTIMColor(CW);
R := COLOR.R;
G := COLOR.G;
B := COLOR.B;
STP := COLOR.STP;
end;
cTIM24C, cTIM24NC:
begin
CL := IMAGE_DATA^[IMAGE_DATA_POS];
R := (CL and $FF);
G := ((CL and $FF00) shr 8);
B := ((CL and $FF0000) shr 16);
STP := 0;
end;
else
Break;
end;
if (TIM^.HEAD^.bBPP in cTIM24) or (not(Transparent or SemiTransparent))
then
ALPHA := 255
else
begin
if (R + G + B) = 0 then
ALPHA := 0
else
begin
if (STP = 0) then
ALPHA := 255
else
ALPHA := 128;
if (not SemiTransparent) and (ALPHA = 128) then
ALPHA := 255;
end;
end;
PNG^.AlphaScanline[Y - 1]^[X - 1] := ALPHA;
if ALPHA = 0 then
begin
B := 0;
G := 0;
R := 0;
end;
pRGBLine(PNG^.Scanline[Y - 1])^[X - 1].rgbtBlue := B;
pRGBLine(PNG^.Scanline[Y - 1])^[X - 1].rgbtGreen := G;
pRGBLine(PNG^.Scanline[Y - 1])^[X - 1].rgbtRed := R;
Inc(IMAGE_DATA_POS);
end;
Dispose(CLUT_DATA);
Dispose(IMAGE_DATA);
end;
procedure DrawTIM(TIM: PTIM; CLUT_NUM: Integer; ACanvas: PCanvas; Rect: TRect;
var PNG: PPNGImage; TranspMode: Byte);
begin
TimToPNG(TIM, CLUT_NUM, PNG, TranspMode);
DrawPNG(PNG, ACanvas, Rect);
end;
procedure ClearCanvas(CHandle: THandle; Rect: TRect);
begin
PatBlt(CHandle, Rect.Left, Rect.Top, Rect.Width, Rect.Height, WHITENESS);
end;
procedure ClearGrid(Grid: PDrawGrid);
var
X, Y, W, H: Word;
begin
W := Grid^.ColCount;
H := Grid^.RowCount;
for Y := 1 to H do
for X := 1 to W do
ClearCanvas(Grid^.Canvas.Handle, Grid^.CellRect(X - 1, Y - 1));
end;
procedure DrawPNG(PNG: PPNGImage; ACanvas: PCanvas; Rect: TRect);
begin
if PNG^ = nil then
Exit;
Rect.Width := PNG^.Width;
Rect.Height := PNG^.Height;
PNG^.Draw(ACanvas^, Rect);
end;
procedure DrawClutCell(TIM: PTIM; CLUT_NUM: Integer; Grid: PDrawGrid;
X, Y: Integer);
var
CLUT_COLOR: PCLUT_COLOR;
R, G, B, STP, ALPHA: Byte;
Rect: TRect;
COLS: Integer;
begin
New(CLUT_COLOR);
COLS := Min(GetTimColorsCount(TIM), cCLUTGridColsCount);
CLUT_COLOR^ := GetCLUTColor(TIM, CLUT_NUM, Y * COLS + X);
R := CLUT_COLOR^.R;
G := CLUT_COLOR^.G;
B := CLUT_COLOR^.B;
STP := CLUT_COLOR^.STP;
Rect := Grid^.CellRect(X, Y);
ClearCanvas(Grid^.Canvas.Handle, Rect);
Grid^.Canvas.Brush.COLOR := RGB(R, G, B);
Grid^.Canvas.FillRect(Rect);
if (R + G + B) = 0 then
ALPHA := 0
else
begin
if STP = 0 then
ALPHA := 255
else
ALPHA := 128;
end;
if ALPHA in [0, 128] then
begin
Grid^.Canvas.Brush.COLOR := clWhite;
if ALPHA = 0 then
Rect.Height := Rect.Height div 2
else
Rect.Width := Rect.Width div 2;
Grid^.Canvas.FillRect(Rect);
end;
Dispose(CLUT_COLOR);
end;
procedure DrawCLUT(TIM: PTIM; CLUT_NUM: Integer; Grid: PDrawGrid);
var
X, Y, ROWS, COLS, COLORS: Integer;
begin
COLORS := GetTimColorsCount(TIM);
COLS := Min(COLORS, cCLUTGridColsCount);
Grid^.ColCount := COLS;
ROWS := COLORS div COLS;
Grid^.RowCount := ROWS;
for Y := 1 to ROWS do
for X := 1 to COLS do
begin
ClearCanvas(Grid^.Canvas.Handle, Grid^.CellRect(X - 1, Y - 1));
DrawClutCell(TIM, CLUT_NUM, Grid, X - 1, Y - 1);
end;
end;
end.

48
units/uEventWaitThread.pas Normal file
View File

@@ -0,0 +1,48 @@
unit uEventWaitThread;
interface
uses
Windows, Classes;
type
TEventWaitThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
var
CommandEvent: THandle;
implementation
uses
uMain;
{ Important: Methods and properties of objects in VCL can only be used in a
method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure TEventWaitThread.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end; }
{ TEventWaitThread }
procedure TEventWaitThread.Execute;
begin
while True do
begin
if WaitForSingleObject(CommandEvent, INFINITE) <> WAIT_OBJECT_0 then
Exit;
PostMessage(frmMain.Handle, WM_COMMANDARRIVED, 0, 0);
end;
end;
end.

467
units/uMain.dfm Normal file
View File

@@ -0,0 +1,467 @@
object frmMainT2V: TfrmMainT2V
Left = 0
Top = 0
Width = 754
Height = 591
AutoScroll = True
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
Menu = mmMain
OldCreateOrder = False
Position = poScreenCenter
ScreenSnap = True
OnClose = FormClose
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object pnlStatus: TPanel
Left = 0
Top = 502
Width = 738
Height = 30
Align = alBottom
BevelOuter = bvLowered
TabOrder = 2
object lblStatus: TLabel
Left = 76
Top = 1
Width = 157
Height = 28
Align = alClient
Alignment = taRightJustify
Layout = tlCenter
ExplicitLeft = 230
ExplicitWidth = 3
ExplicitHeight = 13
end
object pbProgress: TProgressBar
Left = 233
Top = 1
Width = 504
Height = 28
Align = alRight
Smooth = True
TabOrder = 1
end
object btnStopScan: TButton
Left = 1
Top = 1
Width = 75
Height = 28
Align = alLeft
Caption = 'Stop Scan'
Enabled = False
TabOrder = 0
OnClick = btnStopScanClick
end
end
object cbbFiles: TComboBox
Left = 0
Top = 0
Width = 738
Height = 21
Align = alTop
AutoDropDown = True
AutoCloseUp = True
Style = csDropDownList
DropDownCount = 30
TabOrder = 0
OnChange = cbbFilesChange
end
object pnlMain: TPanel
Left = 0
Top = 21
Width = 738
Height = 481
Align = alClient
BevelOuter = bvNone
TabOrder = 1
object splMain: TSplitter
Left = 233
Top = 0
Height = 481
ResizeStyle = rsUpdate
ExplicitLeft = 201
end
object pnlList: TPanel
Left = 0
Top = 0
Width = 233
Height = 481
Align = alLeft
BevelOuter = bvNone
TabOrder = 0
object lvList: TListView
Left = 0
Top = 0
Width = 233
Height = 481
Align = alClient
Columns = <
item
Caption = '# / 0'
Width = 60
end
item
Alignment = taCenter
Caption = 'Resolution'
Width = 95
end
item
Caption = 'BPP'
end>
ColumnClick = False
DoubleBuffered = True
GridLines = True
HideSelection = False
OwnerData = True
ReadOnly = True
RowSelect = True
ParentDoubleBuffered = False
PopupMenu = pmList
TabOrder = 0
ViewStyle = vsReport
OnClick = lvListClick
OnData = lvListData
OnKeyDown = lvListKeyDown
end
end
object pnlImage: TPanel
Left = 236
Top = 0
Width = 502
Height = 481
Align = alClient
BevelOuter = bvLowered
TabOrder = 1
object splImageClut: TSplitter
Left = 1
Top = 1
Width = 500
Height = 3
Cursor = crVSplit
Align = alTop
Beveled = True
ResizeStyle = rsUpdate
ExplicitTop = 274
end
object imgTIM: TImage
Left = 1
Top = 4
Width = 500
Height = 296
Align = alClient
Center = True
IncrementalDisplay = True
Proportional = True
ExplicitLeft = 152
ExplicitTop = 112
ExplicitWidth = 105
ExplicitHeight = 105
end
object grdCurrCLUT: TDrawGrid
Left = 1
Top = 330
Width = 500
Height = 150
Align = alBottom
ColCount = 1
DefaultColWidth = 14
DefaultRowHeight = 14
DoubleBuffered = True
Enabled = False
FixedCols = 0
RowCount = 1
FixedRows = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goDrawFocusSelected]
ParentDoubleBuffered = False
ScrollBars = ssNone
TabOrder = 0
OnDblClick = grdCurrCLUTDblClick
OnDrawCell = grdCurrCLUTDrawCell
end
object pnlImageOptions: TPanel
Left = 1
Top = 300
Width = 500
Height = 30
Align = alBottom
BevelOuter = bvLowered
TabOrder = 1
object cbbCLUT: TComboBox
AlignWithMargins = True
Left = 4
Top = 4
Width = 152
Height = 21
Align = alLeft
AutoDropDown = True
AutoCloseUp = True
Style = csDropDownList
TabOrder = 0
OnChange = cbbCLUTChange
end
object cbbTransparenceMode: TComboBox
AlignWithMargins = True
Left = 162
Top = 4
Width = 145
Height = 21
Align = alLeft
Style = csDropDownList
ItemIndex = 0
TabOrder = 1
Text = 'Full transparence'
OnClick = cbbTransparenceModeClick
Items.Strings = (
'Full transparence'
'Black Transparence'
'Semi Transparence'
'No Transparence')
end
object cbbBitMode: TComboBox
AlignWithMargins = True
Left = 313
Top = 4
Width = 88
Height = 21
Align = alLeft
Style = csDropDownList
ItemIndex = 0
TabOrder = 2
Text = 'Real'
OnChange = cbbBitModeChange
Items.Strings = (
'Real'
'4 BPP'
'8 BPP'
'16 BPP'
'24 BPP')
end
object chkStretch: TCheckBox
Left = 404
Top = 1
Width = 97
Height = 28
Action = actStretch
Align = alLeft
TabOrder = 3
end
end
end
end
object dlgOpenFile: TOpenDialog
DefaultExt = '.bin'
Filter = 'All Files (*.*)|*.*'
Options = [ofHideReadOnly, ofNoChangeDir, ofAllowMultiSelect, ofFileMustExist, ofNoNetworkButton, ofEnableSizing, ofForceShowHidden]
Title = 'Please, select File...'
Left = 668
Top = 502
end
object mmMain: TMainMenu
Left = 608
Top = 504
object mnFile: TMenuItem
Caption = '&File'
object mnScanFile: TMenuItem
Action = actScanFile
end
object mnScanDir: TMenuItem
Action = actScanDir
end
object N1: TMenuItem
Caption = '-'
end
object mnCloseFile: TMenuItem
Action = actCloseFile
end
object mnCloseAllFiles: TMenuItem
Action = actCloseFiles
end
object mnExit: TMenuItem
Action = actExit
end
end
object mnTIM: TMenuItem
Caption = '&TIM'
object mnSaveTIM: TMenuItem
Action = actExtractTim
end
object mnReplaceIn: TMenuItem
Action = actReplaceTim
end
object mnSaveToPNG: TMenuItem
Action = actTim2Png
end
object N4: TMenuItem
Caption = '-'
end
object IMInfo1: TMenuItem
Action = actTimInfo
end
end
object mnConfig: TMenuItem
Caption = '&Options'
object mnAutoExtract: TMenuItem
AutoCheck = True
Caption = '&Auto Extraction'
end
object Stretch1: TMenuItem
Action = actStretch
AutoCheck = True
end
object mnViewMode: TMenuItem
Caption = '&View Mode'
object mnSimpleMode: TMenuItem
AutoCheck = True
Caption = '&Simple Mode'
RadioItem = True
OnClick = mnSimpleModeClick
end
object mnAdvancedMode: TMenuItem
AutoCheck = True
Caption = '&Advanced Mode'
Checked = True
RadioItem = True
OnClick = mnAdvancedModeClick
end
end
object N5: TMenuItem
Caption = '-'
end
object mnAssociate: TMenuItem
Action = actAssocTims
end
end
object mnHelp: TMenuItem
Caption = '&Help'
object mnSVN: TMenuItem
Action = actOpenRepo
end
object mnSite: TMenuItem
Action = actOpenLab
end
object N3: TMenuItem
Caption = '-'
end
object mnAbout: TMenuItem
Action = actAbout
end
end
end
object dlgSavePNG: TSavePictureDialog
DefaultExt = 'png'
Filter = 'Portable Network Graphics (*.png)|*.png'
Options = [ofHideReadOnly, ofNoChangeDir, ofNoNetworkButton, ofEnableSizing]
Title = 'Please, select filename for PNG...'
Left = 704
Top = 504
end
object dlgSaveTIM: TSaveDialog
DefaultExt = 'tim'
Filter = 'PSX TIM Files (*.tim)|*.tim|All Files (*.*)|*.*'
Options = [ofOverwritePrompt, ofHideReadOnly, ofNoChangeDir, ofNoNetworkButton, ofEnableSizing]
Title = 'Please, select where to save TIM file...'
Left = 576
Top = 504
end
object dlgColor: TColorDialog
Options = [cdFullOpen]
Left = 544
Top = 502
end
object actList: TActionList
Left = 512
Top = 502
object actScanFile: TAction
Caption = 'Scan &File...'
ShortCut = 116
OnExecute = actScanFileExecute
end
object actScanDir: TAction
Caption = 'Scan &Directory...'
ShortCut = 117
OnExecute = actScanDirExecute
end
object actCloseFile: TAction
Caption = 'Close &this File'
ShortCut = 119
OnExecute = actCloseFileExecute
end
object actCloseFiles: TAction
Caption = 'Close &all Files'
ShortCut = 120
OnExecute = actCloseFilesExecute
end
object actExit: TAction
Caption = '&Exit...'
ShortCut = 121
OnExecute = actExitExecute
end
object actExtractTim: TAction
Caption = '&Extract TIM...'
ShortCut = 113
OnExecute = actExtractTimExecute
end
object actReplaceTim: TAction
Caption = '&Replace TIM...'
ShortCut = 114
OnExecute = actReplaceTimExecute
end
object actTim2Png: TAction
Caption = 'Save as &PNG...'
ShortCut = 115
OnExecute = actTim2PngExecute
end
object actOpenRepo: TAction
Caption = 'Tim2Vew &SVN Repo'
OnExecute = actOpenRepoExecute
end
object actOpenLab: TAction
Caption = '[&Lab313] Forum'
OnExecute = actOpenLabExecute
end
object actAbout: TAction
Caption = 'About...'
ShortCut = 112
OnExecute = actAboutExecute
end
object actStretch: TAction
AutoCheck = True
Caption = '&Stretch'
OnExecute = actStretchExecute
end
object actTimInfo: TAction
Caption = 'TIM Info'
Enabled = False
OnExecute = actTimInfoExecute
end
object actAssocTims: TAction
Caption = 'Open TIMs with T2V'
OnExecute = actAssocTimsExecute
end
end
object pmList: TPopupMenu
Left = 640
Top = 502
object ExtractTIM1: TMenuItem
Action = actExtractTim
end
object ReplaceTIM1: TMenuItem
Action = actReplaceTim
end
object SaveasPNG1: TMenuItem
Action = actTim2Png
end
object N2: TMenuItem
Caption = '-'
end
object mnTIMInfo: TMenuItem
Action = actTimInfo
end
end
end

1129
units/uMain.pas Normal file
View File

File diff suppressed because it is too large Load Diff

217
units/uScanThread.pas Normal file
View File

@@ -0,0 +1,217 @@
unit uScanThread;
interface
uses
Classes, Windows, uCommon, uTIM;
type
PScanThread = ^TScanThread;
TScanThread = class(Classes.TThread)
private
{ Private declarations }
pTims: Integer;
pFileToScan: string;
pImageScan: boolean;
pResult: PNativeXml;
pFileSize: DWORD;
pFilePos: DWORD;
pStatusText: string;
pClearBufferPosition: DWORD;
pClearBufferSize: DWORD;
pSectorBufferSize: DWORD;
pSrcFileStream: TFileStream;
pStopScan: boolean;
procedure SetStatusText;
procedure UpdateProgressBar;
procedure AddResult(TIM: PTIM);
procedure ClearSectorBuffer(SectorBuffer, ClearBuffer: PBytesArray);
protected
procedure Execute; override;
public
constructor Create(const FileToScan: string; fResult: pointer;
ImageScan: boolean);
property Terminated;
property StopScan: boolean write pStopScan;
end;
implementation
uses
uMain, uCDIMAGE, System.SysUtils, NativeXml;
const
cClearBufferSize = ((cTIMMaxSize div cSectorDataSize) + 1) *
cSectorDataSize * 2;
cSectorBufferSize = (cClearBufferSize div cSectorDataSize) * cSectorSize;
{ TScanThread }
constructor TScanThread.Create(const FileToScan: string; fResult: pointer;
ImageScan: boolean);
var
Node: TXmlNode;
begin
inherited Create(True);
FreeOnTerminate := True;
pClearBufferPosition := 0;
pFilePos := 0;
pTims := 0;
pFileToScan := FileToScan;
pFileSize := GetFileSizeAPI(pFileToScan);
pStatusText := '';
pStopScan := False;
pImageScan := ImageScan;
pResult := fResult;
Node := pResult^.Root.NodeNew(cResInfoNode);
Node.WriteAttributeUnicodeString(cResAttrFile, pFileToScan);
Node.WriteAttributeBool(cResAttrImageFile, ImageScan);
Node.WriteAttributeInteger(cResAttrTimsCount, 0);
end;
procedure TScanThread.AddResult(TIM: PTIM);
var
Node, AddedNode: TXmlNode;
begin
Node := pResult^.Root.NodeFindOrCreate(cResInfoNode);
Node.WriteAttributeInteger(cResAttrTimsCount, TIM^.dwTimNumber);
Node := pResult^.Root.NodeFindOrCreate(cResTimsNode);
AddedNode := Node.NodeNew(cResTimNode);
AddedNode.WriteAttributeInteger(cResTimAttrPos, TIM^.dwTimPosition);
AddedNode.WriteAttributeInteger(cResTimAttrSize, TIM^.dwSIZE);
AddedNode.WriteAttributeInteger(cResTimAttrWidth, GetTimRealWidth(TIM));
AddedNode.WriteAttributeInteger(cResTimAttrHeight, GetTimHeight(TIM));
AddedNode.WriteAttributeInteger(cResTimAttrBitMode, BppToBitMode(TIM));
AddedNode.WriteAttributeBool(cResTimAttrGood, TIMIsGood(TIM));
Inc(pTims);
end;
procedure TScanThread.Execute;
var
SectorBuffer, ClearBuffer: PBytesArray;
TIM: PTIM;
pScanFinished: boolean;
pRealBufSize, pTimPosition, pTIMNumber: DWORD;
begin
pSrcFileStream := TFileStream.Create(pFileToScan, fmOpenRead or
fmShareDenyWrite);
pSrcFileStream.Position := 0;
if pImageScan then
pSectorBufferSize := cSectorBufferSize
else
pSectorBufferSize := cClearBufferSize;
pClearBufferSize := cClearBufferSize;
SectorBuffer := GetMemory(pSectorBufferSize);
ClearBuffer := GetMemory(pClearBufferSize);
TIM := CreateTIM;
pStatusText := sStatusBarScanningFile;
Synchronize(SetStatusText);
pRealBufSize := pSrcFileStream.Read(SectorBuffer^[0], pSectorBufferSize);
Inc(pFilePos, pRealBufSize);
ClearSectorBuffer(SectorBuffer, ClearBuffer);
pScanFinished := False;
pTIMNumber := 0;
repeat
if LoadTimFromBuf(ClearBuffer, TIM, pClearBufferPosition) then
begin
if pImageScan then
pTimPosition := pFilePos - pRealBufSize +
((pClearBufferPosition - 1) div cSectorDataSize) * cSectorSize +
((pClearBufferPosition - 1) mod cSectorDataSize) + cSectorInfoSize
else
pTimPosition := pFilePos - pRealBufSize + (pClearBufferPosition - 1);
if pTimPosition >= pFileSize then
Break;
TIM^.dwTimPosition := pTimPosition;
Inc(pTIMNumber);
TIM^.dwTimNumber := pTIMNumber;
AddResult(TIM);
end;
if pClearBufferPosition = (pClearBufferSize div 2) then
begin
if pScanFinished then
Break;
pScanFinished := (pFilePos = pFileSize);
pClearBufferPosition := 0;
Move(SectorBuffer^[pSectorBufferSize div 2], SectorBuffer^[0],
pSectorBufferSize div 2);
if pScanFinished then
begin
if pRealBufSize >= (pSectorBufferSize div 2) then
// Need to check file size
pRealBufSize := pRealBufSize - (pSectorBufferSize div 2);
end
else
begin
pRealBufSize := pSrcFileStream.
Read(SectorBuffer^[pSectorBufferSize div 2], pSectorBufferSize div 2);
Inc(pFilePos, pRealBufSize);
pRealBufSize := pRealBufSize + (pSectorBufferSize div 2);
end;
Synchronize(UpdateProgressBar);
ClearSectorBuffer(SectorBuffer, ClearBuffer);
end;
until pStopScan;
FreeTIM(TIM);
FreeMemory(SectorBuffer);
FreeMemory(ClearBuffer);
Synchronize(UpdateProgressBar);
pSrcFileStream.Free;
pFilePos := 0;
Synchronize(UpdateProgressBar);
pStatusText := '';
Synchronize(SetStatusText);
end;
procedure TScanThread.SetStatusText;
begin
frmMain.lblStatus.Caption := pStatusText;
end;
procedure TScanThread.UpdateProgressBar;
begin
frmMain.pbProgress.Position := pFilePos;
frmMain.lvList.Column[0].Caption := Format('# / %d', [pTims]);
end;
procedure TScanThread.ClearSectorBuffer(SectorBuffer, ClearBuffer: PBytesArray);
var
i: DWORD;
begin
FillChar(ClearBuffer^[0], pClearBufferSize, 0);
if not pImageScan then
begin
Move(SectorBuffer^[0], ClearBuffer^[0], pClearBufferSize);
Exit;
end;
for i := 1 to (pSectorBufferSize div cSectorSize) do
begin
Move(SectorBuffer^[(i - 1) * cSectorSize + cSectorInfoSize],
ClearBuffer^[(i - 1) * cSectorDataSize], cSectorDataSize);
end;
end;
end.

598
units/uTIM.pas Normal file
View File

@@ -0,0 +1,598 @@
unit uTIM;
interface
uses
Windows, uCommon, System.Classes;
const
cTIMMagic = $10;
cTIM4C = $08;
cTIM4NC = $00;
cTIM4 = [cTIM4C, cTIM4NC];
cTIM8C = $09;
cTIM8NC = $01;
cTIM8 = [cTIM8C, cTIM8NC];
cTIM16C = $0A;
cTIM16NC = $02;
cTIM16 = [cTIM16C, cTIM16NC];
cTIM24C = $0B;
cTIM24NC = $03;
cTIM24 = [cTIM24C, cTIM24NC];
cTIMMix = $04;
cTIMVersions = [$00, $01];
cTIMWrongBads = [cTIM4NC, cTIM8NC, cTIMMix];
cTIMCLUT = [cTIM4C, cTIM8C, cTIM16C, cTIM24C];
cTIMNOCLUT = [cTIM4NC, cTIM8NC, cTIM16NC, cTIM24NC, cTIMMix];
cTIMBpp = [cTIM4C, cTIM8C, cTIM16C, cTIM24C, cTIM4NC, cTIM8NC, cTIM16NC,
cTIM24NC, cTIMMix];
cCLUTColorsMax = 1024;
cCLUTCountMax = 512;
cIMAGEWidthMax = 1024;
cIMAGEHeightMax = 1024;
cCLUTHeadSize = $0C;
cIMAGEHeadSize = $0C;
cTIMHeadSize = 8;
cRandomPaletteSize = $100;
cTIMMaxSize = cTIMHeadSize + cCLUTColorsMax * cCLUTCountMax * 2 +
cCLUTHeadSize + cIMAGEWidthMax * cIMAGEHeightMax * 2 + cIMAGEHeadSize;
type
TTIMHeader = packed record // TIM Header (8 bytes)
bMagic: byte; // $10 (1 byte)
bVersion: byte; // Any? (1 byte)
bReserved1: byte; // Reserved byte 1 (1 byte)
bReserved2: byte; // Reserved byte 2 (1 byte)
bBPP: DWORD; // Bit per Pixel (4 bytes)
// variants:
// [$08, $09, $0A, $0B, $02, $03, $00, $01]
end;
PTIMHeader = ^TTIMHeader;
type
TCLUTHeader = packed record // CLUT header (12+ bytes)
dwSize: DWORD; // Length of CLUT (4 bytes)
wVRAMX: word; // Palette coordinates in VRAM (by X) (2 bytes)
wVRAMY: word; // Palette coordinates in VRAM (by Y) (2 bytes)
wColorsCount: word; // Number of CLUT Colors (2 bytes)
wClutsCount: word; // Count of Palettes (2 bytes)
end;
PCLUTHeader = ^TCLUTHeader;
type
TIMAGEHeader = packed record // IMAGE Block Header (12+ bytes)
dwSize: DWORD; // Length of Image Block (4 bytes)
wVRAMX: word; // Image Block Coordinates in VRAM (by X) (2 bytes)
wVRAMY: word; // Image Block Coordinates in VRAM (by Y) (2 bytes)
wWidth: word; // Image Width (not Real) (2 bytes)
wHeight: word; // Image Height (Real) (2 bytes)
end;
PIMAGEHeader = ^TIMAGEHeader;
type
TTIMDataArray = array [0 .. cTIMMaxSize - 1] of byte;
PTIMDataArray = ^TTIMDataArray;
type
TCLUT_COLOR = record
// stp (special transparency processing) D=[0,1]
STP: byte;
// r,g,b D=[0,31]
R: byte;
G: byte;
B: byte;
end;
PCLUT_COLOR = ^TCLUT_COLOR;
TCLUT_COLORS = array [0 .. cCLUTColorsMax * cCLUTCountMax - 1] of TCLUT_COLOR;
PCLUT_COLORS = ^TCLUT_COLORS;
type
TIMAGE_INDEXES = array [0 .. cIMAGEWidthMax * cIMAGEHeightMax * 4 -
1] of DWORD;
PIMAGE_INDEXES = ^TIMAGE_INDEXES;
type
TTIM = record
dwTimNumber: DWORD;
dwTimPosition: DWORD;
HEAD: PTIMHeader;
CLUT: PCLUTHeader;
IMAGE: PIMAGEHeader;
dwSize: DWORD;
DATA: PTIMDataArray;
bGOOD: Boolean;
end;
PTIM = ^TTIM;
function TIMHasCLUT(TIM: PTIM): Boolean;
function GetTIMCLUTSize(TIM: PTIM): DWORD;
function GetTIMSize(TIM: PTIM): DWORD;
function GetTimWidth(TIM: PTIM): word;
function GetTimRealWidth(TIM: PTIM): word;
function GetTimHeight(TIM: PTIM): word;
function TIMIsGood(TIM: PTIM): Boolean;
function LoadTimFromBuf(BUFFER: pointer; var TIM: PTIM;
var Position: DWORD): Boolean;
function LoadTimFromFile(const FileName: string; var Position: DWORD;
ImageScan: Boolean; dwSize: DWORD): PTIM;
procedure SaveTimToFile(const FileName: string; TIM: PTIM);
function CreateTIM: PTIM;
procedure FreeTIM(TIM: PTIM);
function BppToBitMode(TIM: PTIM): byte;
function GetTimColorsCount(TIM: PTIM): word;
function GetTimClutsCount(TIM: PTIM): word;
function GetTimVersion(TIM: PTIM): byte;
function GetTimBPP(TIM: PTIM): DWORD;
function GetTimClutSizeHeader(TIM: PTIM): DWORD;
function GetTimClutVRAMX(TIM: PTIM): word;
function GetTimClutVRAMY(TIM: PTIM): word;
function GetTimImageSizeHeader(TIM: PTIM): DWORD;
function GetTimImageVRAMX(TIM: PTIM): word;
function GetTimImageVRAMY(TIM: PTIM): word;
function GetTIMIMAGESize(TIM: PTIM): DWORD;
function GetCLUTColor(TIM: PTIM; CLUT_NUM, COLOR_NUM: Integer): TCLUT_COLOR;
procedure WriteCLUTColor(TIM: PTIM; CLUT_NUM, COLOR_NUM: Integer;
COLOR: TCLUT_COLOR);
function ConvertTIMColor(COLOR: word): TCLUT_COLOR;
function ConvertCLUTColor(COLOR: TCLUT_COLOR): word;
implementation
uses
System.SysUtils, uCDIMAGE;
function ConvertTIMColor(COLOR: word): TCLUT_COLOR;
begin
Result.R := (COLOR and $1F) * 8;
Result.G := ((COLOR and $3E0) shr 5) * 8;
Result.B := ((COLOR and $7C00) shr 10) * 8;
Result.STP := ((COLOR and $8000) shr 15);
end;
function ConvertCLUTColor(COLOR: TCLUT_COLOR): word;
begin
Result := (COLOR.STP shl 15) or ((COLOR.B div 8) shl 10) or
((COLOR.G div 8) shl 5) or (COLOR.R div 8);
end;
function GetCLUTColor(TIM: PTIM; CLUT_NUM, COLOR_NUM: Integer): TCLUT_COLOR;
var
CLUT_OFFSET: Integer;
COLOR: word;
begin
if (TIM^.HEAD^.bBPP in [cTIM4NC, cTIM8NC]) then
begin
Result.R := random($20) * 8;
Result.G := random($20) * 8;
Result.B := random($20) * 8;
Result.STP := 1;
Exit;
end;
CLUT_OFFSET := CLUT_NUM * GetTimColorsCount(TIM) * 2;
Move(TIM^.DATA^[cTIMHeadSize + cCLUTHeadSize + COLOR_NUM * 2 + CLUT_OFFSET],
COLOR, 2);
Result := ConvertTIMColor(COLOR);
end;
procedure WriteCLUTColor(TIM: PTIM; CLUT_NUM, COLOR_NUM: Integer;
COLOR: TCLUT_COLOR);
var
CLUT_OFFSET: Integer;
COLOR_TO_WRITE: word;
begin
CLUT_OFFSET := CLUT_NUM * GetTimColorsCount(TIM) * 2;
COLOR_TO_WRITE := ConvertCLUTColor(COLOR);
Move(COLOR_TO_WRITE, TIM^.DATA^[cTIMHeadSize + cCLUTHeadSize + COLOR_NUM * 2 +
CLUT_OFFSET], 2);
end;
function GetTimHeight(TIM: PTIM): word;
begin
Result := TIM^.IMAGE^.wHeight;
end;
function GetTIMCLUTSize(TIM: PTIM): DWORD;
begin
Result := 0;
if not TIMHasCLUT(TIM) then
Exit;
Result := TIM^.CLUT^.wColorsCount * TIM^.CLUT^.wClutsCount * 2 +
cCLUTHeadSize;
end;
function GetTIMIMAGESize(TIM: PTIM): DWORD;
begin
Result := TIM^.IMAGE^.wWidth * TIM^.IMAGE^.wHeight * 2 + cIMAGEHeadSize;
end;
function GetTIMSize(TIM: PTIM): DWORD;
begin
Result := GetTIMCLUTSize(TIM) + GetTIMIMAGESize(TIM) + cTIMHeadSize;
end;
function CheckVersion(TIM: PTIM): Boolean;
begin
Result := (TIM^.HEAD^.bVersion in cTIMVersions);
end;
function CheckMagic(TIM: PTIM): Boolean;
begin
Result := (TIM^.HEAD^.bMagic = cTIMMagic);
end;
function CheckBpp(TIM: PTIM): Boolean;
begin
Result := (TIM^.HEAD^.bBPP in cTIMBpp);
end;
function CheckReserved(TIM: PTIM): Boolean;
begin
Result := (TIM^.HEAD^.bReserved1 = 0) and (TIM^.HEAD^.bReserved2 = 0);
end;
function TIMHasCLUT(TIM: PTIM): Boolean;
begin
Result := (TIM^.HEAD^.bBPP in cTIMCLUT);
end;
function CheckCLUTColors(TIM: PTIM): Boolean;
begin
Result := (TIM^.CLUT^.wColorsCount >= 1) and
(TIM^.CLUT^.wColorsCount <= cCLUTColorsMax);
end;
function CheckCLUTCount(TIM: PTIM): Boolean;
begin
Result := (TIM^.CLUT^.wClutsCount >= 1) and
(TIM^.CLUT^.wClutsCount <= cCLUTCountMax);
end;
function IWidthToRWidth(TIM: PTIM): word;
begin
case TIM^.HEAD^.bBPP of
cTIM4C, cTIM4NC:
Result := (TIM^.IMAGE^.wWidth * 4) and $FFFF;
cTIM8C, cTIM8NC:
Result := (TIM^.IMAGE^.wWidth * 2) and $FFFF;
cTIM16C, cTIM16NC, cTIMMix:
Result := TIM^.IMAGE^.wWidth;
cTIM24C, cTIM24NC:
Result := (Round(TIM^.IMAGE^.wWidth * 2 / 3)) and $FFFF;
else
Result := 0;
end;
end;
function CheckHEAD(TIM: PTIM): Boolean;
begin
Result := (CheckMagic(TIM) and CheckVersion(TIM) and CheckBpp(TIM) and
CheckReserved(TIM))
end;
function CheckCLUT(TIM: PTIM): Boolean;
begin
Result := (CheckCLUTColors(TIM) and CheckCLUTCount(TIM)
// Need to Check CLUT^.dwSize
);
end;
function CheckTIMSize(TIM: PTIM): Boolean;
begin
Result := (GetTIMSize(TIM) <= cTIMMaxSize);
end;
function TIMIsGood(TIM: PTIM): Boolean;
begin
Result := (TIM^.IMAGE^.dwSize = GetTIMIMAGESize(TIM));
end;
function CheckIMAGE(TIM: PTIM): Boolean;
begin
Result := False;
if (TIM^.IMAGE^.wWidth = 0) or (TIM^.IMAGE^.wHeight = 0) then
Exit;
if (TIM^.IMAGE^.wWidth > cIMAGEWidthMax) or
(TIM^.IMAGE^.wHeight > cIMAGEHeightMax) then
Exit;
Result := (not(TIM^.HEAD^.bBPP in cTIMWrongBads)) or TIMIsGood(TIM);
end;
procedure ClearTIM(TIM: PTIM);
begin
FillChar(TIM^.HEAD^, cTIMHeadSize, 0);
FillChar(TIM^.CLUT^, cCLUTHeadSize, 0);
FillChar(TIM^.IMAGE^, cIMAGEHeadSize, 0);
FillChar(TIM^.DATA^, cTIMMaxSize, 0);
end;
function LoadTimFromBuf(BUFFER: pointer; var TIM: PTIM;
var Position: DWORD): Boolean;
var
P: DWORD;
TIM_POS: DWORD;
begin
Result := False;
P := Position;
Inc(Position);
TIM_POS := P;
if TIM = nil then
TIM := CreateTIM;
Move(PBytesArray(BUFFER)^[P], TIM^.HEAD^, cTIMHeadSize);
if not CheckHEAD(TIM) then
Exit;
Inc(P, cTIMHeadSize);
if TIMHasCLUT(TIM) then
begin
Move(PBytesArray(BUFFER)^[P], TIM^.CLUT^, cCLUTHeadSize);
if not CheckCLUT(TIM) then
Exit;
Inc(P, GetTIMCLUTSize(TIM));
end;
Move(PBytesArray(BUFFER)^[P], TIM^.IMAGE^, cIMAGEHeadSize);
if not CheckIMAGE(TIM) then
Exit;
if not CheckTIMSize(TIM) then
Exit;
TIM^.dwSize := GetTIMSize(TIM);
TIM^.bGOOD := TIMIsGood(TIM);
Move(PBytesArray(BUFFER)^[TIM_POS], TIM^.DATA^[0], TIM^.dwSize);
Result := True;
end;
function LoadTimFromCDFile(const FileName: string; var Position: DWORD;
SIZE: DWORD): PTIM;
var
TimOffsetInSector, FirstPartSize, LastPartSize: DWORD;
TimSectorNumber, TimStartSectorPos: DWORD;
TIM_BUF: PTIMDataArray;
sImageStream: TFileStream;
Sector: TCDSector;
P, TIM_FULL_SECTORS: DWORD;
begin
sImageStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
TimSectorNumber := Position div cSectorSize + 1;
TimOffsetInSector := Position mod cSectorSize - cSectorInfoSize;
TimStartSectorPos := (TimSectorNumber - 1) * cSectorSize;
FirstPartSize := cSectorDataSize - TimOffsetInSector;
New(TIM_BUF);
P := 0;
if SIZE < FirstPartSize then
FirstPartSize := SIZE;
sImageStream.Seek(TimStartSectorPos, soBeginning);
sImageStream.Read(Sector, cSectorSize);
Move(Sector.dwData[TimOffsetInSector], TIM_BUF^[P], FirstPartSize);
Inc(P, FirstPartSize);
Inc(TimStartSectorPos, cSectorSize);
sImageStream.Seek(TimStartSectorPos, soBeginning);
TIM_FULL_SECTORS := (SIZE - P) div cSectorDataSize;
while TIM_FULL_SECTORS > 0 do
begin
sImageStream.Read(Sector, cSectorSize);
Move(Sector.dwData[0], TIM_BUF^[P], cSectorDataSize);
Inc(P, cSectorDataSize);
Inc(TimStartSectorPos, cSectorSize);
sImageStream.Seek(TimStartSectorPos, soBeginning);
Dec(TIM_FULL_SECTORS);
end;
sImageStream.Read(Sector, cSectorSize);
if SIZE > P then
begin
LastPartSize := SIZE - P;
Move(Sector.dwData[0], TIM_BUF^[P], LastPartSize);
end;
P := 0;
Result := nil;
LoadTimFromBuf(TIM_BUF, Result, P);
sImageStream.Free;
Dispose(TIM_BUF);
end;
function LoadTimFromStream(Stream: TStream; var Position: DWORD;
dwSize: DWORD): PTIM;
var
BUF: PTIMDataArray;
P: DWORD;
begin
Result := nil;
if dwSize > cTIMMaxSize then
Exit;
New(BUF);
Result := CreateTIM;
Stream.Seek(Position, soBeginning);
Stream.Read(BUF^[0], dwSize);
P := 0;
if not LoadTimFromBuf(BUF, Result, P) then
FreeTIM(Result);
Dispose(BUF);
end;
function LoadTimFromFile(const FileName: string; var Position: DWORD;
ImageScan: Boolean; dwSize: DWORD): PTIM;
var
sTIM: TFileStream;
begin
if not ImageScan then
begin
sTIM := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
Result := LoadTimFromStream(sTIM, Position, dwSize);
sTIM.Free;
Exit;
end;
Result := LoadTimFromCDFile(FileName, Position, dwSize);
end;
procedure SaveTimToFile(const FileName: string; TIM: PTIM);
var
tmp: TMemoryStream;
begin
if TIM = nil then
Exit;
tmp := TMemoryStream.Create;
tmp.Write(TIM^.DATA^[0], TIM^.dwSize);
tmp.SaveToFile(FileName);
tmp.Free;
end;
function CreateTIM: PTIM;
begin
New(Result);
New(Result^.HEAD);
New(Result^.CLUT);
New(Result^.IMAGE);
Result^.dwSize := 0;
Result^.dwTimPosition := 0;
Result^.dwTimNumber := 0;
Result^.bGOOD := False;
New(Result^.DATA);
ClearTIM(Result);
end;
procedure FreeTIM(TIM: PTIM);
begin
Dispose(TIM^.HEAD);
TIM^.HEAD := nil;
Dispose(TIM^.CLUT);
TIM^.CLUT := nil;
Dispose(TIM^.IMAGE);
TIM^.IMAGE := nil;
Dispose(TIM^.DATA);
TIM^.DATA := nil;
Dispose(TIM);
end;
function BppToBitMode(TIM: PTIM): byte;
begin
Result := 4;
if (TIM^.HEAD^.bBPP in cTIM4) then
begin
Result := 4;
Exit;
end;
if (TIM^.HEAD^.bBPP in cTIM8) then
begin
Result := 8;
Exit;
end;
if (TIM^.HEAD^.bBPP in cTIM16) then
begin
Result := 16;
Exit;
end;
if (TIM^.HEAD^.bBPP in cTIM24) then
begin
Result := 24;
Exit;
end;
if (TIM^.HEAD^.bBPP = cTIMMix) then
begin
Result := 16;
Exit;
end;
end;
function GetTimVersion(TIM: PTIM): byte;
begin
Result := TIM^.HEAD^.bVersion;
end;
function GetTimWidth(TIM: PTIM): word;
begin
Result := TIM^.IMAGE^.wWidth;
end;
function GetTimRealWidth(TIM: PTIM): word;
begin
Result := IWidthToRWidth(TIM);
end;
function GetTimColorsCount(TIM: PTIM): word;
begin
Result := TIM^.CLUT^.wColorsCount;
end;
function GetTimClutsCount(TIM: PTIM): word;
begin
Result := TIM^.CLUT^.wClutsCount;
end;
function GetTimBPP(TIM: PTIM): DWORD;
begin
Result := TIM^.HEAD^.bBPP;
end;
function GetTimClutSizeHeader(TIM: PTIM): DWORD;
begin
Result := TIM^.CLUT^.dwSize;
end;
function GetTimClutVRAMX(TIM: PTIM): word;
begin
Result := TIM^.CLUT^.wVRAMX;
end;
function GetTimClutVRAMY(TIM: PTIM): word;
begin
Result := TIM^.CLUT^.wVRAMY;
end;
function GetTimImageSizeHeader(TIM: PTIM): DWORD;
begin
Result := TIM^.IMAGE^.dwSize;
end;
function GetTimImageVRAMX(TIM: PTIM): word;
begin
Result := TIM^.IMAGE^.wVRAMX;
end;
function GetTimImageVRAMY(TIM: PTIM): word;
begin
Result := TIM^.IMAGE^.wVRAMY;
end;
end.